├── .github └── workflows │ ├── cabal.project.local.ci │ └── haskell.yml ├── .gitignore ├── .travis.yml ├── AUTHORS ├── COPYING ├── ChangeLog ├── GNUmakefile ├── HsOpenSSL.cabal ├── OpenSSL.hs ├── OpenSSL ├── ASN1.hsc ├── BIO.hs ├── BN.hsc ├── Cipher.hsc ├── DER.hsc ├── DH.hs ├── DH │ └── Internal.hs ├── DSA.hsc ├── ERR.hs ├── EVP │ ├── Base64.hs │ ├── Cipher.hs │ ├── Digest.hsc │ ├── Internal.hsc │ ├── Open.hs │ ├── PKey.hsc │ ├── Seal.hs │ ├── Sign.hs │ └── Verify.hs ├── Objects.hsc ├── PEM.hs ├── PKCS7.hsc ├── RSA.hsc ├── Random.hs ├── SSL │ └── Option.hsc ├── Session.hsc ├── Stack.hsc ├── Utils.hs ├── X509.hsc └── X509 │ ├── Name.hsc │ ├── Request.hs │ ├── Revocation.hsc │ └── Store.hsc ├── README.md ├── Test └── OpenSSL │ ├── Cipher.hs │ ├── DER.hs │ ├── DSA.hs │ ├── EVP │ ├── Base64.hs │ └── Digest.hs │ └── TestUtils.hs ├── cabal-package.mk ├── cbits ├── HsOpenSSL.c ├── HsOpenSSL.h ├── mutex-pthread.c ├── mutex-win.c └── mutex.h └── examples ├── Client.hs ├── GenRSAKey.hs ├── HelloWorld.hs ├── Makefile ├── PKCS7.hs ├── Server.hs ├── server.crt └── server.pem /.github/workflows/cabal.project.local.ci: -------------------------------------------------------------------------------- 1 | package HsOpenSSL 2 | flags: +use-pkg-config 3 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | create: 6 | 7 | jobs: 8 | build: 9 | runs-on: ${{ matrix.os }} 10 | 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | ghc: 15 | - "8.0.2" 16 | - "8.2.2" 17 | - "8.4.4" 18 | - "8.6.5" 19 | - "8.8.4" 20 | - "8.10.7" 21 | - "9.0.2" 22 | - "9.2.8" 23 | - "9.4.8" 24 | - "9.6.6" 25 | - "9.8.4" 26 | - "9.10.1" 27 | - "9.12.1" 28 | # FIXME: Add windows-latest back to CI once it is passing. 29 | os: [ubuntu-latest] 30 | 31 | # Action fails to install GHC < 8.10 on OSX with a generic error 32 | # messsage: 33 | # 34 | # Error: All install methods for ghc 8.0.2 failed 35 | # 36 | # On the other hand, 8.10 and 9.0 fail due to LLVM: 37 | # 38 | # Warning: Couldn't figure out LLVM version! 39 | # Make sure you have installed LLVM between [9 and 13) 40 | include: 41 | - {ghc: "8.0.2" , os: "macos-13"} 42 | - {ghc: "8.2.2" , os: "macos-13"} 43 | - {ghc: "8.4.4" , os: "macos-13"} 44 | - {ghc: "8.6.5" , os: "macos-13"} 45 | - {ghc: "8.8.4" , os: "macos-13"} 46 | - {ghc: "8.10.7", os: "macos-13"} 47 | - {ghc: "9.0.2" , os: "macos-13"} 48 | - {ghc: "9.2.8" , os: "macos-latest"} 49 | - {ghc: "9.4.8" , os: "macos-latest"} 50 | - {ghc: "9.6.6" , os: "macos-latest"} 51 | - {ghc: "9.8.4" , os: "macos-latest"} 52 | - {ghc: "9.10.1", os: "macos-latest"} 53 | - {ghc: "9.12.1", os: "macos-latest"} 54 | env: 55 | # OpenSSL is installed in a non-standard location in MacOS. See 56 | # https://github.com/actions/virtual-environments/blob/main/images/macos/macos-latest-Readme.md 57 | PKG_CONFIG_PATH: ${{ (matrix.os == 'macos-latest' && '/usr/lib/pkgconfig:/usr/local/opt/openssl@1.1/lib/pkgconfig') || (matrix.os == 'ubuntu-latest' && '/usr/lib/pkgconfig:/usr/local/lib/pkgconfig') || '' }} 58 | 59 | # FIXME: this is arguably a bug, and pkg-config should return the right values! 60 | LD_LIBRARY_PATH: ${{ (matrix.os != 'windows-latest' && '/usr/local/lib') || '' }} 61 | 62 | steps: 63 | - uses: haskell-actions/setup@v2 64 | with: 65 | ghc-version: ${{ matrix.ghc }} 66 | 67 | - name: "WIN: Install System Dependencies via pacman (msys2)" 68 | if: runner.os == 'Windows' 69 | run: | 70 | # ghcup should be installed on current GHA Windows runners. Let's use ghcup to run 71 | # pacman, to install the necessary dependencies, ... 72 | ghcup run -- pacman --noconfirm -S ` 73 | mingw-w64-x86_64-pkg-config ` 74 | mingw-w64-x86_64-openssl ` 75 | base-devel ` 76 | autoconf-wrapper ` 77 | autoconf ` 78 | automake ` 79 | libtool ` 80 | make 81 | 82 | # this seems to break something. It _must_ come after the pacman setup 83 | # above. It appears as if PATHEXT is set _after_ ghcup install ghc/cabal, and 84 | # as such we'd need pacman.exe instead. 85 | - name: "WIN: Setup Haskell" 86 | if: runner.os == 'Windows' 87 | run: | 88 | # Use GHCUP to manage ghc/cabal 89 | ghcup install ghc --set ${{ matrix.ghc }} 90 | ghcup install cabal --set 3.6.2.0 91 | 92 | ghc --version 93 | cabal --version 94 | 95 | - name: "WIN: fixup cabal config" 96 | if: runner.os == 'Windows' 97 | run: | 98 | # make sure cabal knows about msys64, and mingw64 tools. Not clear why C:/cabal/config is empty 99 | # and C:/cabal doesn't even exist. The ghcup bootstrap file should have create it in the image: 100 | # See https://github.com/haskell/ghcup-hs/blob/787edc17af4907dbc51c85e25c490edd8d68b80b/scripts/bootstrap/bootstrap-haskell#L591 101 | # So we'll do it by hand here for now. 102 | # 103 | # We'll _not_ add extra-include-dirs, or extra-lib-dirs, and rely on what's shipped with GHC. 104 | # https://github.com/msys2/MINGW-packages/issues/10837#issuecomment-1047105402 105 | # https://gitlab.haskell.org/ghc/ghc/-/issues/21111 106 | # if we _do_ want them, this would be the lines to add below 107 | 108 | $ghcMingwDir = Join-Path -Path $(ghc --print-libdir) ` 109 | -ChildPath ../mingw/x86_64-*-mingw32/lib/ ` 110 | -Resolve 111 | 112 | cabal user-config -a "extra-prog-path: C:/msys64/mingw64/bin, C:/msys64/usr/bin" ` 113 | -a "extra-include-dirs: C:/msys64/mingw64/include" ` 114 | -a ("extra-lib-dirs: {0}, C:/msys64/mingw64/lib" -f $ghcMingwDir) ` 115 | -f init 116 | 117 | - name: "Setup cabal-store" 118 | id: cabal-store 119 | shell: bash 120 | run: | 121 | cabal_config_file="$(cabal help user-config | tail -n 1 | xargs)" 122 | 123 | if [[ '${{ runner.os }}' != 'Windows' ]]; then 124 | echo "cabal-store=$(dirname "$cabal_config_file")/store" | tee -a "$GITHUB_OUTPUT" 125 | else 126 | echo "cabal-store=C:\\cabal\\store" | tee -a "$GITHUB_OUTPUT" 127 | fi 128 | 129 | - name: "Check cabal-store" 130 | shell: bash 131 | run: echo '${{ steps.cabal-store.outputs.cabal-store }}' 132 | 133 | - uses: actions/checkout@v4 134 | 135 | - name: "[PowerShell] Add build script path" 136 | if: runner.os == 'Windows' 137 | shell: pwsh 138 | run: Add-Content $env:GITHUB_PATH "$(pwd)/.github/bin" 139 | 140 | - name: "[Bash] Add build script path" 141 | if: runner.os != 'Windows' 142 | run: echo "$(pwd)/.github/bin" >> $GITHUB_PATH 143 | 144 | - name: "LINUX: Install build environment (apt-get)" 145 | if: runner.os == 'Linux' 146 | run: | 147 | sudo apt-get update 148 | sudo apt-get -y install libsystemd0 libsystemd-dev 149 | sudo apt-get -y remove --purge software-properties-common 150 | sudo apt-get -y autoremove 151 | 152 | - name: "MAC: Install build environment" 153 | if: runner.os == 'macOS' 154 | run: brew install autoconf automake libtool openssl@3 155 | 156 | - name: Cabal update 157 | run: cabal update 158 | 159 | - name: Configure build 160 | shell: bash 161 | run: | 162 | if [ "${{github.event.inputs.tests}}" == "all" ]; then 163 | echo "Reconfigure cabal projects to run tests for all dependencies" 164 | sed -i 's|tests: False|tests: True|g' cabal.project 165 | fi 166 | 167 | cp ".github/workflows/cabal.project.local.ci" cabal.project.local 168 | 169 | echo "# cabal.project.local" 170 | cat cabal.project.local 171 | 172 | - name: Record dependencies 173 | id: record-deps 174 | run: | 175 | cabal build all --dry-run 176 | cat dist-newstyle/cache/plan.json | jq -r '."install-plan"[].id' | sort | uniq > dependencies.txt 177 | 178 | - name: Cache Cabal store 179 | uses: actions/cache@v4 180 | with: 181 | path: ${{ steps.cabal-store.outputs.cabal-store }} 182 | key: cache-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }} 183 | restore-keys: | 184 | cache-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }} 185 | cache-${{ env.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }} 186 | 187 | - name: Build 188 | run: cabal build all --enable-tests 189 | 190 | - name: Run tests 191 | env: 192 | TMPDIR: ${{ runner.temp }} 193 | TMP: ${{ runner.temp }} 194 | KEEP_WORKSPACE: 1 195 | run: | 196 | # The tests call out to msys2 commands. We generally do not want to mix toolchains, so 197 | # we are very deliberate about only adding msys64 to the path where absolutely necessary. 198 | ${{ (runner.os == 'Windows' && '$env:PATH=("C:\msys64\mingw64\bin;{0}" -f $env:PATH)') || '' }} 199 | cabal test all --enable-tests 200 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | 4 | Setup 5 | dist 6 | dist-newstyle 7 | examples/GenRSAKey 8 | examples/HelloWorld 9 | examples/PKCS7 10 | examples/Server 11 | 12 | .cabal-sandbox 13 | cabal.sandbox.config 14 | cabal.project.local 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'HsOpenSSL.cabal' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | # version: 0.5.20190908 8 | # 9 | language: c 10 | dist: xenial 11 | git: 12 | # whether to recursively clone submodules 13 | submodules: false 14 | cache: 15 | directories: 16 | - $HOME/.cabal/packages 17 | - $HOME/.cabal/store 18 | before_cache: 19 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 23 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 26 | - rm -rfv $CABALHOME/packages/head.hackage 27 | matrix: 28 | include: 29 | - compiler: ghc-8.8.1 30 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} 31 | - compiler: ghc-8.6.5 32 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}} 33 | - compiler: ghc-8.4.4 34 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}} 35 | - compiler: ghc-8.2.2 36 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}} 37 | - compiler: ghc-8.0.2 38 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}} 39 | - compiler: ghc-7.10.3 40 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-3.0"]}} 41 | - compiler: ghc-7.8.4 42 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-3.0"]}} 43 | - compiler: ghc-7.6.3 44 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.6.3","cabal-install-3.0"]}} 45 | - compiler: ghc-7.4.2 46 | addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.4.2","cabal-install-3.0"]}} 47 | before_install: 48 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 49 | - WITHCOMPILER="-w $HC" 50 | - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') 51 | - HCPKG="$HC-pkg" 52 | - unset CC 53 | - CABAL=/opt/ghc/bin/cabal 54 | - CABALHOME=$HOME/.cabal 55 | - export PATH="$CABALHOME/bin:$PATH" 56 | - TOP=$(pwd) 57 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 58 | - echo $HCNUMVER 59 | - CABAL="$CABAL -vnormal+nowrap+markoutput" 60 | - set -o pipefail 61 | - | 62 | echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk 63 | echo 'BEGIN { state = "output"; }' >> .colorful.awk 64 | echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk 65 | echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk 66 | echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk 67 | echo ' if (state == "cabal") {' >> .colorful.awk 68 | echo ' print blue($0)' >> .colorful.awk 69 | echo ' } else {' >> .colorful.awk 70 | echo ' print $0' >> .colorful.awk 71 | echo ' }' >> .colorful.awk 72 | echo '}' >> .colorful.awk 73 | - cat .colorful.awk 74 | - | 75 | color_cabal_output () { 76 | awk -f $TOP/.colorful.awk 77 | } 78 | - echo text | color_cabal_output 79 | install: 80 | - ${CABAL} --version 81 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 82 | - TEST=--enable-tests 83 | - BENCH=--enable-benchmarks 84 | - HEADHACKAGE=false 85 | - rm -f $CABALHOME/config 86 | - | 87 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 88 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 89 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 90 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 91 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 92 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 93 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 94 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 95 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 96 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 97 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 98 | echo "install-dirs user" >> $CABALHOME/config 99 | echo " prefix: $CABALHOME" >> $CABALHOME/config 100 | echo "repository hackage.haskell.org" >> $CABALHOME/config 101 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 102 | - | 103 | echo "program-default-options" >> $CABALHOME/config 104 | echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config 105 | - cat $CABALHOME/config 106 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 107 | - travis_retry ${CABAL} v2-update -v 108 | # Generate cabal.project 109 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 110 | - touch cabal.project 111 | - | 112 | echo "packages: ." >> cabal.project 113 | - | 114 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(HsOpenSSL)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 115 | - cat cabal.project || true 116 | - cat cabal.project.local || true 117 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 118 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output 119 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 120 | - rm cabal.project.freeze 121 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output 122 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output 123 | script: 124 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 125 | # Packaging... 126 | - ${CABAL} v2-sdist all | color_cabal_output 127 | # Unpacking... 128 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 129 | - cd ${DISTDIR} || false 130 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 131 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 132 | - PKGDIR_HsOpenSSL="$(find . -maxdepth 1 -type d -regex '.*/HsOpenSSL-[0-9.]*')" 133 | # Generate cabal.project 134 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 135 | - touch cabal.project 136 | - | 137 | echo "packages: ${PKGDIR_HsOpenSSL}" >> cabal.project 138 | - | 139 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(HsOpenSSL)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 140 | - cat cabal.project || true 141 | - cat cabal.project.local || true 142 | # Building... 143 | # this builds all libraries and executables (without tests/benchmarks) 144 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output 145 | # Building with tests and benchmarks... 146 | # build & run tests, build benchmarks 147 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output 148 | # Testing... 149 | - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output 150 | # cabal check... 151 | - (cd ${PKGDIR_HsOpenSSL} && ${CABAL} -vnormal check) 152 | # haddock... 153 | - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output 154 | # Building without installed constraints for packages in global-db... 155 | - rm -f cabal.project.local 156 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output 157 | 158 | # REGENDATA ["HsOpenSSL.cabal"] 159 | # EOF 160 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | This is an incomplete list of contributors to the HsOpenSSL: 2 | 3 | * Adam Langley 4 | * John Van Enk and his friend 5 | * Mikhail Vorozhtsov 6 | * Taru Karttunen 7 | * PHO 8 | 9 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Creative Commons Legal Code 2 | 3 | CC0 1.0 Universal 4 | 5 | CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE 6 | LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN 7 | ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS 8 | INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES 9 | REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS 10 | PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM 11 | THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED 12 | HEREUNDER. 13 | 14 | Statement of Purpose 15 | 16 | The laws of most jurisdictions throughout the world automatically confer 17 | exclusive Copyright and Related Rights (defined below) upon the creator 18 | and subsequent owner(s) (each and all, an "owner") of an original work of 19 | authorship and/or a database (each, a "Work"). 20 | 21 | Certain owners wish to permanently relinquish those rights to a Work for 22 | the purpose of contributing to a commons of creative, cultural and 23 | scientific works ("Commons") that the public can reliably and without fear 24 | of later claims of infringement build upon, modify, incorporate in other 25 | works, reuse and redistribute as freely as possible in any form whatsoever 26 | and for any purposes, including without limitation commercial purposes. 27 | These owners may contribute to the Commons to promote the ideal of a free 28 | culture and the further production of creative, cultural and scientific 29 | works, or to gain reputation or greater distribution for their Work in 30 | part through the use and efforts of others. 31 | 32 | For these and/or other purposes and motivations, and without any 33 | expectation of additional consideration or compensation, the person 34 | associating CC0 with a Work (the "Affirmer"), to the extent that he or she 35 | is an owner of Copyright and Related Rights in the Work, voluntarily 36 | elects to apply CC0 to the Work and publicly distribute the Work under its 37 | terms, with knowledge of his or her Copyright and Related Rights in the 38 | Work and the meaning and intended legal effect of CC0 on those rights. 39 | 40 | 1. Copyright and Related Rights. A Work made available under CC0 may be 41 | protected by copyright and related or neighboring rights ("Copyright and 42 | Related Rights"). Copyright and Related Rights include, but are not 43 | limited to, the following: 44 | 45 | i. the right to reproduce, adapt, distribute, perform, display, 46 | communicate, and translate a Work; 47 | ii. moral rights retained by the original author(s) and/or performer(s); 48 | iii. publicity and privacy rights pertaining to a person's image or 49 | likeness depicted in a Work; 50 | iv. rights protecting against unfair competition in regards to a Work, 51 | subject to the limitations in paragraph 4(a), below; 52 | v. rights protecting the extraction, dissemination, use and reuse of data 53 | in a Work; 54 | vi. database rights (such as those arising under Directive 96/9/EC of the 55 | European Parliament and of the Council of 11 March 1996 on the legal 56 | protection of databases, and under any national implementation 57 | thereof, including any amended or successor version of such 58 | directive); and 59 | vii. other similar, equivalent or corresponding rights throughout the 60 | world based on applicable law or treaty, and any national 61 | implementations thereof. 62 | 63 | 2. Waiver. To the greatest extent permitted by, but not in contravention 64 | of, applicable law, Affirmer hereby overtly, fully, permanently, 65 | irrevocably and unconditionally waives, abandons, and surrenders all of 66 | Affirmer's Copyright and Related Rights and associated claims and causes 67 | of action, whether now known or unknown (including existing as well as 68 | future claims and causes of action), in the Work (i) in all territories 69 | worldwide, (ii) for the maximum duration provided by applicable law or 70 | treaty (including future time extensions), (iii) in any current or future 71 | medium and for any number of copies, and (iv) for any purpose whatsoever, 72 | including without limitation commercial, advertising or promotional 73 | purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each 74 | member of the public at large and to the detriment of Affirmer's heirs and 75 | successors, fully intending that such Waiver shall not be subject to 76 | revocation, rescission, cancellation, termination, or any other legal or 77 | equitable action to disrupt the quiet enjoyment of the Work by the public 78 | as contemplated by Affirmer's express Statement of Purpose. 79 | 80 | 3. Public License Fallback. Should any part of the Waiver for any reason 81 | be judged legally invalid or ineffective under applicable law, then the 82 | Waiver shall be preserved to the maximum extent permitted taking into 83 | account Affirmer's express Statement of Purpose. In addition, to the 84 | extent the Waiver is so judged Affirmer hereby grants to each affected 85 | person a royalty-free, non transferable, non sublicensable, non exclusive, 86 | irrevocable and unconditional license to exercise Affirmer's Copyright and 87 | Related Rights in the Work (i) in all territories worldwide, (ii) for the 88 | maximum duration provided by applicable law or treaty (including future 89 | time extensions), (iii) in any current or future medium and for any number 90 | of copies, and (iv) for any purpose whatsoever, including without 91 | limitation commercial, advertising or promotional purposes (the 92 | "License"). The License shall be deemed effective as of the date CC0 was 93 | applied by Affirmer to the Work. Should any part of the License for any 94 | reason be judged legally invalid or ineffective under applicable law, such 95 | partial invalidity or ineffectiveness shall not invalidate the remainder 96 | of the License, and in such case Affirmer hereby affirms that he or she 97 | will not (i) exercise any of his or her remaining Copyright and Related 98 | Rights in the Work or (ii) assert any associated claims and causes of 99 | action with respect to the Work, in either case contrary to Affirmer's 100 | express Statement of Purpose. 101 | 102 | 4. Limitations and Disclaimers. 103 | 104 | a. No trademark or patent rights held by Affirmer are waived, abandoned, 105 | surrendered, licensed or otherwise affected by this document. 106 | b. Affirmer offers the Work as-is and makes no representations or 107 | warranties of any kind concerning the Work, express, implied, 108 | statutory or otherwise, including without limitation warranties of 109 | title, merchantability, fitness for a particular purpose, non 110 | infringement, or the absence of latent or other defects, accuracy, or 111 | the present or absence of errors, whether or not discoverable, all to 112 | the greatest extent permissible under applicable law. 113 | c. Affirmer disclaims responsibility for clearing rights of other persons 114 | that may apply to the Work or any use thereof, including without 115 | limitation any person's Copyright and Related Rights in the Work. 116 | Further, Affirmer disclaims responsibility for obtaining any necessary 117 | consents, permissions or other rights required for any use of the 118 | Work. 119 | d. Affirmer understands and acknowledges that Creative Commons is not a 120 | party to this document and has no duty or obligation with respect to 121 | this CC0 or use of the Work. 122 | -------------------------------------------------------------------------------- /GNUmakefile: -------------------------------------------------------------------------------- 1 | RUN_COMMAND = $(MAKE) -C examples run 2 | 3 | CONFIGURE_ARGS = \ 4 | --enable-tests \ 5 | -O2 \ 6 | -p \ 7 | --extra-include-dirs=/usr/pkg/include \ 8 | --extra-lib-dirs=/usr/pkg/lib 9 | 10 | include cabal-package.mk 11 | -------------------------------------------------------------------------------- /HsOpenSSL.cabal: -------------------------------------------------------------------------------- 1 | Name: HsOpenSSL 2 | Synopsis: Partial OpenSSL binding for Haskell 3 | Description: 4 | HsOpenSSL is an OpenSSL binding for Haskell. It can generate RSA 5 | and DSA keys, read and write PEM files, generate message digests, 6 | sign and verify messages, encrypt and decrypt messages. It has 7 | also some capabilities of creating SSL clients and servers. 8 | . 9 | This package is in production use by a number of Haskell based 10 | systems and stable. You may also be interested in the @tls@ package, 11 | , which is a pure Haskell 12 | implementation of SSL. 13 | Version: 0.11.7.9 14 | License: PublicDomain 15 | License-File: COPYING 16 | Author: Adam Langley, Mikhail Vorozhtsov, PHO, Taru Karttunen 17 | Maintainer: Vladimir Shabanov 18 | Stability: stable 19 | Homepage: https://github.com/haskell-cryptography/HsOpenSSL 20 | Bug-Reports: https://github.com/haskell-cryptography/HsOpenSSL/issues 21 | Category: Cryptography 22 | Cabal-Version: 1.18 23 | Tested-With: 24 | GHC ==8.0.2 25 | || ==8.2.2 26 | || ==8.4.4 27 | || ==8.6.5 28 | || ==8.8.4 29 | || ==8.10.7 30 | || ==9.0.2 31 | || ==9.2.8 32 | || ==9.4.8 33 | || ==9.6.6 34 | || ==9.8.1 35 | || ==9.10.1 36 | Build-Type: Simple 37 | Extra-Doc-Files: 38 | AUTHORS 39 | ChangeLog 40 | README.md 41 | Extra-Source-Files: 42 | cbits/HsOpenSSL.h 43 | cbits/mutex.h 44 | examples/Makefile 45 | examples/GenRSAKey.hs 46 | examples/HelloWorld.hs 47 | examples/PKCS7.hs 48 | examples/Server.hs 49 | examples/server.crt 50 | examples/server.pem 51 | 52 | Source-Repository head 53 | Type: git 54 | Location: https://github.com/haskell-cryptography/HsOpenSSL.git 55 | 56 | Flag fast-bignum 57 | Description: 58 | Enable fast moving of bignums between OpenSSL and GMP (GHC and OpenSSL version < 1.1.0 only). 59 | Default: 60 | False 61 | 62 | Flag homebrew-openssl 63 | Description: 64 | Use Homebrew version of OpenSSL (macOS only). 65 | Default: 66 | False 67 | 68 | Flag macports-openssl 69 | Description: 70 | Use MacPorts version of OpenSSL (macOS only). 71 | Default: 72 | False 73 | 74 | Flag use-pkg-config 75 | Description: 76 | Use pkg-config to find OpenSSL (macOS and linux only). 77 | Default: 78 | False 79 | Manual: 80 | True 81 | 82 | Library 83 | Build-Depends: 84 | base >= 4.8 && < 5, 85 | bytestring >= 0.9 && < 0.13, 86 | network >= 2.1 && < 3.3, 87 | time >= 1.5 && < 1.15 88 | 89 | Build-Tools: hsc2hs >= 0.67 90 | 91 | if flag(fast-bignum) && impl(ghc >= 7.10.1) 92 | -- only new integer-gmp 1.0.0 is supported 93 | -- and it only works in OpenSSL version < 1.1.0 where BIGNUM 94 | -- wasn't opaque structure. 95 | CPP-Options: -DFAST_BIGNUM 96 | Build-Depends: integer-gmp >= 1.0.0 && < 1.1.0 97 | 98 | if os(darwin) && flag(homebrew-openssl) 99 | if arch(aarch64) 100 | Include-Dirs: /opt/homebrew/opt/openssl/include 101 | Extra-Lib-Dirs: /opt/homebrew/opt/openssl/lib 102 | else 103 | Include-Dirs: /usr/local/opt/openssl/include 104 | Extra-Lib-Dirs: /usr/local/opt/openssl/lib 105 | 106 | if os(darwin) && flag(macports-openssl) 107 | Include-Dirs: /opt/local/include 108 | Extra-Lib-Dirs: /opt/local/lib 109 | 110 | if flag(use-pkg-config) 111 | pkgconfig-depends: libssl, libcrypto 112 | else 113 | Extra-Libraries: ssl crypto 114 | 115 | if os(mingw32) 116 | C-Sources: cbits/mutex-win.c 117 | CC-Options: -D MINGW32 -DNOCRYPT 118 | CPP-Options: -DCALLCONV=stdcall 119 | else 120 | C-Sources: cbits/mutex-pthread.c 121 | CC-Options: -D PTHREAD 122 | CPP-Options: -DCALLCONV=ccall 123 | 124 | Exposed-Modules: 125 | OpenSSL 126 | OpenSSL.BN 127 | OpenSSL.DER 128 | OpenSSL.EVP.Base64 129 | OpenSSL.EVP.Cipher 130 | OpenSSL.EVP.Digest 131 | OpenSSL.EVP.Internal 132 | OpenSSL.EVP.Open 133 | OpenSSL.EVP.PKey 134 | OpenSSL.EVP.Seal 135 | OpenSSL.EVP.Sign 136 | OpenSSL.EVP.Verify 137 | OpenSSL.Cipher 138 | OpenSSL.PEM 139 | OpenSSL.PKCS7 140 | OpenSSL.Random 141 | OpenSSL.DSA 142 | OpenSSL.RSA 143 | OpenSSL.X509 144 | OpenSSL.X509.Revocation 145 | OpenSSL.X509.Request 146 | OpenSSL.X509.Store 147 | OpenSSL.Session 148 | OpenSSL.DH 149 | Other-Modules: 150 | OpenSSL.ASN1 151 | OpenSSL.BIO 152 | OpenSSL.ERR 153 | OpenSSL.Objects 154 | OpenSSL.SSL.Option 155 | OpenSSL.Stack 156 | OpenSSL.Utils 157 | OpenSSL.X509.Name 158 | OpenSSL.DH.Internal 159 | Default-Language: 160 | Haskell2010 161 | GHC-Options: 162 | -Wall -optc=-Wno-discarded-qualifiers -optc=-Wno-deprecated-declarations -optc=-Wno-incompatible-pointer-types 163 | C-Sources: 164 | cbits/HsOpenSSL.c 165 | Include-Dirs: 166 | cbits 167 | Includes: 168 | openssl/asn1.h 169 | 170 | Test-Suite test-dsa 171 | Type: exitcode-stdio-1.0 172 | Main-Is: DSA.hs 173 | HS-Source-Dirs: Test/OpenSSL 174 | Other-Modules: TestUtils 175 | Build-Depends: 176 | HsOpenSSL, 177 | base >= 4.8 && < 5, 178 | bytestring >= 0.9 && < 0.13 179 | Default-Language: 180 | Haskell2010 181 | GHC-Options: 182 | -Wall 183 | 184 | Test-Suite test-der 185 | Type: exitcode-stdio-1.0 186 | Main-Is: DER.hs 187 | HS-Source-Dirs: Test/OpenSSL 188 | Other-Modules: TestUtils 189 | Build-Depends: 190 | HsOpenSSL, 191 | base >= 4.8 && < 5 192 | Default-Language: 193 | Haskell2010 194 | GHC-Options: 195 | -Wall 196 | 197 | Test-Suite test-evp-base64 198 | Type: exitcode-stdio-1.0 199 | Main-Is: EVP/Base64.hs 200 | HS-Source-Dirs: Test/OpenSSL 201 | Other-Modules: TestUtils 202 | Build-Depends: 203 | HsOpenSSL, 204 | base >= 4.8 && < 5, 205 | bytestring >= 0.9 && < 0.13 206 | Default-Language: 207 | Haskell2010 208 | GHC-Options: 209 | -Wall 210 | 211 | Test-Suite test-evp-digest 212 | Type: exitcode-stdio-1.0 213 | Main-Is: EVP/Digest.hs 214 | HS-Source-Dirs: Test/OpenSSL 215 | Other-Modules: TestUtils 216 | Build-Depends: 217 | HsOpenSSL, 218 | base >= 4.8 && < 5, 219 | bytestring >= 0.9 && < 0.13 220 | Default-Language: 221 | Haskell2010 222 | GHC-Options: 223 | -Wall 224 | -------------------------------------------------------------------------------- /OpenSSL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | -- |HsOpenSSL is an OpenSSL binding for Haskell. It can generate RSA 5 | -- and DSA keys, read and write PEM files, generate message digests, 6 | -- sign and verify messages, encrypt and decrypt messages. 7 | -- 8 | -- Please note that this project has started at the time when there 9 | -- were no pure-Haskell implementations of TLS. Now there is tls 10 | -- package (), which looks 11 | -- pretty saner than HsOpenSSL especially for initialisation and error 12 | -- handlings. So PHO (the initial author of HsOpenSSL) wants to 13 | -- encourage you to use and improve the tls package instead as long as 14 | -- possible. The only problem is that the tls package has not received 15 | -- as much review as OpenSSL from cryptography specialists yet, thus 16 | -- we can't assume it's secure enough. 17 | -- 18 | -- Features that aren't (yet) supported: 19 | -- 20 | -- [/SSL network connection/] ssl(3) functionalities aren't fully 21 | -- covered yet. See "OpenSSL.Session". 22 | -- 23 | -- [/Complete coverage of Low-level API to symmetric ciphers/] Only 24 | -- high-level APIs (EVP and BIO) are fully available. But I believe 25 | -- no one will be lost without functions like @DES_set_odd_parity@. 26 | -- 27 | -- [/Low-level API to asymmetric ciphers/] Only a high-level API 28 | -- (EVP) is available. But I believe no one will complain about the 29 | -- absence of functions like @RSA_public_encrypt@. 30 | -- 31 | -- [/X.509 v3 extension handling/] It should be supported in the 32 | -- future. 33 | -- 34 | -- [/Low-level API to message digest functions/] Just use EVP 35 | -- instead of something like @MD5_Update@. 36 | -- 37 | -- [/API to PKCS#12 functionality/] It should be covered someday. 38 | -- 39 | -- [/BIO/] BIO isn't needed because we are Haskell hackers. Though 40 | -- HsOpenSSL itself uses BIO internally. 41 | -- 42 | -- [/ENGINE cryptographic module/] The default implementations work 43 | -- very well, don't they? 44 | module OpenSSL 45 | ( withOpenSSL 46 | ) 47 | where 48 | import Control.Concurrent.MVar 49 | import Control.Monad 50 | import System.IO.Unsafe 51 | 52 | #if !MIN_VERSION_base(4,6,0) 53 | import Control.Exception (onException, mask_) 54 | #endif 55 | 56 | foreign import capi "HsOpenSSL.h HsOpenSSL_init" 57 | initSSL :: IO () 58 | 59 | foreign import capi "HsOpenSSL.h HsOpenSSL_setupMutex" 60 | setupMutex :: IO () 61 | 62 | 63 | -- |Computation of @'withOpenSSL' action@ initializes the OpenSSL 64 | -- library as necessary, and computes @action@. Every application that 65 | -- uses HsOpenSSL must wrap any operations involving OpenSSL with 66 | -- 'withOpenSSL', or they might crash: 67 | -- 68 | -- > module Main where 69 | -- > import OpenSSL 70 | -- > 71 | -- > main :: IO () 72 | -- > main = withOpenSSL $ 73 | -- > do ... 74 | -- 75 | -- Since 0.10.3.5, 'withOpenSSL' is safe to be applied 76 | -- redundantly. Library authors may wish to wrap their functions not 77 | -- to force their users to think about initialization: 78 | -- 79 | -- > get :: URI -> IO Response 80 | -- > get uri = withOpenSSL $ internalImplementationOfGet uri 81 | -- 82 | withOpenSSL :: IO a -> IO a 83 | withOpenSSL io 84 | -- We don't want our initialisation sequence to be interrupted 85 | -- halfway. 86 | = do modifyMVarMasked_ isInitialised $ \ done -> 87 | do unless done $ do initSSL 88 | setupMutex 89 | return True 90 | io 91 | 92 | #if !MIN_VERSION_base(4,6,0) 93 | {-| 94 | Like 'modifyMVar_', but the @IO@ action in the second argument is executed with 95 | asynchronous exceptions masked. 96 | -} 97 | {-# INLINE modifyMVarMasked_ #-} 98 | modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO () 99 | modifyMVarMasked_ m io = 100 | mask_ $ do 101 | a <- takeMVar m 102 | a' <- io a `onException` putMVar m a 103 | putMVar m a' 104 | #endif 105 | 106 | -- This variable must be atomically fetched/stored not to initialise 107 | -- the library twice. 108 | isInitialised :: MVar Bool 109 | {-# NOINLINE isInitialised #-} 110 | isInitialised = 111 | unsafePerformIO $ newMVar False 112 | -------------------------------------------------------------------------------- /OpenSSL/ASN1.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE ForeignFunctionInterface #-} 4 | {-# LANGUAGE CApiFFI #-} 5 | module OpenSSL.ASN1 6 | ( ASN1_OBJECT 7 | , obj2nid 8 | , nid2sn 9 | , nid2ln 10 | 11 | , ASN1_STRING 12 | , peekASN1String 13 | 14 | , ASN1_INTEGER 15 | , peekASN1Integer 16 | , withASN1Integer 17 | 18 | , ASN1_TIME 19 | , peekASN1Time 20 | , withASN1Time 21 | ) 22 | where 23 | #include "HsOpenSSL.h" 24 | import Control.Exception 25 | import Data.Time.Clock 26 | import Data.Time.Clock.POSIX 27 | import Data.Time.Format 28 | import Foreign 29 | import Foreign.C 30 | import OpenSSL.BIO 31 | import OpenSSL.BN 32 | import OpenSSL.Utils 33 | 34 | #if !MIN_VERSION_time(1,5,0) 35 | import System.Locale 36 | #endif 37 | 38 | {- ASN1_OBJECT --------------------------------------------------------------- -} 39 | 40 | data {-# CTYPE "openssl/asn1.h" "ASN1_OBJECT" #-} ASN1_OBJECT 41 | 42 | foreign import capi unsafe "openssl/objects.h OBJ_obj2nid" 43 | obj2nid :: Ptr ASN1_OBJECT -> IO CInt 44 | 45 | foreign import capi unsafe "openssl/objects.h OBJ_nid2sn" 46 | _nid2sn :: CInt -> IO CString 47 | 48 | foreign import capi unsafe "openssl/objects.h OBJ_nid2ln" 49 | _nid2ln :: CInt -> IO CString 50 | 51 | 52 | nid2sn :: CInt -> IO String 53 | nid2sn nid = _nid2sn nid >>= peekCString 54 | 55 | 56 | nid2ln :: CInt -> IO String 57 | nid2ln nid = _nid2ln nid >>= peekCString 58 | 59 | 60 | {- ASN1_STRING --------------------------------------------------------------- -} 61 | 62 | data {-# CTYPE "openssl/asn1.h" "ASN1_STRING" #-} ASN1_STRING 63 | 64 | peekASN1String :: Ptr ASN1_STRING -> IO String 65 | peekASN1String strPtr 66 | = do buf <- (#peek ASN1_STRING, data ) strPtr 67 | len <- (#peek ASN1_STRING, length) strPtr :: IO CInt 68 | peekCStringLen (buf, fromIntegral len) 69 | 70 | 71 | {- ASN1_INTEGER -------------------------------------------------------------- -} 72 | 73 | data {-# CTYPE "openssl/asn1.h" "ASN1_INTEGER" #-} ASN1_INTEGER 74 | 75 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_M_ASN1_INTEGER_new" 76 | _ASN1_INTEGER_new :: IO (Ptr ASN1_INTEGER) 77 | 78 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_M_ASN1_INTEGER_free" 79 | _ASN1_INTEGER_free :: Ptr ASN1_INTEGER -> IO () 80 | 81 | foreign import capi unsafe "openssl/asn1.h ASN1_INTEGER_to_BN" 82 | _ASN1_INTEGER_to_BN :: Ptr ASN1_INTEGER -> Ptr BIGNUM -> IO (Ptr BIGNUM) 83 | 84 | foreign import capi unsafe "openssl/asn1.h BN_to_ASN1_INTEGER" 85 | _BN_to_ASN1_INTEGER :: Ptr BIGNUM -> Ptr ASN1_INTEGER -> IO (Ptr ASN1_INTEGER) 86 | 87 | 88 | peekASN1Integer :: Ptr ASN1_INTEGER -> IO Integer 89 | peekASN1Integer intPtr 90 | = allocaBN $ \ bn -> 91 | do _ASN1_INTEGER_to_BN intPtr (unwrapBN bn) 92 | >>= failIfNull_ 93 | peekBN bn 94 | 95 | 96 | allocaASN1Integer :: (Ptr ASN1_INTEGER -> IO a) -> IO a 97 | allocaASN1Integer 98 | = bracket _ASN1_INTEGER_new _ASN1_INTEGER_free 99 | 100 | 101 | withASN1Integer :: Integer -> (Ptr ASN1_INTEGER -> IO a) -> IO a 102 | withASN1Integer int m 103 | = withBN int $ \ bn -> 104 | allocaASN1Integer $ \ intPtr -> 105 | do _BN_to_ASN1_INTEGER (unwrapBN bn) intPtr 106 | >>= failIfNull_ 107 | m intPtr 108 | 109 | 110 | {- ASN1_TIME ---------------------------------------------------------------- -} 111 | 112 | data {-# CTYPE "openssl/asn1.h" "ASN1_TIME" #-} ASN1_TIME 113 | 114 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_M_ASN1_TIME_new" 115 | _ASN1_TIME_new :: IO (Ptr ASN1_TIME) 116 | 117 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_M_ASN1_TIME_free" 118 | _ASN1_TIME_free :: Ptr ASN1_TIME -> IO () 119 | 120 | foreign import capi unsafe "openssl/asn1.h ASN1_TIME_set" 121 | _ASN1_TIME_set :: Ptr ASN1_TIME -> CTime -> IO (Ptr ASN1_TIME) 122 | 123 | foreign import capi unsafe "openssl/asn1.h ASN1_TIME_print" 124 | _ASN1_TIME_print :: Ptr BIO_ -> Ptr ASN1_TIME -> IO CInt 125 | 126 | 127 | peekASN1Time :: Ptr ASN1_TIME -> IO UTCTime -- asn1/t_x509.c 128 | peekASN1Time time 129 | = do bio <- newMem 130 | withBioPtr bio $ \ bioPtr -> 131 | _ASN1_TIME_print bioPtr time 132 | >>= failIf_ (/= 1) 133 | timeStr <- bioRead bio 134 | #if MIN_VERSION_time(1,5,0) 135 | case parseTimeM True defaultTimeLocale "%b %e %H:%M:%S %Y %Z" timeStr of 136 | #else 137 | case parseTime defaultTimeLocale "%b %e %H:%M:%S %Y %Z" timeStr of 138 | #endif 139 | Just utc -> return utc 140 | Nothing -> fail ("peekASN1Time: failed to parse time string: " ++ timeStr) 141 | 142 | allocaASN1Time :: (Ptr ASN1_TIME -> IO a) -> IO a 143 | allocaASN1Time 144 | = bracket _ASN1_TIME_new _ASN1_TIME_free 145 | 146 | 147 | withASN1Time :: UTCTime -> (Ptr ASN1_TIME -> IO a) -> IO a 148 | withASN1Time utc m 149 | = allocaASN1Time $ \ time -> 150 | do _ASN1_TIME_set time (fromIntegral (round $ utcTimeToPOSIXSeconds utc :: Integer)) 151 | >>= failIfNull_ 152 | m time 153 | -------------------------------------------------------------------------------- /OpenSSL/BN.hsc: -------------------------------------------------------------------------------- 1 | #include "HsOpenSSL.h" 2 | 3 | #if (OPENSSL_VERSION_NUMBER >= 0x10100000L && defined(FAST_BIGNUM)) 4 | -- BIGNUM is opaque type in OpenSSL 1.1.x 5 | #undef FAST_BIGNUM 6 | #endif 7 | 8 | #if defined(FAST_BIGNUM) 9 | {-# LANGUAGE BangPatterns #-} 10 | #endif 11 | {-# LANGUAGE EmptyDataDecls #-} 12 | {-# LANGUAGE ForeignFunctionInterface #-} 13 | {-# LANGUAGE CApiFFI #-} 14 | #if defined(FAST_BIGNUM) 15 | {-# LANGUAGE MagicHash #-} 16 | {-# LANGUAGE UnboxedTuples #-} 17 | {-# LANGUAGE UnliftedFFITypes #-} 18 | #endif 19 | {-# OPTIONS_HADDOCK prune #-} 20 | -- |BN - multiprecision integer arithmetics 21 | module OpenSSL.BN 22 | ( -- * Type 23 | BigNum 24 | , BIGNUM 25 | 26 | -- * Allocation 27 | , allocaBN 28 | , withBN 29 | 30 | , newBN 31 | , wrapBN -- private 32 | , unwrapBN -- private 33 | 34 | -- * Conversion from\/to Integer 35 | , peekBN 36 | , integerToBN 37 | , bnToInteger 38 | , integerToMPI 39 | , mpiToInteger 40 | 41 | -- * Computation 42 | , modexp 43 | 44 | -- * Random number generation 45 | , randIntegerUptoNMinusOneSuchThat 46 | , prandIntegerUptoNMinusOneSuchThat 47 | , randIntegerZeroToNMinusOne 48 | , prandIntegerZeroToNMinusOne 49 | , randIntegerOneToNMinusOne 50 | , prandIntegerOneToNMinusOne 51 | ) 52 | where 53 | 54 | import Control.Exception hiding (try) 55 | import qualified Data.ByteString as BS 56 | import Foreign.Marshal 57 | import Foreign.Ptr 58 | import Foreign.Storable 59 | import OpenSSL.Utils 60 | import System.IO.Unsafe 61 | 62 | #if defined(FAST_BIGNUM) 63 | import Foreign.C.Types 64 | import GHC.Base 65 | import GHC.Integer.GMP.Internals 66 | #else 67 | import Control.Monad 68 | import Foreign.C 69 | #endif 70 | 71 | -- |'BigNum' is an opaque object representing a big number. 72 | newtype BigNum = BigNum (Ptr BIGNUM) 73 | data {-# CTYPE "openssl/bn.h" "BIGNUM" #-} BIGNUM 74 | 75 | 76 | foreign import capi unsafe "openssl/bn.h BN_new" 77 | _new :: IO (Ptr BIGNUM) 78 | 79 | foreign import capi unsafe "openssl/bn.h BN_free" 80 | _free :: Ptr BIGNUM -> IO () 81 | 82 | -- |@'allocaBN' f@ allocates a 'BigNum' and computes @f@. Then it 83 | -- frees the 'BigNum'. 84 | allocaBN :: (BigNum -> IO a) -> IO a 85 | allocaBN m 86 | = bracket _new _free (m . wrapBN) 87 | 88 | 89 | unwrapBN :: BigNum -> Ptr BIGNUM 90 | unwrapBN (BigNum p) = p 91 | 92 | 93 | wrapBN :: Ptr BIGNUM -> BigNum 94 | wrapBN = BigNum 95 | 96 | 97 | #if !defined(FAST_BIGNUM) 98 | 99 | {- slow, safe functions ----------------------------------------------------- -} 100 | 101 | foreign import capi unsafe "openssl/bn.h BN_bn2dec" 102 | _bn2dec :: Ptr BIGNUM -> IO CString 103 | 104 | foreign import capi unsafe "openssl/bn.h BN_dec2bn" 105 | _dec2bn :: Ptr (Ptr BIGNUM) -> CString -> IO CInt 106 | 107 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_OPENSSL_free" 108 | _openssl_free :: Ptr a -> IO () 109 | 110 | -- |Convert a BIGNUM to an 'Integer'. 111 | bnToInteger :: BigNum -> IO Integer 112 | bnToInteger bn 113 | = bracket (do strPtr <- _bn2dec (unwrapBN bn) 114 | when (strPtr == nullPtr) $ fail "BN_bn2dec failed" 115 | return strPtr) 116 | _openssl_free 117 | ((read `fmap`) . peekCString) 118 | 119 | -- |Return a new, alloced BIGNUM. 120 | integerToBN :: Integer -> IO BigNum 121 | integerToBN i = do 122 | withCString (show i) (\str -> do 123 | alloca (\bnptr -> do 124 | poke bnptr nullPtr 125 | _ <- _dec2bn bnptr str >>= failIf (== 0) 126 | wrapBN `fmap` peek bnptr)) 127 | 128 | #else 129 | 130 | {- fast, dangerous functions ------------------------------------------------ -} 131 | 132 | -- Both BN (the OpenSSL library) and GMP (used by GHC) use the same internal 133 | -- representation for numbers: an array of words, least-significant first. Thus 134 | -- we can move from Integer's to BIGNUMs very quickly: by copying in the worst 135 | -- case and by just alloca'ing and pointing into the Integer in the fast case. 136 | -- Note that, in the fast case, it's very important that any foreign function 137 | -- calls be "unsafe", that is, they don't call back into Haskell. Otherwise the 138 | -- GC could do nasty things to the data which we thought that we had a pointer 139 | -- to 140 | 141 | foreign import capi unsafe "string.h memcpy" 142 | _copy_in :: ByteArray## -> Ptr () -> CSize -> IO (Ptr ()) 143 | 144 | foreign import capi unsafe "string.h memcpy" 145 | _copy_out :: Ptr () -> ByteArray## -> CSize -> IO (Ptr ()) 146 | 147 | -- These are taken from Data.Binary's disabled fast Integer support 148 | data ByteArray = BA !ByteArray## 149 | data MBA = MBA !(MutableByteArray## RealWorld) 150 | 151 | newByteArray :: Int## -> IO MBA 152 | newByteArray sz = IO $ \s -> 153 | case newByteArray## sz s of { (## s', arr ##) -> 154 | (## s', MBA arr ##) } 155 | 156 | freezeByteArray :: MutableByteArray## RealWorld -> IO ByteArray 157 | freezeByteArray arr = IO $ \s -> 158 | case unsafeFreezeByteArray## arr s of { (## s', arr' ##) -> 159 | (## s', BA arr' ##) } 160 | 161 | -- | Convert a BIGNUM to an Integer 162 | bnToInteger :: BigNum -> IO Integer 163 | bnToInteger bn = do 164 | nlimbs <- (#peek BIGNUM, top) (unwrapBN bn) :: IO CInt 165 | case nlimbs of 166 | 0 -> return 0 167 | 1 -> do (I## i) <- (#peek BIGNUM, d) (unwrapBN bn) >>= peek 168 | negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO CInt 169 | if negative == 0 170 | then return $ S## i 171 | else return $ S## (0## -## i) 172 | _ -> do 173 | let !(I## nlimbsi) = fromIntegral nlimbs 174 | !(I## limbsize) = (#size unsigned long) 175 | (MBA arr) <- newByteArray (nlimbsi *## limbsize) 176 | (BA ba) <- freezeByteArray arr 177 | limbs <- (#peek BIGNUM, d) (unwrapBN bn) 178 | _ <- _copy_in ba limbs $ fromIntegral $ nlimbs * (#size unsigned long) 179 | negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO CInt 180 | if negative == 0 181 | then return $ Jp## (byteArrayToBigNat## ba nlimbsi) 182 | else return $ Jn## (byteArrayToBigNat## ba nlimbsi) 183 | 184 | -- | This is a GHC specific, fast conversion between Integers and OpenSSL 185 | -- bignums. It returns a malloced BigNum. 186 | integerToBN :: Integer -> IO BigNum 187 | integerToBN (S## 0##) = do 188 | bnptr <- mallocBytes (#size BIGNUM) 189 | (#poke BIGNUM, d) bnptr nullPtr 190 | -- This is needed to give GHC enough type information 191 | let one :: CInt 192 | one = 1 193 | zero :: CInt 194 | zero = 0 195 | (#poke BIGNUM, flags) bnptr one 196 | (#poke BIGNUM, top) bnptr zero 197 | (#poke BIGNUM, dmax) bnptr zero 198 | (#poke BIGNUM, neg) bnptr zero 199 | return (wrapBN bnptr) 200 | 201 | integerToBN (S## v) = do 202 | bnptr <- mallocBytes (#size BIGNUM) 203 | limbs <- malloc :: IO (Ptr CULong) 204 | poke limbs $ fromIntegral $ abs $ I## v 205 | (#poke BIGNUM, d) bnptr limbs 206 | -- This is needed to give GHC enough type information since #poke just 207 | -- uses an offset 208 | let one :: CInt 209 | one = 1 210 | (#poke BIGNUM, flags) bnptr one 211 | (#poke BIGNUM, top) bnptr one 212 | (#poke BIGNUM, dmax) bnptr one 213 | (#poke BIGNUM, neg) bnptr (if (I## v) < 0 then one else 0) 214 | return (wrapBN bnptr) 215 | 216 | integerToBN v = 217 | case v of 218 | Jp## bn -> convert 0 bn 219 | Jn## bn -> convert 1 bn 220 | S## _ -> undefined 221 | where 222 | convert :: CInt -> BigNat -> IO BigNum 223 | convert negValue bn@(BN## bytearray) = do 224 | let nlimbs = I## (sizeofBigNat## bn) 225 | bnptr <- mallocBytes (#size BIGNUM) 226 | limbs <- mallocBytes ((#size unsigned long) * nlimbs) 227 | (#poke BIGNUM, d) bnptr limbs 228 | (#poke BIGNUM, flags) bnptr (1 :: CInt) 229 | _ <- _copy_out limbs bytearray (fromIntegral $ (#size unsigned long) * nlimbs) 230 | (#poke BIGNUM, top) bnptr ((fromIntegral nlimbs) :: CInt) 231 | (#poke BIGNUM, dmax) bnptr ((fromIntegral nlimbs) :: CInt) 232 | (#poke BIGNUM, neg) bnptr negValue 233 | return (wrapBN bnptr) 234 | #endif 235 | 236 | -- TODO: we could make a function which doesn't even allocate BN data if we 237 | -- wanted to be very fast and dangerout. The BIGNUM could point right into the 238 | -- Integer's data. However, I'm not sure about the semantics of the GC; which 239 | -- might move the Integer data around. 240 | 241 | -- |@'withBN' n f@ converts n to a 'BigNum' and computes @f@. Then it 242 | -- frees the 'BigNum'. 243 | withBN :: Integer -> (BigNum -> IO a) -> IO a 244 | withBN dec m = bracket (integerToBN dec) (_free . unwrapBN) m 245 | 246 | foreign import capi unsafe "openssl/bn.h BN_bn2mpi" 247 | _bn2mpi :: Ptr BIGNUM -> Ptr CUChar -> IO CInt 248 | 249 | foreign import capi unsafe "openssl/bn.h BN_mpi2bn" 250 | _mpi2bn :: Ptr CUChar -> CInt -> Ptr BIGNUM -> IO (Ptr BIGNUM) 251 | 252 | -- |This is an alias to 'bnToInteger'. 253 | peekBN :: BigNum -> IO Integer 254 | peekBN = bnToInteger 255 | 256 | -- |This is an alias to 'integerToBN'. 257 | newBN :: Integer -> IO BigNum 258 | newBN = integerToBN 259 | 260 | -- | Convert a BigNum to an MPI: a serialisation of large ints which has a 261 | -- 4-byte, big endian length followed by the bytes of the number in 262 | -- most-significant-first order. 263 | bnToMPI :: BigNum -> IO BS.ByteString 264 | bnToMPI bn = do 265 | bytes <- _bn2mpi (unwrapBN bn) nullPtr 266 | allocaBytes (fromIntegral bytes) (\buffer -> do 267 | _ <- _bn2mpi (unwrapBN bn) buffer 268 | BS.packCStringLen (castPtr buffer, fromIntegral bytes)) 269 | 270 | -- | Convert an MPI into a BigNum. See bnToMPI for details of the format 271 | mpiToBN :: BS.ByteString -> IO BigNum 272 | mpiToBN mpi = do 273 | BS.useAsCStringLen mpi (\(ptr, len) -> do 274 | _mpi2bn (castPtr ptr) (fromIntegral len) nullPtr) >>= return . wrapBN 275 | 276 | -- | Convert an Integer to an MPI. See bnToMPI for the format 277 | integerToMPI :: Integer -> IO BS.ByteString 278 | integerToMPI v = bracket (integerToBN v) (_free . unwrapBN) bnToMPI 279 | 280 | -- | Convert an MPI to an Integer. See bnToMPI for the format 281 | mpiToInteger :: BS.ByteString -> IO Integer 282 | mpiToInteger mpi = do 283 | bn <- mpiToBN mpi 284 | v <- bnToInteger bn 285 | _free (unwrapBN bn) 286 | return v 287 | 288 | foreign import capi unsafe "openssl/bn.h BN_mod_exp" 289 | _mod_exp :: Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> BNCtx -> IO CInt 290 | 291 | type BNCtx = Ptr BNCTX 292 | data {-# CTYPE "openssl/bn.h" "BN_CTX" #-} BNCTX 293 | 294 | foreign import capi unsafe "openssl/bn.h BN_CTX_new" 295 | _BN_ctx_new :: IO BNCtx 296 | 297 | foreign import capi unsafe "openssl/bn.h BN_CTX_free" 298 | _BN_ctx_free :: BNCtx -> IO () 299 | 300 | withBNCtx :: (BNCtx -> IO a) -> IO a 301 | withBNCtx f = bracket _BN_ctx_new _BN_ctx_free f 302 | 303 | -- |@'modexp' a p m@ computes @a@ to the @p@-th power modulo @m@. 304 | modexp :: Integer -> Integer -> Integer -> Integer 305 | modexp a p m = unsafePerformIO (do 306 | withBN a (\bnA -> (do 307 | withBN p (\bnP -> (do 308 | withBN m (\bnM -> (do 309 | withBNCtx (\ctx -> (do 310 | r <- newBN 0 311 | _ <- _mod_exp (unwrapBN r) (unwrapBN bnA) (unwrapBN bnP) (unwrapBN bnM) ctx 312 | bnToInteger r >>= return))))))))) 313 | 314 | {- Random Integer generation ------------------------------------------------ -} 315 | 316 | foreign import capi unsafe "openssl/bn.h BN_rand_range" 317 | _BN_rand_range :: Ptr BIGNUM -> Ptr BIGNUM -> IO CInt 318 | 319 | foreign import capi unsafe "openssl/bn.h BN_pseudo_rand_range" 320 | _BN_pseudo_rand_range :: Ptr BIGNUM -> Ptr BIGNUM -> IO CInt 321 | 322 | -- | Return a strongly random number in the range 0 <= x < n where the given 323 | -- filter function returns true. 324 | randIntegerUptoNMinusOneSuchThat :: (Integer -> Bool) -- ^ a filter function 325 | -> Integer -- ^ one plus the upper limit 326 | -> IO Integer 327 | randIntegerUptoNMinusOneSuchThat f range = withBN range (\bnRange -> (do 328 | r <- newBN 0 329 | let try = do 330 | _BN_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf_ (/= 1) 331 | i <- bnToInteger r 332 | if f i 333 | then return i 334 | else try 335 | try)) 336 | 337 | -- | Return a random number in the range 0 <= x < n where the given 338 | -- filter function returns true. 339 | prandIntegerUptoNMinusOneSuchThat :: (Integer -> Bool) -- ^ a filter function 340 | -> Integer -- ^ one plus the upper limit 341 | -> IO Integer 342 | prandIntegerUptoNMinusOneSuchThat f range = withBN range (\bnRange -> (do 343 | r <- newBN 0 344 | let try = do 345 | _BN_pseudo_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf_ (/= 1) 346 | i <- bnToInteger r 347 | if f i 348 | then return i 349 | else try 350 | try)) 351 | 352 | -- | Return a strongly random number in the range 0 <= x < n 353 | randIntegerZeroToNMinusOne :: Integer -> IO Integer 354 | randIntegerZeroToNMinusOne = randIntegerUptoNMinusOneSuchThat (const True) 355 | -- | Return a strongly random number in the range 0 < x < n 356 | randIntegerOneToNMinusOne :: Integer -> IO Integer 357 | randIntegerOneToNMinusOne = randIntegerUptoNMinusOneSuchThat (/= 0) 358 | 359 | -- | Return a random number in the range 0 <= x < n 360 | prandIntegerZeroToNMinusOne :: Integer -> IO Integer 361 | prandIntegerZeroToNMinusOne = prandIntegerUptoNMinusOneSuchThat (const True) 362 | -- | Return a random number in the range 0 < x < n 363 | prandIntegerOneToNMinusOne :: Integer -> IO Integer 364 | prandIntegerOneToNMinusOne = prandIntegerUptoNMinusOneSuchThat (/= 0) 365 | -------------------------------------------------------------------------------- /OpenSSL/Cipher.hsc: -------------------------------------------------------------------------------- 1 | #include "HsOpenSSL.h" 2 | #include "openssl/aes.h" 3 | 4 | {-# LANGUAGE EmptyDataDecls #-} 5 | {-# LANGUAGE ForeignFunctionInterface #-} 6 | {-# LANGUAGE CApiFFI #-} 7 | -- | This module interfaces to some of the OpenSSL ciphers without using 8 | -- EVP (see OpenSSL.EVP.Cipher). The EVP ciphers are easier to use, 9 | -- however, in some cases you cannot do without using the OpenSSL 10 | -- fuctions directly. 11 | -- 12 | -- One of these cases (and the motivating example 13 | -- for this module) is that the EVP CBC functions try to encode the 14 | -- length of the input string in the output (thus hiding the fact that the 15 | -- cipher is, in fact, block based and needs padding). This means that the 16 | -- EVP CBC functions cannot, in some cases, interface with other users 17 | -- which don't use that system (like SSH). 18 | module OpenSSL.Cipher 19 | ( Mode(..) 20 | , AESCtx 21 | , newAESCtx 22 | , aesCBC 23 | #if OPENSSL_VERSION_NUMBER < 0x10100000L 24 | , aesCTR 25 | #endif 26 | ) 27 | where 28 | 29 | import Control.Monad (when, unless) 30 | import Data.IORef 31 | import Foreign 32 | import Foreign.C.Types 33 | import qualified Data.ByteString as BS 34 | import qualified Data.ByteString.Internal as BSI 35 | import OpenSSL.Utils 36 | 37 | data Mode = Encrypt | Decrypt deriving (Eq, Show) 38 | 39 | modeToInt :: Num a => Mode -> a 40 | modeToInt Encrypt = 1 41 | modeToInt Decrypt = 0 42 | 43 | data {-# CTYPE "openssl/aes.h" "AES_KEY" #-} AES_KEY 44 | data AESCtx = AESCtx 45 | (ForeignPtr AES_KEY) -- the key schedule 46 | (ForeignPtr CUChar) -- the IV / counter 47 | (ForeignPtr CUChar) -- the encrypted counter (CTR mode) 48 | (IORef CUInt) -- the number of bytes of the encrypted counter used 49 | Mode 50 | 51 | foreign import capi unsafe "string.h memcpy" 52 | _memcpy :: Ptr CUChar -> Ptr CChar -> CSize -> IO (Ptr ()) 53 | 54 | foreign import capi unsafe "string.h memset" 55 | _memset :: Ptr CUChar -> CChar -> CSize -> IO () 56 | 57 | foreign import capi unsafe "openssl/aes.h AES_set_encrypt_key" 58 | _AES_set_encrypt_key :: Ptr CChar -> CInt -> Ptr AES_KEY -> IO CInt 59 | foreign import capi unsafe "openssl/aes.h AES_set_decrypt_key" 60 | _AES_set_decrypt_key :: Ptr CChar -> CInt -> Ptr AES_KEY -> IO CInt 61 | 62 | foreign import capi unsafe "openssl/aes.h AES_cbc_encrypt" 63 | _AES_cbc_encrypt :: Ptr CChar -> Ptr Word8 -> CULong -> Ptr AES_KEY -> Ptr CUChar -> CInt -> IO () 64 | 65 | foreign import capi unsafe "stdlib.h &free" 66 | _free :: FunPtr (Ptr a -> IO ()) 67 | 68 | -- | Construct a new context which holds the key schedule and IV. 69 | newAESCtx :: Mode -- ^ For CTR mode, this must always be Encrypt 70 | -> BS.ByteString -- ^ Key: 128, 192 or 256 bits long 71 | -> BS.ByteString -- ^ IV: 16 bytes long 72 | -> IO AESCtx 73 | newAESCtx mode key iv = do 74 | let keyLen = BS.length key * 8 75 | unless (any (keyLen ==) [128, 192, 256]) $ fail "Bad AES key length" 76 | when (BS.length iv /= 16) $ fail "Bad AES128 iv length" 77 | ctx <- mallocForeignPtrBytes (#size AES_KEY) 78 | withForeignPtr ctx $ \ctxPtr -> 79 | BS.useAsCStringLen key (\(ptr, _) -> 80 | case mode of 81 | Encrypt -> _AES_set_encrypt_key ptr (fromIntegral keyLen) ctxPtr >>= failIf_ (/= 0) 82 | Decrypt -> _AES_set_decrypt_key ptr (fromIntegral keyLen) ctxPtr >>= failIf_ (/= 0)) 83 | ivbytes <- mallocForeignPtrBytes 16 84 | ecounter <- mallocForeignPtrBytes 16 85 | nref <- newIORef 0 86 | withForeignPtr ecounter (\ecptr -> _memset ecptr 0 16) 87 | withForeignPtr ivbytes $ \ivPtr -> 88 | BS.useAsCStringLen iv $ \(ptr, _) -> 89 | do _ <- _memcpy ivPtr ptr 16 90 | return $ AESCtx ctx ivbytes ecounter nref mode 91 | 92 | -- | Encrypt some number of blocks using CBC. This is an IO function because 93 | -- the context is destructivly updated. 94 | aesCBC :: AESCtx -- ^ context 95 | -> BS.ByteString -- ^ input, must be multiple of block size (16 bytes) 96 | -> IO BS.ByteString 97 | aesCBC (AESCtx ctx iv _ _ mode) input = do 98 | when (BS.length input `mod` 16 /= 0) $ fail "Bad input length to aesCBC" 99 | withForeignPtr ctx $ \ctxPtr -> 100 | withForeignPtr iv $ \ivPtr -> 101 | BS.useAsCStringLen input $ \(ptr, len) -> 102 | BSI.create (BS.length input) $ \out -> 103 | _AES_cbc_encrypt ptr out (fromIntegral len) ctxPtr ivPtr $ modeToInt mode 104 | 105 | #if OPENSSL_VERSION_NUMBER < 0x10100000L 106 | -- seems that AES_ctr128_encrypt was removed in recent OpenSSL versions 107 | foreign import capi unsafe "openssl/aes.h AES_ctr128_encrypt" 108 | _AES_ctr_encrypt :: Ptr CChar -> Ptr Word8 -> CULong -> Ptr AES_KEY -> Ptr CUChar -> Ptr CUChar -> Ptr CUInt -> IO () 109 | 110 | -- | Encrypt some number of bytes using CTR mode. This is an IO function 111 | -- because the context is destructivly updated. 112 | aesCTR :: AESCtx -- ^ context 113 | -> BS.ByteString -- ^ input, any number of bytes 114 | -> IO BS.ByteString 115 | aesCTR (AESCtx _ _ _ _ Decrypt) _ = fail "the context mode must be Encrypt" 116 | aesCTR (AESCtx ctx iv ecounter nref Encrypt) input = 117 | withForeignPtr ctx $ \ctxPtr -> 118 | withForeignPtr iv $ \ivPtr -> 119 | withForeignPtr ecounter $ \ecptr -> 120 | BS.useAsCStringLen input $ \(ptr, len) -> 121 | BSI.create (BS.length input) $ \out -> 122 | alloca $ \nptr -> do 123 | n <- readIORef nref 124 | poke nptr n 125 | _AES_ctr_encrypt ptr out (fromIntegral len) ctxPtr ivPtr ecptr nptr 126 | n' <- peek nptr 127 | writeIORef nref n' 128 | #endif 129 | -------------------------------------------------------------------------------- /OpenSSL/DER.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE CApiFFI #-} 3 | -- |Encoding and decoding of RSA keys using the ASN.1 DER format 4 | module OpenSSL.DER 5 | ( toDERPub 6 | , fromDERPub 7 | , toDERPriv 8 | , fromDERPriv 9 | ) 10 | where 11 | 12 | #if !MIN_VERSION_base(4,8,0) 13 | import Control.Applicative ((<$>)) 14 | #endif 15 | import OpenSSL.RSA (RSA, RSAKey, RSAKeyPair, RSAPubKey, 16 | absorbRSAPtr, withRSAPtr) 17 | 18 | import Data.ByteString (ByteString) 19 | import qualified Data.ByteString as B (useAsCStringLen) 20 | import qualified Data.ByteString.Internal as BI (createAndTrim) 21 | import Foreign.Ptr (Ptr, nullPtr, castPtr) 22 | import Foreign.C.Types (CLong(..), CInt(..)) 23 | import Foreign.Marshal.Alloc (alloca) 24 | import Foreign.Storable (poke) 25 | import GHC.Word (Word8) 26 | import System.IO.Unsafe (unsafePerformIO) 27 | 28 | type CDecodeFun = Ptr (Ptr RSA) -> Ptr (Ptr Word8) -> CLong -> IO (Ptr RSA) 29 | type CEncodeFun = Ptr RSA -> Ptr (Ptr Word8) -> IO CInt 30 | 31 | foreign import capi unsafe "HsOpenSSL.h d2i_RSAPublicKey" 32 | _fromDERPub :: CDecodeFun 33 | 34 | foreign import capi unsafe "HsOpenSSL.h i2d_RSAPublicKey" 35 | _toDERPub :: CEncodeFun 36 | 37 | foreign import capi unsafe "HsOpenSSL.h d2i_RSAPrivateKey" 38 | _fromDERPriv :: CDecodeFun 39 | 40 | foreign import capi unsafe "HsOpenSSL.h i2d_RSAPrivateKey" 41 | _toDERPriv :: CEncodeFun 42 | 43 | -- | Generate a function that decodes a key from ASN.1 DER format 44 | makeDecodeFun :: RSAKey k => CDecodeFun -> ByteString -> Maybe k 45 | makeDecodeFun fun bs = unsafePerformIO . usingConvedBS $ \(csPtr, ci) -> do 46 | -- When you pass a null pointer to this function, it will allocate the memory 47 | -- space required for the RSA key all by itself. It will be freed whenever 48 | -- the haskell object is garbage collected, as they are stored in ForeignPtrs 49 | -- internally. 50 | rsaPtr <- fun nullPtr (castPtr csPtr) ci 51 | -- CString is represented as a void* in C and the C compiler whines about 52 | -- a bad pointer conversion in d2i_* functions. So we declare 53 | -- the CDecodeFun to accept Ptr Word8 and perform the castPtr here. 54 | if rsaPtr == nullPtr then return Nothing else absorbRSAPtr rsaPtr 55 | where usingConvedBS io = B.useAsCStringLen bs $ \(cs, len) -> 56 | alloca $ \csPtr -> poke csPtr cs >> io (csPtr, fromIntegral len) 57 | 58 | -- | Generate a function that encodes a key in ASN.1 DER format 59 | makeEncodeFun :: RSAKey k => CEncodeFun -> k -> ByteString 60 | makeEncodeFun fun k = unsafePerformIO $ do 61 | -- When you pass a null pointer to this function, it will only compute the 62 | -- required buffer size. See https://www.openssl.org/docs/faq.html#PROG3 63 | requiredSize <- withRSAPtr k $ flip fun nullPtr 64 | -- It’s too sad BI.createAndTrim is considered internal, as it does a great 65 | -- job here. See https://hackage.haskell.org/package/bytestring-0.9.1.4/docs/Data-ByteString-Internal.html#v%3AcreateAndTrim 66 | BI.createAndTrim (fromIntegral requiredSize) $ \ptr -> 67 | alloca $ \pptr -> 68 | (fromIntegral <$>) . withRSAPtr k $ \key -> 69 | poke pptr ptr >> fun key pptr 70 | 71 | -- | Dump a public key to ASN.1 DER format 72 | toDERPub :: RSAKey k 73 | => k -- ^ You can pass either 'RSAPubKey' or 'RSAKeyPair' 74 | -- because both contain the necessary information. 75 | -> ByteString -- ^ The public key information encoded in ASN.1 DER 76 | toDERPub = makeEncodeFun _toDERPub 77 | 78 | -- | Parse a public key from ASN.1 DER format 79 | fromDERPub :: ByteString -> Maybe RSAPubKey 80 | fromDERPub = makeDecodeFun _fromDERPub 81 | 82 | -- | Dump a private key to ASN.1 DER format 83 | toDERPriv :: RSAKeyPair -> ByteString 84 | toDERPriv = makeEncodeFun _toDERPriv 85 | 86 | -- | Parse a private key from ASN.1 DER format 87 | fromDERPriv :: RSAKey k 88 | => ByteString -- ^ The private key information encoded in ASN.1 DER 89 | -> Maybe k -- ^ This can return either 'RSAPubKey' or 90 | -- 'RSAKeyPair' because there’s sufficient 91 | -- information for both. 92 | fromDERPriv = makeDecodeFun _fromDERPriv 93 | -------------------------------------------------------------------------------- /OpenSSL/DH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | -- | Diffie-Hellman key exchange 5 | module OpenSSL.DH 6 | ( DHP 7 | , DH 8 | , DHGen(..) 9 | , genDHParams 10 | , getDHLength 11 | , checkDHParams 12 | , genDH 13 | , getDHParams 14 | , getDHPublicKey 15 | , computeDHKey 16 | ) 17 | where 18 | import Data.Word (Word8) 19 | import Data.ByteString (ByteString) 20 | import qualified Data.ByteString.Internal as BS 21 | #if !MIN_VERSION_base(4,8,0) 22 | import Control.Applicative ((<$>)) 23 | #endif 24 | import Foreign.Ptr (Ptr, nullPtr) 25 | #if MIN_VERSION_base(4,5,0) 26 | import Foreign.C.Types (CInt(..)) 27 | #else 28 | import Foreign.C.Types (CInt) 29 | #endif 30 | import Foreign.Marshal.Alloc (alloca) 31 | import OpenSSL.BN 32 | import OpenSSL.DH.Internal 33 | import OpenSSL.Utils 34 | 35 | data DHGen = DHGen2 36 | | DHGen5 37 | deriving (Eq, Ord, Show) 38 | 39 | -- | @'genDHParams' gen n@ generates @n@-bit long DH parameters. 40 | genDHParams :: DHGen -> Int -> IO DHP 41 | genDHParams gen len = do 42 | _DH_generate_parameters (fromIntegral len) gen' nullPtr nullPtr 43 | >>= failIfNull 44 | >>= wrapDHPPtr 45 | where gen' = case gen of 46 | DHGen2 -> 2 47 | DHGen5 -> 5 48 | 49 | -- | Get DH parameters length (in bits). 50 | getDHLength :: DHP -> IO Int 51 | getDHLength dh = fromIntegral <$> withDHPPtr dh _DH_length 52 | 53 | -- | Check that DH parameters are coherent. 54 | checkDHParams :: DHP -> IO Bool 55 | checkDHParams dh = alloca $ \pErr -> 56 | withDHPPtr dh $ \dhPtr -> _DH_check dhPtr pErr 57 | 58 | -- | The first step of a key exchange. Public and private keys are generated. 59 | genDH :: DHP -> IO DH 60 | genDH dh = do 61 | dh' <- withDHPPtr dh _DH_dup >>= failIfNull >>= wrapDHPPtr 62 | withDHPPtr dh' _DH_generate_key >>= failIf_ (/= 1) 63 | return $ asDH dh' 64 | 65 | -- | Get parameters of a key exchange. 66 | getDHParams :: DH -> DHP 67 | getDHParams = asDHP 68 | 69 | -- | Get the public key. 70 | getDHPublicKey :: DH -> IO Integer 71 | getDHPublicKey dh = 72 | withDHPtr dh $ \dhPtr -> do 73 | pKey <- _DH_get_pub_key dhPtr 74 | bnToInteger (wrapBN pKey) 75 | 76 | -- | Compute the shared key using the other party's public key. 77 | computeDHKey :: DH -> Integer -> IO ByteString 78 | computeDHKey dh pubKey = 79 | withDHPtr dh $ \dhPtr -> 80 | withBN pubKey $ \bn -> do 81 | size <- fromIntegral <$> _DH_size dhPtr 82 | BS.createAndTrim size $ \bsPtr -> 83 | fromIntegral <$> _DH_compute_key bsPtr (unwrapBN bn) dhPtr 84 | >>= failIf (< 0) 85 | 86 | foreign import capi "openssl/dh.h DH_generate_parameters" 87 | _DH_generate_parameters :: CInt -> CInt -> Ptr () -> Ptr () -> IO (Ptr DH_) 88 | foreign import capi "openssl/dh.h DH_generate_key" 89 | _DH_generate_key :: Ptr DH_ -> IO CInt 90 | foreign import capi "openssl/dh.h DH_compute_key" 91 | _DH_compute_key :: Ptr Word8 -> Ptr BIGNUM -> Ptr DH_ -> IO CInt 92 | foreign import capi "openssl/dh.h DH_check" 93 | _DH_check :: Ptr DH_ -> Ptr CInt -> IO Bool 94 | foreign import capi unsafe "openssl/dh.h DH_size" 95 | _DH_size :: Ptr DH_ -> IO CInt 96 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_DHparams_dup" 97 | _DH_dup :: Ptr DH_ -> IO (Ptr DH_) 98 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_DH_get_pub_key" 99 | _DH_get_pub_key :: Ptr DH_ -> IO (Ptr BIGNUM) 100 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_DH_length" 101 | _DH_length :: Ptr DH_ -> IO CInt 102 | -------------------------------------------------------------------------------- /OpenSSL/DH/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE ForeignFunctionInterface #-} 4 | {-# LANGUAGE CApiFFI #-} 5 | module OpenSSL.DH.Internal ( 6 | DH_, 7 | DHP, 8 | withDHPPtr, 9 | wrapDHPPtrWith, 10 | wrapDHPPtr, 11 | DH, 12 | withDHPtr, 13 | wrapDHPtrWith, 14 | wrapDHPtr, 15 | asDH, 16 | asDHP 17 | ) where 18 | 19 | import Foreign.Ptr (Ptr) 20 | import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) 21 | import qualified Foreign.Concurrent as FC 22 | 23 | #if !MIN_VERSION_base(4,8,0) 24 | import Control.Applicative ((<$>)) 25 | #endif 26 | 27 | data {-# CTYPE "openssl/dh.h" "DH" #-} DH_ 28 | newtype DHP = DHP (ForeignPtr DH_) 29 | 30 | withDHPPtr :: DHP -> (Ptr DH_ -> IO a) -> IO a 31 | withDHPPtr (DHP fp) = withForeignPtr fp 32 | 33 | wrapDHPPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DHP 34 | wrapDHPPtrWith fin p = DHP <$> FC.newForeignPtr p (fin p) 35 | 36 | wrapDHPPtr :: Ptr DH_ -> IO DHP 37 | wrapDHPPtr = wrapDHPPtrWith _DH_free 38 | 39 | newtype DH = DH (ForeignPtr DH_) 40 | 41 | withDHPtr :: DH -> (Ptr DH_ -> IO a) -> IO a 42 | withDHPtr (DH fp) = withForeignPtr fp 43 | 44 | wrapDHPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DH 45 | wrapDHPtrWith fin p = DH <$> FC.newForeignPtr p (fin p) 46 | 47 | wrapDHPtr :: Ptr DH_ -> IO DH 48 | wrapDHPtr = wrapDHPtrWith _DH_free 49 | 50 | asDH :: DHP -> DH 51 | asDH (DHP fp) = DH fp 52 | 53 | asDHP :: DH -> DHP 54 | asDHP (DH fp) = DHP fp 55 | 56 | foreign import capi "openssl/dh.h DH_free" 57 | _DH_free :: Ptr DH_ -> IO () 58 | -------------------------------------------------------------------------------- /OpenSSL/ERR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE CApiFFI #-} 3 | module OpenSSL.ERR 4 | ( getError 5 | , peekError 6 | 7 | , errorString 8 | ) 9 | where 10 | import Foreign 11 | import Foreign.C 12 | 13 | foreign import capi unsafe "openssl/err.h ERR_get_error" 14 | getError :: IO CULong 15 | 16 | foreign import capi unsafe "openssl/err.h ERR_peek_error" 17 | peekError :: IO CULong 18 | 19 | foreign import capi unsafe "openssl/err.h ERR_error_string" 20 | _error_string :: CULong -> CString -> IO CString 21 | 22 | errorString :: CULong -> IO String 23 | errorString code 24 | = _error_string code nullPtr >>= peekCString 25 | -------------------------------------------------------------------------------- /OpenSSL/EVP/Base64.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | -- |An interface to Base64 codec. 5 | module OpenSSL.EVP.Base64 6 | ( -- * Encoding 7 | encodeBase64 8 | , encodeBase64BS 9 | , encodeBase64LBS 10 | 11 | -- * Decoding 12 | , decodeBase64 13 | , decodeBase64BS 14 | , decodeBase64LBS 15 | ) 16 | where 17 | import Control.Exception (assert) 18 | import Data.ByteString.Internal (createAndTrim) 19 | import Data.ByteString.Unsafe (unsafeUseAsCStringLen) 20 | import qualified Data.ByteString.Lazy.Internal as L8Internal 21 | import qualified Data.ByteString.Char8 as B8 22 | import qualified Data.ByteString.Lazy.Char8 as L8 23 | import Data.List 24 | #if MIN_VERSION_base(4,5,0) 25 | import Foreign.C.Types (CUChar(..), CInt(..)) 26 | #else 27 | import Foreign.C.Types (CUChar, CInt) 28 | #endif 29 | import Foreign.Ptr (Ptr, castPtr) 30 | import System.IO.Unsafe (unsafePerformIO) 31 | 32 | 33 | -- On encoding, we keep fetching the next block until we get at least 34 | -- 3 bytes. Then we apply B8.concat to the returned [ByteString] and 35 | -- split it at the offset in multiple of 3, then prepend the remaining 36 | -- bytes to the next block. 37 | -- 38 | -- On decoding, we apply the same algorithm but we split the input in 39 | -- multiple of 4. 40 | nextBlock :: Int -> ([B8.ByteString], L8.ByteString) -> ([B8.ByteString], L8.ByteString) 41 | nextBlock minLen (xs, src) 42 | = if foldl' (+) 0 (map B8.length xs) >= minLen then 43 | (xs, src) 44 | else 45 | case src of 46 | L8Internal.Empty -> (xs, src) 47 | L8Internal.Chunk y ys -> nextBlock minLen (xs ++ [y], ys) 48 | 49 | 50 | {- encode -------------------------------------------------------------------- -} 51 | 52 | foreign import capi unsafe "openssl/evp.h EVP_EncodeBlock" 53 | _EncodeBlock :: Ptr CUChar -> Ptr CUChar -> CInt -> IO CInt 54 | 55 | 56 | encodeBlock :: B8.ByteString -> B8.ByteString 57 | encodeBlock inBS 58 | = unsafePerformIO $ 59 | unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> 60 | createAndTrim maxOutLen $ \ outBuf -> 61 | fmap fromIntegral 62 | (_EncodeBlock (castPtr outBuf) (castPtr inBuf) (fromIntegral inLen)) 63 | where 64 | maxOutLen = (inputLen `div` 3 + 1) * 4 + 1 -- +1: '\0' 65 | inputLen = B8.length inBS 66 | 67 | 68 | -- |@'encodeBase64' str@ lazilly encodes a stream of data to 69 | -- Base64. The string doesn't have to be finite. Note that the string 70 | -- must not contain any letters which aren't in the range of U+0000 - 71 | -- U+00FF. 72 | {-# DEPRECATED encodeBase64 "Use encodeBase64BS or encodeBase64LBS instead." #-} 73 | encodeBase64 :: String -> String 74 | encodeBase64 = L8.unpack . encodeBase64LBS . L8.pack 75 | 76 | -- |@'encodeBase64BS' bs@ strictly encodes a chunk of data to Base64. 77 | encodeBase64BS :: B8.ByteString -> B8.ByteString 78 | encodeBase64BS = encodeBlock 79 | 80 | -- |@'encodeBase64LBS' lbs@ lazilly encodes a stream of data to 81 | -- Base64. The string doesn't have to be finite. 82 | encodeBase64LBS :: L8.ByteString -> L8.ByteString 83 | encodeBase64LBS inLBS 84 | | L8.null inLBS = L8.empty 85 | | otherwise 86 | = let (blockParts', remain' ) = nextBlock 3 ([], inLBS) 87 | block' = B8.concat blockParts' 88 | blockLen' = B8.length block' 89 | (block , leftover) = if blockLen' < 3 then 90 | -- The last remnant. 91 | (block', B8.empty) 92 | else 93 | B8.splitAt (blockLen' - blockLen' `mod` 3) block' 94 | remain = if B8.null leftover then 95 | remain' 96 | else 97 | L8.fromChunks [leftover] `L8.append` remain' 98 | encodedBlock = encodeBlock block 99 | encodedRemain = encodeBase64LBS remain 100 | in 101 | L8.fromChunks [encodedBlock] `L8.append` encodedRemain 102 | 103 | 104 | {- decode -------------------------------------------------------------------- -} 105 | 106 | foreign import capi unsafe "openssl/evp.h EVP_DecodeBlock" 107 | _DecodeBlock :: Ptr CUChar -> Ptr CUChar -> CInt -> IO CInt 108 | 109 | 110 | decodeBlock :: B8.ByteString -> B8.ByteString 111 | decodeBlock inBS 112 | = assert (B8.length inBS `mod` 4 == 0) $ 113 | unsafePerformIO $ 114 | unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> 115 | createAndTrim (B8.length inBS) $ \ outBuf -> 116 | _DecodeBlock (castPtr outBuf) (castPtr inBuf) (fromIntegral inLen) 117 | >>= \ outLen -> return (fromIntegral outLen - paddingLen) 118 | where 119 | paddingLen :: Int 120 | paddingLen = B8.count '=' inBS 121 | 122 | -- |@'decodeBase64' str@ lazilly decodes a stream of data from 123 | -- Base64. The string doesn't have to be finite. 124 | {-# DEPRECATED decodeBase64 "Use decodeBase64BS or decodeBase64LBS instead." #-} 125 | decodeBase64 :: String -> String 126 | decodeBase64 = L8.unpack . decodeBase64LBS . L8.pack 127 | 128 | -- |@'decodeBase64BS' bs@ strictly decodes a chunk of data from 129 | -- Base64. 130 | decodeBase64BS :: B8.ByteString -> B8.ByteString 131 | decodeBase64BS = decodeBlock 132 | 133 | -- |@'decodeBase64LBS' lbs@ lazilly decodes a stream of data from 134 | -- Base64. The string doesn't have to be finite. 135 | decodeBase64LBS :: L8.ByteString -> L8.ByteString 136 | decodeBase64LBS inLBS 137 | | L8.null inLBS = L8.empty 138 | | otherwise 139 | = let (blockParts', remain' ) = nextBlock 4 ([], inLBS) 140 | block' = B8.concat blockParts' 141 | blockLen' = B8.length block' 142 | (block , leftover) = assert (blockLen' >= 4) $ 143 | B8.splitAt (blockLen' - blockLen' `mod` 4) block' 144 | remain = if B8.null leftover then 145 | remain' 146 | else 147 | L8.fromChunks [leftover] `L8.append` remain' 148 | decodedBlock = decodeBlock block 149 | decodedRemain = decodeBase64LBS remain 150 | in 151 | L8.fromChunks [decodedBlock] `L8.append` decodedRemain 152 | -------------------------------------------------------------------------------- /OpenSSL/EVP/Cipher.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | -- |An interface to symmetric cipher algorithms. 5 | module OpenSSL.EVP.Cipher 6 | ( Cipher 7 | , getCipherByName 8 | , getCipherNames 9 | 10 | , CryptoMode(..) 11 | 12 | , cipher 13 | , cipherBS 14 | , cipherLBS 15 | , cipherStrictLBS 16 | ) 17 | where 18 | import qualified Data.ByteString.Char8 as B8 19 | import qualified Data.ByteString.Lazy.Char8 as L8 20 | import Foreign 21 | import Foreign.C 22 | import OpenSSL.Objects 23 | import OpenSSL.EVP.Internal 24 | 25 | #if !MIN_VERSION_base(4,8,0) 26 | import Data.Monoid 27 | #endif 28 | 29 | foreign import capi unsafe "openssl/evp.h EVP_get_cipherbyname" 30 | _get_cipherbyname :: CString -> IO (Ptr EVP_CIPHER) 31 | 32 | -- |@'getCipherByName' name@ returns a symmetric cipher algorithm 33 | -- whose name is @name@. If no algorithms are found, the result is 34 | -- @Nothing@. 35 | getCipherByName :: String -> IO (Maybe Cipher) 36 | getCipherByName name 37 | = withCString name $ \ namePtr -> 38 | do ptr <- _get_cipherbyname namePtr 39 | if ptr == nullPtr then 40 | return Nothing 41 | else 42 | return $ Just $ Cipher ptr 43 | 44 | -- |@'getCipherNames'@ returns a list of name of symmetric cipher 45 | -- algorithms. 46 | getCipherNames :: IO [String] 47 | getCipherNames = getObjNames CipherMethodType True 48 | 49 | {- encrypt/decrypt ----------------------------------------------------------- -} 50 | 51 | -- | Encrypt a lazy bytestring in a strict manner. Does not leak the keys. 52 | cipherStrictLBS :: Cipher -- ^ Cipher 53 | -> B8.ByteString -- ^ Key 54 | -> B8.ByteString -- ^ IV 55 | -> CryptoMode -- ^ Encrypt\/Decrypt 56 | -> L8.ByteString -- ^ Input 57 | -> IO L8.ByteString 58 | cipherStrictLBS c key iv mode input = 59 | do ctx <- cipherInitBS c key iv mode 60 | xs <- cipherUpdateBS ctx `mapM` L8.toChunks input 61 | x <- cipherFinalBS ctx 62 | return $ L8.fromChunks (xs `mappend` [x]) 63 | 64 | -- |@'cipher'@ lazilly encrypts or decrypts a stream of data. The 65 | -- input string doesn't necessarily have to be finite. 66 | cipher :: Cipher -- ^ algorithm to use 67 | -> String -- ^ symmetric key 68 | -> String -- ^ IV 69 | -> CryptoMode -- ^ operation 70 | -> String -- ^ An input string to encrypt\/decrypt. Note 71 | -- that the string must not contain any letters 72 | -- which aren't in the range of U+0000 - 73 | -- U+00FF. 74 | -> IO String -- ^ the result string 75 | {-# DEPRECATED cipher "Use cipherBS, cipherLBS or cipherStrictLBS." #-} 76 | cipher c key iv mode input 77 | = fmap L8.unpack $ cipherLBS c (B8.pack key) (B8.pack iv) mode (L8.pack input) 78 | 79 | -- |@'cipherBS'@ strictly encrypts or decrypts a chunk of data. 80 | cipherBS :: Cipher -- ^ algorithm to use 81 | -> B8.ByteString -- ^ symmetric key 82 | -> B8.ByteString -- ^ IV 83 | -> CryptoMode -- ^ operation 84 | -> B8.ByteString -- ^ input string to encrypt\/decrypt 85 | -> IO B8.ByteString -- ^ the result string 86 | cipherBS c key iv mode input 87 | = do ctx <- cipherInitBS c key iv mode 88 | cipherStrictly ctx input 89 | 90 | -- |@'cipherLBS'@ lazilly encrypts or decrypts a stream of data. The 91 | -- input string doesn't necessarily have to be finite. 92 | cipherLBS :: Cipher -- ^ algorithm to use 93 | -> B8.ByteString -- ^ symmetric key 94 | -> B8.ByteString -- ^ IV 95 | -> CryptoMode -- ^ operation 96 | -> L8.ByteString -- ^ input string to encrypt\/decrypt 97 | -> IO L8.ByteString -- ^ the result string 98 | cipherLBS c key iv mode input 99 | = do ctx <- cipherInitBS c key iv mode 100 | cipherLazily ctx input 101 | -------------------------------------------------------------------------------- /OpenSSL/EVP/Digest.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | -- |An interface to message digest algorithms. 5 | module OpenSSL.EVP.Digest 6 | ( Digest 7 | , getDigestByName 8 | , getDigestNames 9 | 10 | , digest 11 | , digestBS 12 | , digestLBS 13 | 14 | , hmacBS 15 | , hmacLBS 16 | , pkcs5_pbkdf2_hmac_sha1 17 | ) 18 | where 19 | #include "HsOpenSSL.h" 20 | import Data.ByteString.Internal (create) 21 | import Data.ByteString.Unsafe (unsafeUseAsCStringLen) 22 | import qualified Data.ByteString.Char8 as B8 23 | import qualified Data.ByteString.Lazy.Char8 as L8 24 | #if !MIN_VERSION_base(4,8,0) 25 | import Control.Applicative ((<$>)) 26 | #endif 27 | import Foreign.C.String (CString, withCString) 28 | #if MIN_VERSION_base(4,5,0) 29 | import Foreign.C.Types (CChar(..), CInt(..), CSize(..), CUInt(..)) 30 | #else 31 | import Foreign.C.Types (CChar, CInt, CSize, CUInt) 32 | #endif 33 | import Foreign.Marshal.Alloc (alloca) 34 | import Foreign.Marshal.Array (allocaArray) 35 | import Foreign.Ptr (Ptr, castPtr, nullPtr) 36 | import Foreign.Storable (peek) 37 | import OpenSSL.EVP.Internal 38 | import OpenSSL.Objects 39 | import System.IO.Unsafe (unsafePerformIO) 40 | 41 | foreign import capi unsafe "openssl/evp.h EVP_get_digestbyname" 42 | _get_digestbyname :: CString -> IO (Ptr EVP_MD) 43 | 44 | -- |@'getDigestByName' name@ returns a message digest algorithm whose 45 | -- name is @name@. If no algorithms are found, the result is 46 | -- @Nothing@. 47 | getDigestByName :: String -> IO (Maybe Digest) 48 | getDigestByName name 49 | = withCString name $ \ namePtr -> 50 | do ptr <- _get_digestbyname namePtr 51 | if ptr == nullPtr then 52 | return Nothing 53 | else 54 | return $ Just $ Digest ptr 55 | 56 | -- |@'getDigestNames'@ returns a list of name of message digest 57 | -- algorithms. 58 | getDigestNames :: IO [String] 59 | getDigestNames = getObjNames MDMethodType True 60 | 61 | {- digest -------------------------------------------------------------------- -} 62 | 63 | -- |@'digest'@ digests a stream of data. The string must 64 | -- not contain any letters which aren't in the range of U+0000 - 65 | -- U+00FF. 66 | digest :: Digest -> String -> String 67 | {-# DEPRECATED digest "Use digestBS or digestLBS instead." #-} 68 | digest md input 69 | = B8.unpack $ digestLBS md $ L8.pack input 70 | 71 | -- |@'digestBS'@ digests a chunk of data. 72 | digestBS :: Digest -> B8.ByteString -> B8.ByteString 73 | digestBS md input 74 | = unsafePerformIO $ digestStrictly md input >>= digestFinalBS 75 | 76 | -- |@'digestLBS'@ digests a stream of data. 77 | digestLBS :: Digest -> L8.ByteString -> B8.ByteString 78 | digestLBS md input 79 | = unsafePerformIO $ digestLazily md input >>= digestFinalBS 80 | 81 | {- HMAC ---------------------------------------------------------------------- -} 82 | 83 | foreign import capi unsafe "openssl/hmac.h HMAC" 84 | _HMAC :: Ptr EVP_MD -> Ptr CChar -> CInt -> Ptr CChar -> CSize 85 | -> Ptr CChar -> Ptr CUInt -> IO () 86 | 87 | -- | Perform a private key signing using the HMAC template with a given hash 88 | hmacBS :: Digest -- ^ the hash function to use in the HMAC calculation 89 | -> B8.ByteString -- ^ the HMAC key 90 | -> B8.ByteString -- ^ the data to be signed 91 | -> B8.ByteString -- ^ resulting HMAC 92 | hmacBS (Digest md) key input = 93 | unsafePerformIO $ 94 | allocaArray (#const EVP_MAX_MD_SIZE) $ \bufPtr -> 95 | alloca $ \bufLenPtr -> 96 | unsafeUseAsCStringLen key $ \(keydata, keylen) -> 97 | unsafeUseAsCStringLen input $ \(inputdata, inputlen) -> do 98 | _HMAC md 99 | keydata (fromIntegral keylen) inputdata (fromIntegral inputlen) 100 | bufPtr bufLenPtr 101 | bufLen <- fromIntegral <$> peek bufLenPtr 102 | B8.packCStringLen (bufPtr, bufLen) 103 | 104 | hmacLBS :: Digest -> B8.ByteString -> L8.ByteString -> B8.ByteString 105 | hmacLBS md key input 106 | = unsafePerformIO $ hmacLazily md key input >>= hmacFinalBS 107 | 108 | -- | Calculate a PKCS5-PBKDF2 SHA1-HMAC suitable for password hashing. 109 | pkcs5_pbkdf2_hmac_sha1 :: B8.ByteString -- ^ password 110 | -> B8.ByteString -- ^ salt 111 | -> Int -- ^ iterations 112 | -> Int -- ^ destination key length 113 | -> B8.ByteString -- ^ destination key 114 | pkcs5_pbkdf2_hmac_sha1 pass salt iter dkeylen = 115 | unsafePerformIO $ 116 | unsafeUseAsCStringLen pass $ \(passdata, passlen) -> 117 | unsafeUseAsCStringLen salt $ \(saltdata, saltlen) -> 118 | create dkeylen $ \dkeydata -> 119 | _PKCS5_PBKDF2_HMAC_SHA1 120 | passdata (fromIntegral passlen) 121 | saltdata (fromIntegral saltlen) 122 | (fromIntegral iter) (fromIntegral dkeylen) (castPtr dkeydata) 123 | >> return () 124 | 125 | foreign import capi unsafe "openssl/hmac.h PKCS5_PBKDF2_HMAC_SHA1" 126 | _PKCS5_PBKDF2_HMAC_SHA1 :: Ptr CChar -> CInt 127 | -> Ptr CChar -> CInt 128 | -> CInt -> CInt -> Ptr CChar 129 | -> IO CInt 130 | -------------------------------------------------------------------------------- /OpenSSL/EVP/Open.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | -- |Asymmetric cipher decryption using encrypted symmetric key. This 5 | -- is an opposite of "OpenSSL.EVP.Seal". 6 | module OpenSSL.EVP.Open 7 | ( open 8 | , openBS 9 | , openLBS 10 | ) 11 | where 12 | import qualified Data.ByteString.Char8 as B8 13 | import qualified Data.ByteString.Lazy.Char8 as L8 14 | import qualified Data.ByteString.Unsafe as B8 15 | import Foreign.C.String (CString) 16 | #if MIN_VERSION_base(4,5,0) 17 | import Foreign.C.Types (CChar(..), CInt(..)) 18 | #else 19 | import Foreign.C.Types (CChar, CInt) 20 | #endif 21 | import Foreign.Ptr (Ptr) 22 | import OpenSSL.EVP.Cipher hiding (cipher) 23 | import OpenSSL.EVP.PKey 24 | import OpenSSL.EVP.Internal 25 | import OpenSSL.Utils 26 | import System.IO.Unsafe (unsafePerformIO) 27 | 28 | foreign import capi unsafe "openssl/evp.h EVP_OpenInit" 29 | _OpenInit :: Ptr EVP_CIPHER_CTX 30 | -> Cipher 31 | -> Ptr CChar 32 | -> CInt 33 | -> CString 34 | -> Ptr EVP_PKEY 35 | -> IO CInt 36 | 37 | 38 | openInit :: KeyPair key => 39 | Cipher 40 | -> B8.ByteString 41 | -> B8.ByteString 42 | -> key 43 | -> IO CipherCtx 44 | openInit cipher encKey iv pkey 45 | = do ctx <- newCipherCtx 46 | withCipherCtxPtr ctx $ \ ctxPtr -> 47 | B8.unsafeUseAsCStringLen encKey $ \ (encKeyPtr, encKeyLen) -> 48 | B8.unsafeUseAsCString iv $ \ ivPtr -> 49 | withPKeyPtr' pkey $ \ pkeyPtr -> 50 | _OpenInit ctxPtr cipher encKeyPtr (fromIntegral encKeyLen) ivPtr pkeyPtr 51 | >>= failIf_ (== 0) 52 | return ctx 53 | 54 | -- |@'open'@ lazilly decrypts a stream of data. The input string 55 | -- doesn't necessarily have to be finite. 56 | open :: KeyPair key => 57 | Cipher -- ^ symmetric cipher algorithm to use 58 | -> String -- ^ encrypted symmetric key to decrypt the input string 59 | -> String -- ^ IV 60 | -> key -- ^ private key to decrypt the symmetric key 61 | -> String -- ^ input string to decrypt 62 | -> String -- ^ decrypted string 63 | {-# DEPRECATED open "Use openBS or openLBS instead." #-} 64 | open cipher encKey iv pkey input 65 | = L8.unpack $ openLBS cipher (B8.pack encKey) (B8.pack iv) pkey (L8.pack input) 66 | 67 | -- |@'openBS'@ decrypts a chunk of data. 68 | openBS :: KeyPair key => 69 | Cipher -- ^ symmetric cipher algorithm to use 70 | -> B8.ByteString -- ^ encrypted symmetric key to decrypt the input string 71 | -> B8.ByteString -- ^ IV 72 | -> key -- ^ private key to decrypt the symmetric key 73 | -> B8.ByteString -- ^ input string to decrypt 74 | -> B8.ByteString -- ^ decrypted string 75 | openBS cipher encKey iv pkey input 76 | = unsafePerformIO $ 77 | do ctx <- openInit cipher encKey iv pkey 78 | cipherStrictly ctx input 79 | 80 | -- |@'openLBS'@ lazilly decrypts a stream of data. The input string 81 | -- doesn't necessarily have to be finite. 82 | openLBS :: KeyPair key => 83 | Cipher -- ^ symmetric cipher algorithm to use 84 | -> B8.ByteString -- ^ encrypted symmetric key to decrypt the input string 85 | -> B8.ByteString -- ^ IV 86 | -> key -- ^ private key to decrypt the symmetric key 87 | -> L8.ByteString -- ^ input string to decrypt 88 | -> L8.ByteString -- ^ decrypted string 89 | openLBS cipher encKey iv pkey input 90 | = unsafePerformIO $ 91 | do ctx <- openInit cipher encKey iv pkey 92 | cipherLazily ctx input 93 | -------------------------------------------------------------------------------- /OpenSSL/EVP/PKey.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE ForeignFunctionInterface #-} 4 | {-# LANGUAGE CApiFFI #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | -- |An interface to asymmetric cipher keypair. 8 | module OpenSSL.EVP.PKey 9 | ( PublicKey(..) 10 | , KeyPair(..) 11 | , SomePublicKey 12 | , SomeKeyPair 13 | ) 14 | where 15 | #include "HsOpenSSL.h" 16 | import Data.Typeable 17 | import Data.Maybe 18 | import Foreign 19 | import Foreign.C 20 | import OpenSSL.DSA 21 | import OpenSSL.EVP.Digest 22 | import OpenSSL.EVP.Internal 23 | import OpenSSL.RSA 24 | import OpenSSL.Utils 25 | 26 | -- |Instances of this class has at least public portion of a 27 | -- keypair. They might or might not have the private key. 28 | class (Eq k, Typeable k, PKey k) => PublicKey k where 29 | 30 | -- |Wrap an arbitrary public key into polymorphic type 31 | -- 'SomePublicKey'. 32 | fromPublicKey :: k -> SomePublicKey 33 | fromPublicKey = SomePublicKey 34 | 35 | -- |Cast from the polymorphic type 'SomePublicKey' to the concrete 36 | -- type. Return 'Nothing' if failed. 37 | toPublicKey :: SomePublicKey -> Maybe k 38 | toPublicKey (SomePublicKey pk) = cast pk 39 | 40 | -- |Instances of this class has both of public and private portions of 41 | -- a keypair. 42 | class PublicKey a => KeyPair a where 43 | 44 | -- |Wrap an arbitrary keypair into polymorphic type 'SomeKeyPair'. 45 | fromKeyPair :: a -> SomeKeyPair 46 | fromKeyPair = SomeKeyPair 47 | 48 | -- |Cast from the polymorphic type 'SomeKeyPair' to the concrete 49 | -- type. Return 'Nothing' if failed. 50 | toKeyPair :: SomeKeyPair -> Maybe a 51 | toKeyPair (SomeKeyPair pk) = cast pk 52 | 53 | 54 | 55 | #if OPENSSL_VERSION_PREREQ(3,0) 56 | foreign import capi unsafe "openssl/evp.h EVP_PKEY_get_base_id" getType :: Ptr EVP_PKEY -> IO CInt 57 | #elif OPENSSL_VERSION_NUMBER >= 0x10100000L 58 | foreign import capi unsafe "openssl/evp.h EVP_PKEY_base_id" getType :: Ptr EVP_PKEY -> IO CInt 59 | #else 60 | getType :: Ptr EVP_PKEY -> IO CInt 61 | getType = (#peek EVP_PKEY, type) 62 | #endif 63 | 64 | -- Reconstruct the concrete public-key type from an EVP_PKEY. 65 | withConcretePubKey :: VaguePKey -> (forall k. PublicKey k => k -> IO a) -> IO a 66 | withConcretePubKey pk f 67 | = withPKeyPtr pk $ \ pkeyPtr -> 68 | do pkeyType <- getType pkeyPtr 69 | case pkeyType of 70 | #if !defined(OPENSSL_NO_RSA) 71 | (#const EVP_PKEY_RSA) 72 | -> do rsaPtr <- _get1_RSA pkeyPtr 73 | Just rsa <- absorbRSAPtr rsaPtr 74 | f (rsa :: RSAPubKey) 75 | #endif 76 | #if !defined(OPENSSL_NO_DSA) 77 | (#const EVP_PKEY_DSA) 78 | -> do dsaPtr <- _get1_DSA pkeyPtr 79 | Just dsa <- absorbDSAPtr dsaPtr 80 | f (dsa :: DSAPubKey) 81 | #endif 82 | _ -> fail ("withConcretePubKey: unsupported EVP_PKEY type: " ++ show pkeyType) 83 | 84 | -- Reconstruct the concrete keypair type from an EVP_PKEY. 85 | withConcreteKeyPair :: VaguePKey -> (forall k. KeyPair k => k -> IO a) -> IO a 86 | withConcreteKeyPair pk f 87 | = withPKeyPtr pk $ \ pkeyPtr -> 88 | do pkeyType <- getType pkeyPtr 89 | case pkeyType of 90 | #if !defined(OPENSSL_NO_RSA) 91 | (#const EVP_PKEY_RSA) 92 | -> do rsaPtr <- _get1_RSA pkeyPtr 93 | Just rsa <- absorbRSAPtr rsaPtr 94 | f (rsa :: RSAKeyPair) 95 | #endif 96 | #if !defined(OPENSSL_NO_DSA) 97 | (#const EVP_PKEY_DSA) 98 | -> do dsaPtr <- _get1_DSA pkeyPtr 99 | Just dsa <- absorbDSAPtr dsaPtr 100 | f (dsa :: DSAKeyPair) 101 | #endif 102 | _ -> fail ("withConcreteKeyPair: unsupported EVP_PKEY type: " ++ show pkeyType) 103 | 104 | 105 | -- |This is an opaque type to hold an arbitrary public key in it. The 106 | -- actual key type can be safelly type-casted using 'toPublicKey'. 107 | data SomePublicKey = forall k. PublicKey k => SomePublicKey !k 108 | deriving Typeable 109 | 110 | instance Eq SomePublicKey where 111 | (SomePublicKey a) == (SomePublicKey b) 112 | = case cast b of 113 | Just c -> a == c 114 | Nothing -> False -- different types 115 | 116 | instance PublicKey SomePublicKey where 117 | fromPublicKey = id 118 | toPublicKey = Just 119 | 120 | instance PKey SomePublicKey where 121 | toPKey (SomePublicKey k) = toPKey k 122 | pkeySize (SomePublicKey k) = pkeySize k 123 | pkeyDefaultMD (SomePublicKey k) = pkeyDefaultMD k 124 | fromPKey pk 125 | = withConcretePubKey pk (return . Just . SomePublicKey) 126 | 127 | 128 | -- |This is an opaque type to hold an arbitrary keypair in it. The 129 | -- actual key type can be safelly type-casted using 'toKeyPair'. 130 | data SomeKeyPair = forall k. KeyPair k => SomeKeyPair !k 131 | deriving Typeable 132 | 133 | instance Eq SomeKeyPair where 134 | (SomeKeyPair a) == (SomeKeyPair b) 135 | = case cast b of 136 | Just c -> a == c 137 | Nothing -> False 138 | 139 | instance PublicKey SomeKeyPair where 140 | -- Cast the keypair to a public key, hiding its private part. 141 | fromPublicKey (SomeKeyPair k) 142 | = SomePublicKey k 143 | 144 | -- It's impossible to cast a public key to a keypair. 145 | toPublicKey _ = Nothing 146 | 147 | instance KeyPair SomeKeyPair where 148 | fromKeyPair = id 149 | toKeyPair = Just 150 | 151 | instance PKey SomeKeyPair where 152 | toPKey (SomeKeyPair k) = toPKey k 153 | pkeySize (SomeKeyPair k) = pkeySize k 154 | pkeyDefaultMD (SomeKeyPair k) = pkeyDefaultMD k 155 | fromPKey pk 156 | = withConcreteKeyPair pk (return . Just . SomeKeyPair) 157 | 158 | 159 | #if !defined(OPENSSL_NO_RSA) 160 | -- The resulting Ptr RSA must be freed by caller. 161 | foreign import capi unsafe "openssl/evp.h EVP_PKEY_get1_RSA" 162 | _get1_RSA :: Ptr EVP_PKEY -> IO (Ptr RSA) 163 | 164 | foreign import capi unsafe "openssl/evp.h EVP_PKEY_set1_RSA" 165 | _set1_RSA :: Ptr EVP_PKEY -> Ptr RSA -> IO CInt 166 | 167 | 168 | rsaToPKey :: RSAKey k => k -> IO VaguePKey 169 | rsaToPKey rsa 170 | = withRSAPtr rsa $ \rsaPtr -> 171 | createPKey $ \pkeyPtr -> 172 | _set1_RSA pkeyPtr rsaPtr >>= failIf_ (/= 1) 173 | 174 | rsaFromPKey :: RSAKey k => VaguePKey -> IO (Maybe k) 175 | rsaFromPKey pk 176 | = withPKeyPtr pk $ \ pkeyPtr -> 177 | do pkeyType <- getType pkeyPtr 178 | case pkeyType of 179 | (#const EVP_PKEY_RSA) 180 | -> _get1_RSA pkeyPtr >>= absorbRSAPtr 181 | _ -> return Nothing 182 | 183 | instance PublicKey RSAPubKey 184 | instance PKey RSAPubKey where 185 | toPKey = rsaToPKey 186 | fromPKey = rsaFromPKey 187 | pkeySize = rsaSize 188 | pkeyDefaultMD _ = return . fromJust =<< getDigestByName "sha1" 189 | 190 | instance KeyPair RSAKeyPair 191 | instance PublicKey RSAKeyPair 192 | instance PKey RSAKeyPair where 193 | toPKey = rsaToPKey 194 | fromPKey = rsaFromPKey 195 | pkeySize = rsaSize 196 | pkeyDefaultMD _ = return . fromJust =<< getDigestByName "sha1" 197 | #endif 198 | 199 | 200 | #if !defined(OPENSSL_NO_DSA) 201 | foreign import capi unsafe "openssl/evp.h EVP_PKEY_get1_DSA" 202 | _get1_DSA :: Ptr EVP_PKEY -> IO (Ptr DSA) 203 | 204 | foreign import capi unsafe "openssl/evp.h EVP_PKEY_set1_DSA" 205 | _set1_DSA :: Ptr EVP_PKEY -> Ptr DSA -> IO CInt 206 | 207 | dsaToPKey :: DSAKey k => k -> IO VaguePKey 208 | dsaToPKey dsa 209 | = withDSAPtr dsa $ \dsaPtr -> 210 | createPKey $ \pkeyPtr -> 211 | _set1_DSA pkeyPtr dsaPtr >>= failIf_ (/= 1) 212 | 213 | 214 | dsaFromPKey :: DSAKey k => VaguePKey -> IO (Maybe k) 215 | dsaFromPKey pk 216 | = withPKeyPtr pk $ \ pkeyPtr -> 217 | do pkeyType <- getType pkeyPtr 218 | case pkeyType of 219 | (#const EVP_PKEY_DSA) 220 | -> _get1_DSA pkeyPtr >>= absorbDSAPtr 221 | _ -> return Nothing 222 | 223 | instance PublicKey DSAPubKey 224 | instance PKey DSAPubKey where 225 | toPKey = dsaToPKey 226 | fromPKey = dsaFromPKey 227 | pkeySize = dsaSize 228 | pkeyDefaultMD _ = return . fromJust =<< getDigestByName "dss1" 229 | 230 | instance KeyPair DSAKeyPair 231 | instance PublicKey DSAKeyPair 232 | instance PKey DSAKeyPair where 233 | toPKey = dsaToPKey 234 | fromPKey = dsaFromPKey 235 | pkeySize = dsaSize 236 | pkeyDefaultMD _ = return . fromJust =<< getDigestByName "dss1" 237 | #endif 238 | -------------------------------------------------------------------------------- /OpenSSL/EVP/Seal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE CApiFFI #-} 3 | -- |Asymmetric cipher decryption using encrypted symmetric key. This 4 | -- is an opposite of "OpenSSL.EVP.Open". 5 | module OpenSSL.EVP.Seal 6 | ( seal 7 | , sealBS 8 | , sealLBS 9 | ) 10 | where 11 | import qualified Data.ByteString.Char8 as B8 12 | import qualified Data.ByteString.Lazy.Char8 as L8 13 | import Foreign 14 | import Foreign.C 15 | import OpenSSL.EVP.Cipher hiding (cipher) 16 | import OpenSSL.EVP.PKey 17 | import OpenSSL.EVP.Internal 18 | import OpenSSL.Utils 19 | 20 | 21 | foreign import capi unsafe "openssl/evp.h EVP_SealInit" 22 | _SealInit :: Ptr EVP_CIPHER_CTX 23 | -> Cipher 24 | -> Ptr (Ptr CChar) 25 | -> Ptr CInt 26 | -> Ptr CChar 27 | -> Ptr (Ptr EVP_PKEY) 28 | -> CInt 29 | -> IO CInt 30 | 31 | 32 | sealInit :: Cipher 33 | -> [SomePublicKey] 34 | -> IO (CipherCtx, [B8.ByteString], B8.ByteString) 35 | 36 | sealInit _ [] 37 | = fail "sealInit: at least one public key is required" 38 | 39 | sealInit cipher pubKeys 40 | = do ctx <- newCipherCtx 41 | 42 | -- Allocate a list of buffers to write encrypted symmetric 43 | -- keys. Each keys will be at most pkeySize bytes long. 44 | encKeyBufs <- mapM mallocEncKeyBuf pubKeys 45 | 46 | -- encKeyBufs is [Ptr a] but we want Ptr (Ptr CChar). 47 | encKeyBufsPtr <- newArray encKeyBufs 48 | 49 | -- Allocate a buffer to write lengths of each encrypted 50 | -- symmetric keys. 51 | encKeyBufsLenPtr <- mallocArray nKeys 52 | 53 | -- Allocate a buffer to write IV. 54 | ivPtr <- mallocArray (cipherIvLength cipher) 55 | 56 | -- Create Ptr (Ptr EVP_PKEY) from [PKey]. Don't forget to 57 | -- apply touchForeignPtr to each PKey's later. 58 | pkeys <- mapM toPKey pubKeys 59 | pubKeysPtr <- newArray $ map unsafePKeyToPtr pkeys 60 | 61 | -- Prepare an IO action to free buffers we allocated above. 62 | let cleanup = do mapM_ free encKeyBufs 63 | free encKeyBufsPtr 64 | free encKeyBufsLenPtr 65 | free ivPtr 66 | free pubKeysPtr 67 | mapM_ touchPKey pkeys 68 | 69 | -- Call EVP_SealInit finally. 70 | ret <- withCipherCtxPtr ctx $ \ ctxPtr -> 71 | _SealInit ctxPtr cipher encKeyBufsPtr encKeyBufsLenPtr ivPtr pubKeysPtr (fromIntegral nKeys) 72 | 73 | if ret == 0 then 74 | cleanup >> raiseOpenSSLError 75 | else 76 | do encKeysLen <- peekArray nKeys encKeyBufsLenPtr 77 | encKeys <- mapM B8.packCStringLen $ zip encKeyBufs (fromIntegral `fmap` encKeysLen) 78 | iv <- B8.packCStringLen (ivPtr, cipherIvLength cipher) 79 | cleanup 80 | return (ctx, encKeys, iv) 81 | where 82 | nKeys :: Int 83 | nKeys = length pubKeys 84 | 85 | mallocEncKeyBuf :: (PKey k, Storable a) => k -> IO (Ptr a) 86 | mallocEncKeyBuf = mallocArray . pkeySize 87 | 88 | -- |@'seal'@ lazilly encrypts a stream of data. The input string 89 | -- doesn't necessarily have to be finite. 90 | seal :: Cipher -- ^ symmetric cipher algorithm to use 91 | -> [SomePublicKey] -- ^ A list of public keys to encrypt a 92 | -- symmetric key. At least one public key 93 | -- must be supplied. If two or more keys are 94 | -- given, the symmetric key are encrypted by 95 | -- each public keys so that any of the 96 | -- corresponding private keys can decrypt 97 | -- the message. 98 | -> String -- ^ input string to encrypt 99 | -> IO ( String 100 | , [String] 101 | , String 102 | ) -- ^ (encrypted string, list of encrypted asymmetric 103 | -- keys, IV) 104 | {-# DEPRECATED seal "Use sealBS or sealLBS instead." #-} 105 | seal cipher pubKeys input 106 | = do (output, encKeys, iv) <- sealLBS cipher pubKeys $ L8.pack input 107 | return ( L8.unpack output 108 | , B8.unpack `fmap` encKeys 109 | , B8.unpack iv 110 | ) 111 | 112 | -- |@'sealBS'@ strictly encrypts a chunk of data. 113 | sealBS :: Cipher -- ^ symmetric cipher algorithm to use 114 | -> [SomePublicKey] -- ^ list of public keys to encrypt a 115 | -- symmetric key 116 | -> B8.ByteString -- ^ input string to encrypt 117 | -> IO ( B8.ByteString 118 | , [B8.ByteString] 119 | , B8.ByteString 120 | ) -- ^ (encrypted string, list of encrypted asymmetric 121 | -- keys, IV) 122 | sealBS cipher pubKeys input 123 | = do (ctx, encKeys, iv) <- sealInit cipher pubKeys 124 | output <- cipherStrictly ctx input 125 | return (output, encKeys, iv) 126 | 127 | -- |@'sealLBS'@ lazilly encrypts a stream of data. The input string 128 | -- doesn't necessarily have to be finite. 129 | sealLBS :: Cipher -- ^ symmetric cipher algorithm to use 130 | -> [SomePublicKey] -- ^ list of public keys to encrypt a 131 | -- symmetric key 132 | -> L8.ByteString -- ^ input string to encrypt 133 | -> IO ( L8.ByteString 134 | , [B8.ByteString] 135 | , B8.ByteString 136 | ) -- ^ (encrypted string, list of encrypted asymmetric 137 | -- keys, IV) 138 | sealLBS cipher pubKeys input 139 | = do (ctx, encKeys, iv) <- sealInit cipher pubKeys 140 | output <- cipherLazily ctx input 141 | return (output, encKeys, iv) 142 | -------------------------------------------------------------------------------- /OpenSSL/EVP/Sign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | -- |Message signing using asymmetric cipher and message digest 5 | -- algorithm. This is an opposite of "OpenSSL.EVP.Verify". 6 | module OpenSSL.EVP.Sign 7 | ( sign 8 | , signBS 9 | , signLBS 10 | ) 11 | where 12 | import qualified Data.ByteString.Char8 as B8 13 | import qualified Data.ByteString.Internal as B8 14 | import qualified Data.ByteString.Lazy.Char8 as L8 15 | #if !MIN_VERSION_base(4,8,0) 16 | import Control.Applicative ((<$>)) 17 | #endif 18 | import Foreign 19 | import Foreign.C 20 | import OpenSSL.EVP.Digest 21 | import OpenSSL.EVP.PKey 22 | import OpenSSL.EVP.Internal 23 | import OpenSSL.Utils 24 | 25 | foreign import capi unsafe "openssl/evp.h EVP_SignFinal" 26 | _SignFinal :: Ptr EVP_MD_CTX -> Ptr Word8 -> Ptr CUInt 27 | -> Ptr EVP_PKEY -> IO CInt 28 | 29 | signFinal :: KeyPair k => DigestCtx -> k -> IO B8.ByteString 30 | signFinal ctx k = do 31 | let maxLen = pkeySize k 32 | withDigestCtxPtr ctx $ \ ctxPtr -> 33 | withPKeyPtr' k $ \ pkeyPtr -> 34 | B8.createAndTrim maxLen $ \ bufPtr -> 35 | alloca $ \ bufLenPtr -> do 36 | failIf_ (/= 1) =<< _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr 37 | fromIntegral <$> peek bufLenPtr 38 | 39 | -- |@'sign'@ generates a signature from a stream of data. The string 40 | -- must not contain any letters which aren't in the range of U+0000 - 41 | -- U+00FF. 42 | sign :: KeyPair key => 43 | Digest -- ^ message digest algorithm to use 44 | -> key -- ^ private key to sign the message digest 45 | -> String -- ^ input string 46 | -> IO String -- ^ the result signature 47 | {-# DEPRECATED sign "Use signBS or signLBS instead." #-} 48 | sign md pkey input 49 | = fmap L8.unpack $ signLBS md pkey $ L8.pack input 50 | 51 | -- |@'signBS'@ generates a signature from a chunk of data. 52 | signBS :: KeyPair key => 53 | Digest -- ^ message digest algorithm to use 54 | -> key -- ^ private key to sign the message digest 55 | -> B8.ByteString -- ^ input string 56 | -> IO B8.ByteString -- ^ the result signature 57 | signBS md pkey input 58 | = do ctx <- digestStrictly md input 59 | signFinal ctx pkey 60 | 61 | -- |@'signLBS'@ generates a signature from a stream of data. 62 | signLBS :: KeyPair key => 63 | Digest -- ^ message digest algorithm to use 64 | -> key -- ^ private key to sign the message digest 65 | -> L8.ByteString -- ^ input string 66 | -> IO L8.ByteString -- ^ the result signature 67 | signLBS md pkey input 68 | = do ctx <- digestLazily md input 69 | sig <- signFinal ctx pkey 70 | return $ L8.fromChunks [sig] 71 | -------------------------------------------------------------------------------- /OpenSSL/EVP/Verify.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | -- |Message verification using asymmetric cipher and message digest 5 | -- algorithm. This is an opposite of "OpenSSL.EVP.Sign". 6 | module OpenSSL.EVP.Verify 7 | ( VerifyStatus(..) 8 | , verify 9 | , verifyBS 10 | , verifyLBS 11 | ) 12 | where 13 | import qualified Data.ByteString.Char8 as B8 14 | import qualified Data.ByteString.Lazy.Char8 as L8 15 | import qualified Data.ByteString.Unsafe as B8 16 | import Data.Typeable 17 | import Foreign 18 | import Foreign.C 19 | import OpenSSL.EVP.Digest 20 | import OpenSSL.EVP.PKey 21 | import OpenSSL.EVP.Internal 22 | import OpenSSL.Utils 23 | 24 | -- |@'VerifyStatus'@ represents a result of verification. 25 | data VerifyStatus = VerifySuccess 26 | | VerifyFailure 27 | deriving (Show, Eq, Typeable) 28 | 29 | 30 | foreign import capi unsafe "openssl/evp.h EVP_VerifyFinal" 31 | _VerifyFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> CUInt -> Ptr EVP_PKEY -> IO CInt 32 | 33 | 34 | verifyFinalBS :: PublicKey k => 35 | DigestCtx 36 | -> B8.ByteString 37 | -> k 38 | -> IO VerifyStatus 39 | verifyFinalBS ctx sig k 40 | = withDigestCtxPtr ctx $ \ ctxPtr -> 41 | B8.unsafeUseAsCStringLen sig $ \ (buf, len) -> 42 | withPKeyPtr' k $ \ pkeyPtr -> 43 | _VerifyFinal ctxPtr buf (fromIntegral len) pkeyPtr >>= interpret 44 | where 45 | interpret :: CInt -> IO VerifyStatus 46 | interpret 1 = return VerifySuccess 47 | interpret 0 = return VerifyFailure 48 | interpret _ = raiseOpenSSLError 49 | 50 | -- |@'verify'@ verifies a signature and a stream of data. The string 51 | -- must not contain any letters which aren't in the range of U+0000 - 52 | -- U+00FF. 53 | verify :: PublicKey key => 54 | Digest -- ^ message digest algorithm to use 55 | -> String -- ^ message signature 56 | -> key -- ^ public key to verify the signature 57 | -> String -- ^ input string to verify 58 | -> IO VerifyStatus -- ^ the result of verification 59 | {-# DEPRECATED verify "Use verifyBS or verifyLBS instead." #-} 60 | verify md sig pkey input 61 | = verifyLBS md (B8.pack sig) pkey (L8.pack input) 62 | 63 | -- |@'verifyBS'@ verifies a signature and a chunk of data. 64 | verifyBS :: PublicKey key => 65 | Digest -- ^ message digest algorithm to use 66 | -> B8.ByteString -- ^ message signature 67 | -> key -- ^ public key to verify the signature 68 | -> B8.ByteString -- ^ input string to verify 69 | -> IO VerifyStatus -- ^ the result of verification 70 | verifyBS md sig pkey input 71 | = do ctx <- digestStrictly md input 72 | verifyFinalBS ctx sig pkey 73 | 74 | -- |@'verifyLBS'@ verifies a signature of a stream of data. 75 | verifyLBS :: PublicKey key => 76 | Digest -- ^ message digest algorithm to use 77 | -> B8.ByteString -- ^ message signature 78 | -> key -- ^ public key to verify the signature 79 | -> L8.ByteString -- ^ input string to verify 80 | -> IO VerifyStatus -- ^ the result of verification 81 | verifyLBS md sig pkey input 82 | = do ctx <- digestLazily md input 83 | verifyFinalBS ctx sig pkey 84 | -------------------------------------------------------------------------------- /OpenSSL/Objects.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | module OpenSSL.Objects 5 | ( ObjNameType(..) 6 | , getObjNames 7 | ) 8 | where 9 | #include "HsOpenSSL.h" 10 | import Data.IORef 11 | import Foreign 12 | import Foreign.C 13 | 14 | 15 | type ObjName = Ptr OBJ_NAME 16 | data {-# CTYPE "openssl/objects.h" "OBJ_NAME" #-} OBJ_NAME 17 | 18 | type DoAllCallback = ObjName -> Ptr () -> IO () 19 | 20 | 21 | foreign import capi safe "openssl/objects.h OBJ_NAME_do_all" 22 | _NAME_do_all :: CInt -> FunPtr DoAllCallback -> Ptr () -> IO () 23 | 24 | foreign import capi safe "openssl/objects.h OBJ_NAME_do_all_sorted" 25 | _NAME_do_all_sorted :: CInt -> FunPtr DoAllCallback -> Ptr () -> IO () 26 | 27 | foreign import ccall "wrapper" 28 | mkDoAllCallback :: DoAllCallback -> IO (FunPtr DoAllCallback) 29 | 30 | 31 | data ObjNameType = MDMethodType 32 | | CipherMethodType 33 | | PKeyMethodType 34 | | CompMethodType 35 | 36 | objNameTypeToInt :: ObjNameType -> CInt 37 | objNameTypeToInt MDMethodType = #const OBJ_NAME_TYPE_MD_METH 38 | objNameTypeToInt CipherMethodType = #const OBJ_NAME_TYPE_CIPHER_METH 39 | objNameTypeToInt PKeyMethodType = #const OBJ_NAME_TYPE_PKEY_METH 40 | objNameTypeToInt CompMethodType = #const OBJ_NAME_TYPE_COMP_METH 41 | 42 | 43 | iterateObjNames :: ObjNameType -> Bool -> (ObjName -> IO ()) -> IO () 44 | iterateObjNames nameType wantSorted cb 45 | = do cbPtr <- mkDoAllCallback $ \ name _ -> cb name 46 | let action = if wantSorted then 47 | _NAME_do_all_sorted 48 | else 49 | _NAME_do_all 50 | action (objNameTypeToInt nameType) cbPtr nullPtr 51 | freeHaskellFunPtr cbPtr 52 | 53 | 54 | objNameStr :: ObjName -> IO String 55 | objNameStr name 56 | = (#peek OBJ_NAME, name) name >>= peekCString 57 | 58 | 59 | getObjNames :: ObjNameType -> Bool -> IO [String] 60 | getObjNames nameType wantSorted 61 | = do listRef <- newIORef [] 62 | iterateObjNames nameType wantSorted $ \ name -> 63 | do nameStr <- objNameStr name 64 | modifyIORef listRef (++ [nameStr]) 65 | readIORef listRef 66 | -------------------------------------------------------------------------------- /OpenSSL/RSA.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE ForeignFunctionInterface #-} 4 | {-# LANGUAGE CApiFFI #-} 5 | {-# OPTIONS_HADDOCK prune #-} 6 | -- |An interface to RSA public key generator. 7 | module OpenSSL.RSA 8 | ( -- * Type 9 | RSAKey(..) 10 | , RSAPubKey 11 | , RSAKeyPair 12 | , RSA -- private 13 | 14 | -- * Generating keypair 15 | , RSAGenKeyCallback 16 | , generateRSAKey 17 | , generateRSAKey' 18 | 19 | -- * Exploring keypair 20 | , rsaD 21 | , rsaP 22 | , rsaQ 23 | , rsaDMP1 24 | , rsaDMQ1 25 | , rsaIQMP 26 | , rsaCopyPublic 27 | , rsaKeyPairFinalize -- private 28 | ) 29 | where 30 | #include "HsOpenSSL.h" 31 | import Control.Monad 32 | #if !MIN_VERSION_base(4,8,0) 33 | import Control.Applicative ((<$>)) 34 | #endif 35 | import Data.Typeable 36 | 37 | #if MIN_VERSION_base(4,5,0) 38 | import Foreign.C.Types (CInt(..)) 39 | #else 40 | import Foreign.C.Types (CInt) 41 | #endif 42 | import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, newForeignPtr, withForeignPtr) 43 | import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr, nullFunPtr, nullPtr) 44 | import Foreign.Storable (Storable(..)) 45 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 46 | import Foreign.Marshal.Alloc (alloca) 47 | #endif 48 | import OpenSSL.BN 49 | import OpenSSL.Utils 50 | import System.IO.Unsafe (unsafePerformIO) 51 | 52 | -- |@'RSAPubKey'@ is an opaque object that represents RSA public key. 53 | newtype RSAPubKey = RSAPubKey (ForeignPtr RSA) 54 | deriving Typeable 55 | 56 | -- |@'RSAKeyPair'@ is an opaque object that represents RSA keypair. 57 | newtype RSAKeyPair = RSAKeyPair (ForeignPtr RSA) 58 | deriving Typeable 59 | 60 | -- RSAPubKey and RSAKeyPair are in fact the same type at the OpenSSL 61 | -- level, but we want to treat them differently for type-safety. 62 | data {-# CTYPE "openssl/rsa.h" "RSA" #-} RSA 63 | 64 | -- |@'RSAKey' a@ is either 'RSAPubKey' or 'RSAKeyPair'. 65 | class RSAKey k where 66 | -- |@'rsaSize' key@ returns the length of key. 67 | rsaSize :: k -> Int 68 | rsaSize rsa 69 | = unsafePerformIO $ 70 | withRSAPtr rsa $ \ rsaPtr -> 71 | fmap fromIntegral (_size rsaPtr) 72 | 73 | -- |@'rsaN' key@ returns the public modulus of the key. 74 | rsaN :: k -> Integer 75 | rsaN = peekI rsa_n 76 | 77 | -- |@'rsaE' key@ returns the public exponent of the key. 78 | rsaE :: k -> Integer 79 | rsaE = peekI rsa_e 80 | 81 | -- private 82 | withRSAPtr :: k -> (Ptr RSA -> IO a) -> IO a 83 | peekRSAPtr :: Ptr RSA -> IO (Maybe k) 84 | absorbRSAPtr :: Ptr RSA -> IO (Maybe k) 85 | 86 | 87 | instance RSAKey RSAPubKey where 88 | withRSAPtr (RSAPubKey fp) = withForeignPtr fp 89 | peekRSAPtr rsaPtr = _pubDup rsaPtr >>= absorbRSAPtr 90 | absorbRSAPtr rsaPtr = fmap (Just . RSAPubKey) (newForeignPtr _free rsaPtr) 91 | 92 | 93 | instance RSAKey RSAKeyPair where 94 | withRSAPtr (RSAKeyPair fp) = withForeignPtr fp 95 | peekRSAPtr rsaPtr 96 | = do hasP <- hasRSAPrivateKey rsaPtr 97 | if hasP then 98 | _privDup rsaPtr >>= absorbRSAPtr 99 | else 100 | return Nothing 101 | absorbRSAPtr rsaPtr 102 | = do hasP <- hasRSAPrivateKey rsaPtr 103 | if hasP then 104 | fmap (Just . RSAKeyPair) (newForeignPtr _free rsaPtr) 105 | else 106 | return Nothing 107 | 108 | 109 | hasRSAPrivateKey :: Ptr RSA -> IO Bool 110 | hasRSAPrivateKey rsaPtr 111 | = do d <- rsa_d rsaPtr 112 | p <- rsa_p rsaPtr 113 | q <- rsa_q rsaPtr 114 | return (d /= nullPtr && p /= nullPtr && q /= nullPtr) 115 | 116 | 117 | 118 | foreign import capi unsafe "openssl/rsa.h &RSA_free" 119 | _free :: FunPtr (Ptr RSA -> IO ()) 120 | 121 | foreign import capi unsafe "openssl/rsa.h RSAPublicKey_dup" 122 | _pubDup :: Ptr RSA -> IO (Ptr RSA) 123 | 124 | foreign import capi unsafe "openssl/rsa.h RSAPrivateKey_dup" 125 | _privDup :: Ptr RSA -> IO (Ptr RSA) 126 | 127 | foreign import capi unsafe "openssl/rsa.h RSA_size" 128 | _size :: Ptr RSA -> IO CInt 129 | 130 | -- | Make a copy of the public parameters of the given key. 131 | rsaCopyPublic :: RSAKey key => key -> IO RSAPubKey 132 | rsaCopyPublic key = withRSAPtr key (fmap RSAPubKey . (newForeignPtr _free =<<) . _pubDup) 133 | 134 | -- private 135 | rsaKeyPairFinalize :: RSAKeyPair -> IO () 136 | rsaKeyPairFinalize (RSAKeyPair fp) = finalizeForeignPtr fp 137 | 138 | {- generation --------------------------------------------------------------- -} 139 | 140 | -- |@'RSAGenKeyCallback'@ represents a callback function to get 141 | -- informed the progress of RSA key generation. 142 | -- 143 | -- * @callback 0 i@ is called after generating the @i@-th potential 144 | -- prime number. 145 | -- 146 | -- * While the number is being tested for primality, @callback 1 j@ is 147 | -- called after the @j@-th iteration (j = 0, 1, ...). 148 | -- 149 | -- * When the @n@-th randomly generated prime is rejected as not 150 | -- suitable for the key, @callback 2 n@ is called. 151 | -- 152 | -- * When a random @p@ has been found with @p@-1 relatively prime to 153 | -- @e@, it is called as @callback 3 0@. 154 | -- 155 | -- * The process is then repeated for prime @q@ with @callback 3 1@. 156 | type RSAGenKeyCallback = Int -> Int -> IO () 157 | 158 | type RSAGenKeyCallback' = Int -> Int -> Ptr () -> IO () 159 | 160 | 161 | foreign import ccall "wrapper" 162 | mkGenKeyCallback :: RSAGenKeyCallback' -> IO (FunPtr RSAGenKeyCallback') 163 | 164 | foreign import capi safe "openssl/rsa.h RSA_generate_key" 165 | _generate_key :: CInt -> CInt -> FunPtr RSAGenKeyCallback' -> Ptr a -> IO (Ptr RSA) 166 | 167 | -- |@'generateRSAKey'@ generates an RSA keypair. 168 | generateRSAKey :: Int -- ^ The number of bits of the public modulus 169 | -- (i.e. key size). Key sizes with @n < 170 | -- 1024@ should be considered insecure. 171 | -> Int -- ^ The public exponent. It is an odd 172 | -- number, typically 3, 17 or 65537. 173 | -> Maybe RSAGenKeyCallback -- ^ A callback function. 174 | -> IO RSAKeyPair -- ^ The generated keypair. 175 | 176 | generateRSAKey nbits e Nothing 177 | = do ptr <- _generate_key (fromIntegral nbits) (fromIntegral e) nullFunPtr nullPtr 178 | failIfNull_ ptr 179 | fmap RSAKeyPair (newForeignPtr _free ptr) 180 | 181 | generateRSAKey nbits e (Just cb) 182 | = do cbPtr <- mkGenKeyCallback 183 | $ \ arg1 arg2 _ -> cb arg1 arg2 184 | ptr <- _generate_key (fromIntegral nbits) (fromIntegral e) cbPtr nullPtr 185 | freeHaskellFunPtr cbPtr 186 | failIfNull_ ptr 187 | fmap RSAKeyPair (newForeignPtr _free ptr) 188 | 189 | -- |A simplified alternative to 'generateRSAKey' 190 | generateRSAKey' :: Int -- ^ The number of bits of the public modulus 191 | -- (i.e. key size). Key sizes with @n < 192 | -- 1024@ should be considered insecure. 193 | -> Int -- ^ The public exponent. It is an odd 194 | -- number, typically 3, 17 or 65537. 195 | -> IO RSAKeyPair -- ^ The generated keypair. 196 | generateRSAKey' nbits e 197 | = generateRSAKey nbits e Nothing 198 | 199 | 200 | {- exploration -------------------------------------------------------------- -} 201 | 202 | rsa_n, rsa_e, rsa_d, rsa_p, rsa_q :: Ptr RSA -> IO (Ptr BIGNUM) 203 | rsa_dmp1, rsa_dmq1, rsa_iqmp :: Ptr RSA -> IO (Ptr BIGNUM) 204 | 205 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 206 | 207 | foreign import capi unsafe "openssl/rsa.h RSA_get0_key" 208 | _get0_key :: Ptr RSA -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO () 209 | 210 | foreign import capi unsafe "openssl/rsa.h RSA_get0_factors" 211 | _get0_factors :: Ptr RSA -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO () 212 | 213 | foreign import capi unsafe "openssl/rsa.h RSA_get0_crt_params" 214 | _get0_crt_params :: Ptr RSA -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO () 215 | 216 | withNED :: (Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO b) 217 | -> Ptr RSA -> IO b 218 | withNED f rsa = alloca $ \ n -> alloca $ \ e -> alloca $ \ d -> do 219 | poke n nullPtr 220 | poke e nullPtr 221 | poke d nullPtr 222 | _get0_key rsa n e d 223 | f n e d 224 | 225 | rsa_n = withNED $ \ n _ _ -> peek n 226 | rsa_e = withNED $ \ _ e _ -> peek e 227 | rsa_d = withNED $ \ _ _ d -> peek d 228 | 229 | withFactors 230 | :: (Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO a) -> Ptr RSA -> IO a 231 | withFactors f rsa = alloca $ \ p -> alloca $ \ q -> do 232 | poke p nullPtr 233 | poke q nullPtr 234 | _get0_factors rsa p q 235 | f p q 236 | 237 | rsa_p = withFactors $ \ p _ -> peek p 238 | rsa_q = withFactors $ \ _ q -> peek q 239 | 240 | withCrtParams 241 | :: (Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO b) 242 | -> Ptr RSA -> IO b 243 | withCrtParams f rsa = alloca $ \ dmp1 -> alloca $ \ dmq1 -> alloca $ \ iqmp -> do 244 | poke dmp1 nullPtr 245 | poke dmq1 nullPtr 246 | poke iqmp nullPtr 247 | _get0_crt_params rsa dmp1 dmq1 iqmp 248 | f dmp1 dmq1 iqmp 249 | 250 | rsa_dmp1 = withCrtParams $ \ dmp1 _ _ -> peek dmp1 251 | rsa_dmq1 = withCrtParams $ \ _ dmq1 _ -> peek dmq1 252 | rsa_iqmp = withCrtParams $ \ _ _ iqmp -> peek iqmp 253 | 254 | #else 255 | 256 | rsa_n = (#peek RSA, n) 257 | rsa_e = (#peek RSA, e) 258 | rsa_d = (#peek RSA, d) 259 | rsa_p = (#peek RSA, p) 260 | rsa_q = (#peek RSA, q) 261 | rsa_dmp1 = (#peek RSA, dmp1) 262 | rsa_dmq1 = (#peek RSA, dmq1) 263 | rsa_iqmp = (#peek RSA, iqmp) 264 | 265 | #endif 266 | 267 | peekI :: RSAKey a => (Ptr RSA -> IO (Ptr BIGNUM)) -> a -> Integer 268 | peekI peeker rsa 269 | = unsafePerformIO $ 270 | withRSAPtr rsa $ \ rsaPtr -> 271 | do bn <- peeker rsaPtr 272 | when (bn == nullPtr) $ fail "peekI: got a nullPtr" 273 | peekBN (wrapBN bn) 274 | 275 | peekMI :: RSAKey a => (Ptr RSA -> IO (Ptr BIGNUM)) -> a -> Maybe Integer 276 | peekMI peeker rsa 277 | = unsafePerformIO $ 278 | withRSAPtr rsa $ \ rsaPtr -> 279 | do bn <- peeker rsaPtr 280 | if bn == nullPtr then 281 | return Nothing 282 | else 283 | fmap Just (peekBN (wrapBN bn)) 284 | 285 | -- |@'rsaD' privKey@ returns the private exponent of the key. 286 | rsaD :: RSAKeyPair -> Integer 287 | rsaD = peekI rsa_d 288 | 289 | -- |@'rsaP' privkey@ returns the secret prime factor @p@ of the key. 290 | rsaP :: RSAKeyPair -> Integer 291 | rsaP = peekI rsa_p 292 | 293 | -- |@'rsaQ' privkey@ returns the secret prime factor @q@ of the key. 294 | rsaQ :: RSAKeyPair -> Integer 295 | rsaQ = peekI rsa_q 296 | 297 | -- |@'rsaDMP1' privkey@ returns @d mod (p-1)@ of the key. 298 | rsaDMP1 :: RSAKeyPair -> Maybe Integer 299 | rsaDMP1 = peekMI rsa_dmp1 300 | 301 | -- |@'rsaDMQ1' privkey@ returns @d mod (q-1)@ of the key. 302 | rsaDMQ1 :: RSAKeyPair -> Maybe Integer 303 | rsaDMQ1 = peekMI rsa_dmq1 304 | 305 | -- |@'rsaIQMP' privkey@ returns @q^-1 mod p@ of the key. 306 | rsaIQMP :: RSAKeyPair -> Maybe Integer 307 | rsaIQMP = peekMI rsa_iqmp 308 | 309 | {- instances ---------------------------------------------------------------- -} 310 | 311 | instance Eq RSAPubKey where 312 | a == b 313 | = rsaN a == rsaN b && 314 | rsaE a == rsaE b 315 | 316 | instance Eq RSAKeyPair where 317 | a == b 318 | = rsaN a == rsaN b && 319 | rsaE a == rsaE b && 320 | rsaD a == rsaD b && 321 | rsaP a == rsaP b && 322 | rsaQ a == rsaQ b 323 | 324 | instance Ord RSAPubKey where 325 | a `compare` b 326 | | rsaN a < rsaN b = LT 327 | | rsaN a > rsaN b = GT 328 | | rsaE a < rsaE b = LT 329 | | rsaE a > rsaE b = GT 330 | | otherwise = EQ 331 | 332 | instance Ord RSAKeyPair where 333 | a `compare` b 334 | | rsaN a < rsaN b = LT 335 | | rsaN a > rsaN b = GT 336 | | rsaE a < rsaE b = LT 337 | | rsaE a > rsaE b = GT 338 | | rsaD a < rsaD b = LT 339 | | rsaD a > rsaD b = GT 340 | | rsaP a < rsaP b = LT 341 | | rsaP a > rsaP b = GT 342 | | rsaQ a < rsaQ b = LT 343 | | rsaQ a > rsaQ b = GT 344 | | otherwise = EQ 345 | 346 | instance Show RSAPubKey where 347 | show a 348 | = concat [ "RSAPubKey {" 349 | , "rsaN = ", show (rsaN a), ", " 350 | , "rsaE = ", show (rsaE a) 351 | , "}" 352 | ] 353 | 354 | instance Show RSAKeyPair where 355 | show a 356 | = concat [ "RSAKeyPair {" 357 | , "rsaN = ", show (rsaN a), ", " 358 | , "rsaE = ", show (rsaE a), ", " 359 | , "rsaD = ", show (rsaD a), ", " 360 | , "rsaP = ", show (rsaP a), ", " 361 | , "rsaQ = ", show (rsaQ a) 362 | , "}" 363 | ] 364 | -------------------------------------------------------------------------------- /OpenSSL/Random.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE CApiFFI #-} 3 | -- | PRNG services 4 | -- See 5 | -- For random Integer generation, see "OpenSSL.BN" 6 | module OpenSSL.Random 7 | ( -- * Random byte generation 8 | randBytes 9 | , prandBytes 10 | , add 11 | ) where 12 | import Foreign 13 | import Foreign.C.Types 14 | import qualified Data.ByteString as BS 15 | import OpenSSL.Utils 16 | 17 | foreign import capi unsafe "openssl/rand.h RAND_bytes" 18 | _RAND_bytes :: Ptr CChar -> CInt -> IO CInt 19 | 20 | foreign import capi unsafe "openssl/rand.h RAND_pseudo_bytes" 21 | _RAND_pseudo_bytes :: Ptr CChar -> CInt -> IO () 22 | 23 | foreign import capi unsafe "openssl/rand.h RAND_add" 24 | _RAND_add :: Ptr CChar -> CInt -> CInt -> IO () 25 | 26 | -- | Return a bytestring consisting of the given number of strongly random 27 | -- bytes 28 | randBytes :: Int -- ^ the number of bytes requested 29 | -> IO BS.ByteString 30 | randBytes n = 31 | allocaArray n $ \bufPtr -> 32 | do _RAND_bytes bufPtr (fromIntegral n) >>= failIf_ (/= 1) 33 | BS.packCStringLen (bufPtr, n) 34 | 35 | -- | Return a bytestring consisting of the given number of pseudo random 36 | -- bytes 37 | prandBytes :: Int -- ^ the number of bytes requested 38 | -> IO BS.ByteString 39 | prandBytes n = 40 | allocaArray n $ \bufPtr -> 41 | do _RAND_pseudo_bytes bufPtr (fromIntegral n) 42 | BS.packCStringLen (bufPtr, n) 43 | 44 | -- | Add data to the entropy pool. It's safe to add sensitive information 45 | -- (e.g. user passwords etc) to the pool. Also, adding data with an entropy 46 | -- of 0 can never hurt. 47 | add :: BS.ByteString -- ^ random data to be added to the pool 48 | -> Int -- ^ the number of bits of entropy in the first argument 49 | -> IO () 50 | add bs entropy = 51 | BS.useAsCStringLen bs $ \(ptr, len) -> 52 | _RAND_add ptr (fromIntegral len) (fromIntegral entropy) 53 | -------------------------------------------------------------------------------- /OpenSSL/SSL/Option.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | -- | See https://www.openssl.org/docs/ssl/SSL_CTX_set_options.html 3 | module OpenSSL.SSL.Option 4 | ( SSLOption(..) 5 | , optionToIntegral 6 | ) 7 | where 8 | import Data.Typeable 9 | 10 | #include 11 | 12 | -- | The behaviour of the SSL library can be changed by setting 13 | -- several options. During a handshake, the option settings of the 14 | -- 'OpenSSL.Session.SSL' object are used. When a new 15 | -- 'OpenSSL.Session.SSL' object is created from a 16 | -- 'OpenSSL.Session.SSLContext', the current option setting is 17 | -- copied. Changes to 'OpenSSL.Session.SSLContext' do not affect 18 | -- already created 'OpenSSL.Session.SSL' objects. 19 | data SSLOption 20 | = -- | As of OpenSSL 1.0.0 this option has no effect. 21 | SSL_OP_MICROSOFT_SESS_ID_BUG 22 | -- | As of OpenSSL 1.0.0 this option has no effect. 23 | | SSL_OP_NETSCAPE_CHALLENGE_BUG 24 | -- | As of OpenSSL 0.9.8q and 1.0.0c, this option has no effect. 25 | | SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG 26 | -- | As of OpenSSL 1.0.1h and 1.0.2, this option has no effect. 27 | | SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG 28 | -- | As of OpenSSL 1.1.0 this option has no effect. 29 | | SSL_OP_MICROSOFT_BIG_SSLV3_BUFFER 30 | #if defined(SSL_OP_SAFARI_ECDHE_ECDSA_BUG) 31 | -- | Don't prefer ECDHE-ECDSA ciphers when the client appears to 32 | -- be Safari on OS X. OS X 10.8..10.8.3 has broken support for 33 | -- ECDHE-ECDSA ciphers. 34 | | SSL_OP_SAFARI_ECDHE_ECDSA_BUG 35 | #endif 36 | -- | As of OpenSSL 1.1.0 this option has no effect. 37 | | SSL_OP_SSLEAY_080_CLIENT_DH_BUG 38 | -- | As of OpenSSL 1.1.0 this option has no effect. 39 | | SSL_OP_TLS_D5_BUG 40 | -- | As of OpenSSL 1.1.0 this option has no effect. 41 | | SSL_OP_TLS_BLOCK_PADDING_BUG 42 | #if defined(SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS) 43 | -- | Disables a countermeasure against a SSL 3.0/TLS 1.0 44 | -- protocol vulnerability affecting CBC ciphers, which cannot be 45 | -- handled by some broken SSL implementations. This option has 46 | -- no effect for connections using other ciphers. 47 | | SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS 48 | #endif 49 | #if defined(SSL_OP_TLSEXT_PADDING) 50 | -- | Adds a padding extension to ensure the ClientHello size is 51 | -- never between 256 and 511 bytes in length. This is needed as 52 | -- a workaround for some implementations. 53 | | SSL_OP_TLSEXT_PADDING 54 | #endif 55 | -- | Default set of options 56 | | SSL_OP_ALL 57 | #if defined(SSL_OP_TLS_ROLLBACK_BUG) 58 | -- | Disable version rollback attack detection. 59 | -- 60 | -- During the client key exchange, the client must send the same 61 | -- information about acceptable SSL/TLS protocol levels as 62 | -- during the first hello. Some clients violate this rule by 63 | -- adapting to the server's answer. (Example: the client sends a 64 | -- SSLv2 hello and accepts up to SSLv3.1=TLSv1, the server only 65 | -- understands up to SSLv3. In this case the client must still 66 | -- use the same SSLv3.1=TLSv1 announcement. Some clients step 67 | -- down to SSLv3 with respect to the server's answer and violate 68 | -- the version rollback protection.) 69 | | SSL_OP_TLS_ROLLBACK_BUG 70 | #endif 71 | -- | As of OpenSSL 1.1.0 this option has no effect. 72 | | SSL_OP_SINGLE_DH_USE 73 | -- | As of OpenSSL 1.0.1k and 1.0.2, this option has no effect. 74 | | SSL_OP_EPHEMERAL_RSA 75 | #if defined(SSL_OP_CIPHER_SERVER_PREFERENCE) 76 | -- | When choosing a cipher, use the server's preferences 77 | -- instead of the client preferences. When not set, the SSL 78 | -- server will always follow the clients preferences. When set, 79 | -- the SSLv3/TLSv1 server will choose following its own 80 | -- preferences. Because of the different protocol, for SSLv2 the 81 | -- server will send its list of preferences to the client and 82 | -- the client chooses. 83 | | SSL_OP_CIPHER_SERVER_PREFERENCE 84 | #endif 85 | -- | As of OpenSSL 1.0.1 this option has no effect. 86 | | SSL_OP_PKCS1_CHECK_1 87 | -- | As of OpenSSL 1.0.1 this option has no effect. 88 | | SSL_OP_PKCS1_CHECK_2 89 | -- | As of OpenSSL 1.1.0 this option has no effect. 90 | | SSL_OP_NETSCAPE_CA_DN_BUG 91 | -- | As of OpenSSL 1.1.0 this option has no effect. 92 | | SSL_OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG 93 | -- | As of OpenSSL 1.1.0 this option has no effect. 94 | | SSL_OP_NO_SSLv2 95 | -- | Do not use the SSLv3 protocol. 96 | -- As of OpenSSL 1.1.0, this option is deprecated 97 | | SSL_OP_NO_SSLv3 98 | -- | Do not use the TLSv1 protocol. 99 | -- As of OpenSSL 1.1.0, this option is deprecated 100 | | SSL_OP_NO_TLSv1 101 | -- | Do not use the TLSv1.1 protocol. 102 | -- As of OpenSSL 1.1.0, this option is deprecated 103 | | SSL_OP_NO_TLSv1_1 104 | -- | Do not use the TLSv1.2 protocol. 105 | -- As of OpenSSL 1.1.0, this option is deprecated 106 | | SSL_OP_NO_TLSv1_2 107 | -- | Do not use the TLSv1.3 protocol. 108 | -- As of OpenSSL 1.1.0, this option is deprecated 109 | | SSL_OP_NO_TLSv1_3 110 | -- | Do not use the DTLSv1 protocol. 111 | -- As of OpenSSL 1.1.0, this option is deprecated 112 | | SSL_OP_NO_DTLSv1 113 | -- | Do not use the DTLSv1.2 protocol. 114 | -- As of OpenSSL 1.1.0, this option is deprecated 115 | | SSL_OP_NO_DTLSv1_2 116 | #if defined(SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION) 117 | -- | When performing renegotiation as a server, always start a 118 | -- new session (i.e., session resumption requests are only 119 | -- accepted in the initial handshake). This option is not needed 120 | -- for clients. 121 | | SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION 122 | #endif 123 | -- | Normally clients and servers will, where possible, 124 | -- transparently make use of 125 | -- tickets for 126 | -- stateless session resumption. 127 | -- 128 | -- If this option is set this functionality is disabled and 129 | -- tickets will not be used by clients or servers. 130 | | SSL_OP_NO_TICKET 131 | #if defined(SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION) 132 | -- | Allow legacy insecure renegotiation between OpenSSL and 133 | -- unpatched clients or servers. See 134 | -- 135 | -- for more details. 136 | | SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION 137 | #endif 138 | #if defined(SSL_OP_LEGACY_SERVER_CONNECT) 139 | -- | Allow legacy insecure renegotiation between OpenSSL and 140 | -- unpatched servers _only_. See 141 | -- 142 | -- for more details. 143 | | SSL_OP_LEGACY_SERVER_CONNECT 144 | #endif 145 | #if defined(SSL_OP_NO_EXTENDED_MASTER_SECRET) 146 | -- | Disable Extended master secret. 147 | -- Only available on OpenSSL 3.0.0 and later. 148 | | SSL_OP_NO_EXTENDED_MASTER_SECRET 149 | #endif 150 | #if defined(SSL_OP_CLEANSE_PLAINTEXT) 151 | -- | Cleanse plaintext copies of data. 152 | -- Only available on OpenSSL 3.0.0 and later. 153 | | SSL_OP_CLEANSE_PLAINTEXT 154 | #endif 155 | #if defined(SSL_OP_ENABLE_KTLS) 156 | -- | Enble support for Kernel TLS 157 | -- Only available on OpenSSL 3.0.0 and later 158 | | SSL_OP_ENABLE_KTLS 159 | #endif 160 | #if defined(SSL_OP_IGNORE_UNEXPECTED_EOF) 161 | | SSL_OP_IGNORE_UNEXPECTED_EOF 162 | #endif 163 | #if defined(SSL_OP_ALLOW_CLIENT_RENEGOTIATION) 164 | | SSL_OP_ALLOW_CLIENT_RENEGOTIATION 165 | #endif 166 | #if defined(SSL_OP_DISABLE_TLSEXT_CA_NAMES) 167 | | SSL_OP_DISABLE_TLSEXT_CA_NAMES 168 | #endif 169 | | SSL_OP_CISCO_ANYCONNECT 170 | | SSL_OP_NO_ANTI_REPLAY 171 | | SSL_OP_PRIORITIZE_CHACHA 172 | | SSL_OP_ALLOW_NO_DHE_KEX 173 | | SSL_OP_NO_ENCRYPT_THEN_MAC 174 | | SSL_OP_NO_QUERY_MTU 175 | | SSL_OP_COOKIE_EXCHANGE 176 | | SSL_OP_NO_COMPRESSION 177 | | SSL_OP_ENABLE_MIDDLEBOX_COMPAT 178 | | SSL_OP_NO_RENEGOTIATION 179 | | SSL_OP_CRYPTOPRO_TLSEXT_BUG 180 | deriving (Eq, Ord, Show, Typeable) 181 | 182 | optionToIntegral :: Integral a => SSLOption -> a 183 | optionToIntegral SSL_OP_MICROSOFT_SESS_ID_BUG = #const SSL_OP_MICROSOFT_SESS_ID_BUG 184 | optionToIntegral SSL_OP_NETSCAPE_CHALLENGE_BUG = #const SSL_OP_NETSCAPE_CHALLENGE_BUG 185 | optionToIntegral SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG = #const SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG 186 | optionToIntegral SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG = #const SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG 187 | optionToIntegral SSL_OP_MICROSOFT_BIG_SSLV3_BUFFER = #const SSL_OP_MICROSOFT_BIG_SSLV3_BUFFER 188 | #if defined(SSL_OP_SAFARI_ECDHE_ECDSA_BUG) 189 | optionToIntegral SSL_OP_SAFARI_ECDHE_ECDSA_BUG = #const SSL_OP_SAFARI_ECDHE_ECDSA_BUG 190 | #endif 191 | optionToIntegral SSL_OP_SSLEAY_080_CLIENT_DH_BUG = #const SSL_OP_SSLEAY_080_CLIENT_DH_BUG 192 | optionToIntegral SSL_OP_TLS_D5_BUG = #const SSL_OP_TLS_D5_BUG 193 | optionToIntegral SSL_OP_TLS_BLOCK_PADDING_BUG = #const SSL_OP_TLS_BLOCK_PADDING_BUG 194 | #if defined(SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS) 195 | optionToIntegral SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS = #const SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS 196 | #endif 197 | #if defined(SSL_OP_TLSEXT_PADDING) 198 | optionToIntegral SSL_OP_TLSEXT_PADDING = #const SSL_OP_TLSEXT_PADDING 199 | #endif 200 | optionToIntegral SSL_OP_ALL = #const SSL_OP_ALL 201 | #if defined(SSL_OP_TLS_ROLLBACK_BUG) 202 | optionToIntegral SSL_OP_TLS_ROLLBACK_BUG = #const SSL_OP_TLS_ROLLBACK_BUG 203 | #endif 204 | optionToIntegral SSL_OP_SINGLE_DH_USE = #const SSL_OP_SINGLE_DH_USE 205 | optionToIntegral SSL_OP_EPHEMERAL_RSA = #const SSL_OP_EPHEMERAL_RSA 206 | #if defined(SSL_OP_CIPHER_SERVER_PREFERENCE) 207 | optionToIntegral SSL_OP_CIPHER_SERVER_PREFERENCE = #const SSL_OP_CIPHER_SERVER_PREFERENCE 208 | #endif 209 | optionToIntegral SSL_OP_PKCS1_CHECK_1 = #const SSL_OP_PKCS1_CHECK_1 210 | optionToIntegral SSL_OP_PKCS1_CHECK_2 = #const SSL_OP_PKCS1_CHECK_2 211 | optionToIntegral SSL_OP_NETSCAPE_CA_DN_BUG = #const SSL_OP_NETSCAPE_CA_DN_BUG 212 | optionToIntegral SSL_OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG = #const SSL_OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG 213 | optionToIntegral SSL_OP_NO_SSLv2 = #const SSL_OP_NO_SSLv2 214 | optionToIntegral SSL_OP_NO_SSLv3 = #const SSL_OP_NO_SSLv3 215 | optionToIntegral SSL_OP_NO_TLSv1 = #const SSL_OP_NO_TLSv1 216 | optionToIntegral SSL_OP_NO_TLSv1_1 = #const SSL_OP_NO_TLSv1_1 217 | optionToIntegral SSL_OP_NO_TLSv1_2 = #const SSL_OP_NO_TLSv1_2 218 | #if defined(SSL_OP_NO_TLSv1_3) 219 | optionToIntegral SSL_OP_NO_TLSv1_3 = #const SSL_OP_NO_TLSv1_3 220 | #endif 221 | #if defined(SSL_OP_NO_DTLSv1) 222 | optionToIntegral SSL_OP_NO_DTLSv1 = #const SSL_OP_NO_DTLSv1 223 | #endif 224 | #if defined(SSL_OP_NO_DTLSv1_2) 225 | optionToIntegral SSL_OP_NO_DTLSv1_2 = #const SSL_OP_NO_DTLSv1_2 226 | #endif 227 | #if defined(SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION) 228 | optionToIntegral SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION = #const SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION 229 | #endif 230 | optionToIntegral SSL_OP_NO_TICKET = #const SSL_OP_NO_TICKET 231 | #if defined(SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION) 232 | optionToIntegral SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION = #const SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION 233 | #endif 234 | #if defined(SSL_OP_LEGACY_SERVER_CONNECT) 235 | optionToIntegral SSL_OP_LEGACY_SERVER_CONNECT = #const SSL_OP_LEGACY_SERVER_CONNECT 236 | #endif 237 | #if defined(SSL_OP_NO_EXTENDED_MASTER_SECRET) 238 | optionToIntegral SSL_OP_NO_EXTENDED_MASTER_SECRET = #const SSL_OP_NO_EXTENDED_MASTER_SECRET 239 | #endif 240 | #if defined(SSL_OP_CLEANSE_PLAINTEXT) 241 | optionToIntegral SSL_OP_CLEANSE_PLAINTEXT = #const SSL_OP_CLEANSE_PLAINTEXT 242 | #endif 243 | #if defined(SSL_OP_ENABLE_KTLS) 244 | optionToIntegral SSL_OP_ENABLE_KTLS = #const SSL_OP_ENABLE_KTLS 245 | #endif 246 | #if defined(SSL_OP_IGNORE_UNEXPECTED_EOF) 247 | optionToIntegral SSL_OP_IGNORE_UNEXPECTED_EOF = #const SSL_OP_IGNORE_UNEXPECTED_EOF 248 | #endif 249 | #if defined(SSL_OP_ALLOW_CLIENT_RENEGOTIATION) 250 | optionToIntegral SSL_OP_ALLOW_CLIENT_RENEGOTIATION = #const SSL_OP_ALLOW_CLIENT_RENEGOTIATION 251 | #endif 252 | #if defined(SSL_OP_DISABLE_TLSEXT_CA_NAMES) 253 | optionToIntegral SSL_OP_DISABLE_TLSEXT_CA_NAMES = #const SSL_OP_DISABLE_TLSEXT_CA_NAMES 254 | #endif 255 | optionToIntegral SSL_OP_NO_ANTI_REPLAY = #const SSL_OP_NO_ANTI_REPLAY 256 | optionToIntegral SSL_OP_PRIORITIZE_CHACHA = #const SSL_OP_PRIORITIZE_CHACHA 257 | optionToIntegral SSL_OP_ENABLE_MIDDLEBOX_COMPAT = #const SSL_OP_ENABLE_MIDDLEBOX_COMPAT 258 | optionToIntegral SSL_OP_NO_ENCRYPT_THEN_MAC = #const SSL_OP_NO_ENCRYPT_THEN_MAC 259 | optionToIntegral SSL_OP_ALLOW_NO_DHE_KEX = #const SSL_OP_ALLOW_NO_DHE_KEX 260 | optionToIntegral SSL_OP_NO_QUERY_MTU = #const SSL_OP_NO_QUERY_MTU 261 | optionToIntegral SSL_OP_COOKIE_EXCHANGE = #const SSL_OP_COOKIE_EXCHANGE 262 | optionToIntegral SSL_OP_NO_COMPRESSION = #const SSL_OP_NO_COMPRESSION 263 | optionToIntegral SSL_OP_NO_RENEGOTIATION = #const SSL_OP_NO_RENEGOTIATION 264 | optionToIntegral SSL_OP_CRYPTOPRO_TLSEXT_BUG = #const SSL_OP_CRYPTOPRO_TLSEXT_BUG 265 | optionToIntegral SSL_OP_CISCO_ANYCONNECT = #const SSL_OP_CISCO_ANYCONNECT -------------------------------------------------------------------------------- /OpenSSL/Stack.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | module OpenSSL.Stack 5 | ( STACK 6 | , mapStack 7 | , withStack 8 | , withForeignStack 9 | ) 10 | where 11 | #include "HsOpenSSL.h" 12 | import Control.Exception 13 | import Foreign 14 | import Foreign.C 15 | 16 | 17 | data STACK 18 | 19 | 20 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 21 | foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_new_null" 22 | skNewNull :: IO (Ptr STACK) 23 | 24 | foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_free" 25 | skFree :: Ptr STACK -> IO () 26 | 27 | foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_push" 28 | skPush :: Ptr STACK -> Ptr () -> IO () 29 | 30 | foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_num" 31 | skNum :: Ptr STACK -> IO CInt 32 | 33 | foreign import capi unsafe "openssl/safestack.h OPENSSL_sk_value" 34 | skValue :: Ptr STACK -> CInt -> IO (Ptr ()) 35 | #else 36 | foreign import capi unsafe "openssl/safestack.h sk_new_null" 37 | skNewNull :: IO (Ptr STACK) 38 | 39 | foreign import capi unsafe "openssl/safestack.h sk_free" 40 | skFree :: Ptr STACK -> IO () 41 | 42 | foreign import capi unsafe "openssl/safestack.h sk_push" 43 | skPush :: Ptr STACK -> Ptr () -> IO () 44 | 45 | foreign import capi unsafe "openssl/safestack.h sk_num" 46 | skNum :: Ptr STACK -> IO CInt 47 | 48 | foreign import capi unsafe "openssl/safestack.h sk_value" 49 | skValue :: Ptr STACK -> CInt -> IO (Ptr ()) 50 | #endif 51 | 52 | mapStack :: (Ptr a -> IO b) -> Ptr STACK -> IO [b] 53 | mapStack m st 54 | = do num <- skNum st 55 | mapM (\ i -> fmap castPtr (skValue st i) >>= m) 56 | $ take (fromIntegral num) [0..] 57 | 58 | 59 | newStack :: [Ptr a] -> IO (Ptr STACK) 60 | newStack values 61 | = do st <- skNewNull 62 | mapM_ (skPush st . castPtr) values 63 | return st 64 | 65 | 66 | withStack :: [Ptr a] -> (Ptr STACK -> IO b) -> IO b 67 | withStack values 68 | = bracket (newStack values) skFree 69 | 70 | 71 | withForeignStack :: (fp -> Ptr obj) 72 | -> (fp -> IO ()) 73 | -> [fp] 74 | -> (Ptr STACK -> IO ret) 75 | -> IO ret 76 | withForeignStack unsafeFpToPtr touchFp fps action 77 | = do ret <- withStack (map unsafeFpToPtr fps) action 78 | mapM_ touchFp fps 79 | return ret 80 | -------------------------------------------------------------------------------- /OpenSSL/Utils.hs: -------------------------------------------------------------------------------- 1 | module OpenSSL.Utils 2 | ( failIfNull 3 | , failIfNull_ 4 | , failIf 5 | , failIf_ 6 | , raiseOpenSSLError 7 | , clearErrorStack 8 | , toHex 9 | , fromHex 10 | , peekCStringCLen 11 | ) 12 | where 13 | import Control.Monad 14 | import Foreign.C.String 15 | import Foreign.C.Types 16 | import Foreign.Ptr 17 | import OpenSSL.ERR 18 | import Data.Bits 19 | import Data.List 20 | 21 | failIfNull :: Ptr a -> IO (Ptr a) 22 | failIfNull ptr 23 | = if ptr == nullPtr then 24 | raiseOpenSSLError 25 | else 26 | return ptr 27 | 28 | failIfNull_ :: Ptr a -> IO () 29 | failIfNull_ ptr 30 | = failIfNull ptr >> return () 31 | 32 | failIf :: (a -> Bool) -> a -> IO a 33 | failIf f a 34 | | f a = raiseOpenSSLError 35 | | otherwise = return a 36 | 37 | 38 | failIf_ :: (a -> Bool) -> a -> IO () 39 | failIf_ f a 40 | = failIf f a >> return () 41 | 42 | 43 | raiseOpenSSLError :: IO a 44 | raiseOpenSSLError = getError >>= errorString >>= fail 45 | 46 | 47 | clearErrorStack :: IO () 48 | clearErrorStack = do 49 | e <- getError 50 | when (e /= 0) clearErrorStack 51 | 52 | -- | Convert an integer to a hex string 53 | toHex :: (Num i, Bits i) => i -> String 54 | toHex = reverse . map hexByte . unfoldr step where 55 | step 0 = Nothing 56 | step i = Just (i .&. 0xf, i `shiftR` 4) 57 | 58 | hexByte 0 = '0' 59 | hexByte 1 = '1' 60 | hexByte 2 = '2' 61 | hexByte 3 = '3' 62 | hexByte 4 = '4' 63 | hexByte 5 = '5' 64 | hexByte 6 = '6' 65 | hexByte 7 = '7' 66 | hexByte 8 = '8' 67 | hexByte 9 = '9' 68 | hexByte 10 = 'a' 69 | hexByte 11 = 'b' 70 | hexByte 12 = 'c' 71 | hexByte 13 = 'd' 72 | hexByte 14 = 'e' 73 | hexByte 15 = 'f' 74 | hexByte _ = undefined 75 | 76 | -- | Convert a hex string to an integer 77 | fromHex :: (Num i, Bits i) => String -> i 78 | fromHex = foldl step 0 where 79 | step acc hexchar = (acc `shiftL` 4) .|. byteHex hexchar 80 | 81 | byteHex '0' = 0 82 | byteHex '1' = 1 83 | byteHex '2' = 2 84 | byteHex '3' = 3 85 | byteHex '4' = 4 86 | byteHex '5' = 5 87 | byteHex '6' = 6 88 | byteHex '7' = 7 89 | byteHex '8' = 8 90 | byteHex '9' = 9 91 | byteHex 'a' = 10 92 | byteHex 'b' = 11 93 | byteHex 'c' = 12 94 | byteHex 'd' = 13 95 | byteHex 'e' = 14 96 | byteHex 'f' = 15 97 | byteHex 'A' = 10 98 | byteHex 'B' = 11 99 | byteHex 'C' = 12 100 | byteHex 'D' = 13 101 | byteHex 'E' = 14 102 | byteHex 'F' = 15 103 | byteHex _ = undefined 104 | 105 | peekCStringCLen :: (Ptr CChar, CInt) -> IO String 106 | peekCStringCLen (p, n) 107 | = peekCStringLen (p, fromIntegral n) 108 | -------------------------------------------------------------------------------- /OpenSSL/X509/Name.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | module OpenSSL.X509.Name 5 | ( X509_NAME 6 | 7 | , allocaX509Name 8 | , withX509Name 9 | , peekX509Name 10 | ) 11 | where 12 | #include "HsOpenSSL.h" 13 | import Control.Exception 14 | import Foreign 15 | import Foreign.C 16 | import OpenSSL.ASN1 17 | import OpenSSL.Utils 18 | 19 | data {-# CTYPE "openssl/x509.h" "X509_NAME" #-} X509_NAME 20 | data {-# CTYPE "openssl/x509.h" "X509_NAME_ENTRY" #-} X509_NAME_ENTRY 21 | 22 | foreign import capi unsafe "openssl/x509.h X509_NAME_new" 23 | _new :: IO (Ptr X509_NAME) 24 | 25 | foreign import capi unsafe "openssl/x509.h X509_NAME_free" 26 | _free :: Ptr X509_NAME -> IO () 27 | 28 | foreign import capi unsafe "openssl/x509.h X509_NAME_add_entry_by_txt" 29 | _add_entry_by_txt :: Ptr X509_NAME -> CString -> CInt -> Ptr CChar -> CInt -> CInt -> CInt -> IO CInt 30 | 31 | foreign import capi unsafe "openssl/x509.h X509_NAME_entry_count" 32 | _entry_count :: Ptr X509_NAME -> IO CInt 33 | 34 | foreign import capi unsafe "openssl/x509.h X509_NAME_get_entry" 35 | _get_entry :: Ptr X509_NAME -> CInt -> IO (Ptr X509_NAME_ENTRY) 36 | 37 | foreign import capi unsafe "openssl/x509.h X509_NAME_ENTRY_get_object" 38 | _ENTRY_get_object :: Ptr X509_NAME_ENTRY -> IO (Ptr ASN1_OBJECT) 39 | 40 | foreign import capi unsafe "openssl/x509.h X509_NAME_ENTRY_get_data" 41 | _ENTRY_get_data :: Ptr X509_NAME_ENTRY -> IO (Ptr ASN1_STRING) 42 | 43 | 44 | allocaX509Name :: (Ptr X509_NAME -> IO a) -> IO a 45 | allocaX509Name = bracket _new _free 46 | 47 | 48 | withX509Name :: [(String, String)] -> (Ptr X509_NAME -> IO a) -> IO a 49 | withX509Name name m 50 | = allocaX509Name $ \ namePtr -> 51 | do mapM_ (addEntry namePtr) name 52 | m namePtr 53 | where 54 | addEntry :: Ptr X509_NAME -> (String, String) -> IO () 55 | addEntry namePtr (key, val) 56 | = withCString key $ \ keyPtr -> 57 | withCStringLen val $ \ (valPtr, valLen) -> 58 | _add_entry_by_txt namePtr keyPtr (#const MBSTRING_UTF8) valPtr (fromIntegral valLen) (-1) 0 59 | >>= failIf (/= 1) 60 | >> return () 61 | 62 | 63 | peekX509Name :: Ptr X509_NAME -> Bool -> IO [(String, String)] 64 | peekX509Name namePtr wantLongName 65 | = do count <- return . fromIntegral =<< failIf (< 0) =<< _entry_count namePtr 66 | mapM peekEntry [0..count - 1] 67 | where 68 | peekEntry :: Int -> IO (String, String) 69 | peekEntry n 70 | = do ent <- _get_entry namePtr (fromIntegral n) >>= failIfNull 71 | obj <- _ENTRY_get_object ent >>= failIfNull 72 | dat <- _ENTRY_get_data ent >>= failIfNull 73 | 74 | nid <- obj2nid obj 75 | key <- if wantLongName then 76 | nid2ln nid 77 | else 78 | nid2sn nid 79 | val <- peekASN1String dat 80 | 81 | return (key, val) 82 | -------------------------------------------------------------------------------- /OpenSSL/X509/Request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | {-# OPTIONS_HADDOCK prune #-} 5 | -- |An interface to PKCS#10 certificate request. 6 | module OpenSSL.X509.Request 7 | ( -- * Type 8 | X509Req 9 | , X509_REQ -- private 10 | 11 | -- * Functions to manipulate request 12 | , newX509Req 13 | , wrapX509Req -- private 14 | , withX509ReqPtr -- private 15 | 16 | , signX509Req 17 | , verifyX509Req 18 | 19 | , printX509Req 20 | , writeX509ReqDER 21 | 22 | , makeX509FromReq 23 | 24 | -- * Accessors 25 | , getVersion 26 | , setVersion 27 | 28 | , getSubjectName 29 | , setSubjectName 30 | 31 | , getPublicKey 32 | , setPublicKey 33 | 34 | , addExtensions 35 | , addExtensionToX509 36 | ) 37 | where 38 | 39 | import Control.Monad 40 | import Data.Maybe 41 | import Foreign 42 | import Foreign.C 43 | import OpenSSL.BIO 44 | import OpenSSL.EVP.Digest hiding (digest) 45 | import OpenSSL.EVP.PKey 46 | import OpenSSL.EVP.Verify 47 | import OpenSSL.EVP.Internal 48 | import OpenSSL.Utils 49 | import OpenSSL.X509 (X509) 50 | import qualified OpenSSL.X509 as Cert 51 | import OpenSSL.X509.Name 52 | import Data.ByteString.Lazy (ByteString) 53 | import OpenSSL.Stack 54 | 55 | -- |@'X509Req'@ is an opaque object that represents PKCS#10 56 | -- certificate request. 57 | newtype X509Req = X509Req (ForeignPtr X509_REQ) 58 | data {-# CTYPE "openssl/x509.h" "X509_REQ" #-} X509_REQ 59 | 60 | data X509_EXT 61 | 62 | foreign import capi unsafe "openssl/x509.h X509_REQ_new" 63 | _new :: IO (Ptr X509_REQ) 64 | 65 | foreign import capi unsafe "openssl/x509.h &X509_REQ_free" 66 | _free :: FunPtr (Ptr X509_REQ -> IO ()) 67 | 68 | foreign import capi unsafe "openssl/x509.h X509_REQ_sign" 69 | _sign :: Ptr X509_REQ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt 70 | 71 | foreign import capi unsafe "openssl/x509.h X509_REQ_verify" 72 | _verify :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt 73 | 74 | foreign import capi unsafe "openssl/x509.h X509_REQ_print" 75 | _print :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt 76 | 77 | foreign import capi unsafe "openssl/x509.h i2d_X509_REQ_bio" 78 | _req_to_der :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt 79 | 80 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_REQ_get_version" 81 | _get_version :: Ptr X509_REQ -> IO CLong 82 | 83 | foreign import capi unsafe "openssl/x509.h X509_REQ_set_version" 84 | _set_version :: Ptr X509_REQ -> CLong -> IO CInt 85 | 86 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_REQ_get_subject_name" 87 | _get_subject_name :: Ptr X509_REQ -> IO (Ptr X509_NAME) 88 | 89 | foreign import capi unsafe "openssl/x509.h X509_REQ_set_subject_name" 90 | _set_subject_name :: Ptr X509_REQ -> Ptr X509_NAME -> IO CInt 91 | 92 | foreign import capi unsafe "openssl/x509.h X509_REQ_get_pubkey" 93 | _get_pubkey :: Ptr X509_REQ -> IO (Ptr EVP_PKEY) 94 | 95 | foreign import capi unsafe "openssl/x509.h X509_REQ_set_pubkey" 96 | _set_pubkey :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt 97 | 98 | foreign import capi unsafe "openssl/x509v3.h X509V3_EXT_nconf_nid" 99 | _ext_create :: Ptr a -> Ptr b -> CInt -> CString -> IO (Ptr X509_EXT) 100 | 101 | foreign import capi unsafe "openssl/x509.h X509_REQ_add_extensions" 102 | _req_add_extensions :: Ptr X509_REQ -> Ptr STACK -> IO CInt 103 | 104 | foreign import capi unsafe "openssl/x509.h X509_add_ext" 105 | _X509_add_ext :: Ptr Cert.X509_ -> Ptr X509_EXT -> CInt -> IO CInt 106 | 107 | -- |@'newX509Req'@ creates an empty certificate request. You must set 108 | -- the following properties to and sign it (see 'signX509Req') to 109 | -- actually use the certificate request. 110 | -- 111 | -- [/Version/] See 'setVersion'. 112 | -- 113 | -- [/Subject Name/] See 'setSubjectName'. 114 | -- 115 | -- [/Public Key/] See 'setPublicKey'. 116 | -- 117 | newX509Req :: IO X509Req 118 | newX509Req = _new >>= wrapX509Req 119 | 120 | 121 | wrapX509Req :: Ptr X509_REQ -> IO X509Req 122 | wrapX509Req = fmap X509Req . newForeignPtr _free 123 | 124 | 125 | withX509ReqPtr :: X509Req -> (Ptr X509_REQ -> IO a) -> IO a 126 | withX509ReqPtr (X509Req req) = withForeignPtr req 127 | 128 | -- |@'signX509Req'@ signs a certificate request with a subject private 129 | -- key. 130 | signX509Req :: KeyPair key => 131 | X509Req -- ^ The request to be signed. 132 | -> key -- ^ The private key to sign with. 133 | -> Maybe Digest -- ^ A hashing algorithm to use. If 134 | -- @Nothing@ the most suitable algorithm 135 | -- for the key is automatically used. 136 | -> IO () 137 | signX509Req req pkey mDigest 138 | = withX509ReqPtr req $ \ reqPtr -> 139 | withPKeyPtr' pkey $ \ pkeyPtr -> 140 | do digest <- case mDigest of 141 | Just md -> return md 142 | Nothing -> pkeyDefaultMD pkey 143 | withMDPtr digest $ \ digestPtr -> 144 | _sign reqPtr pkeyPtr digestPtr 145 | >>= failIf_ (== 0) 146 | 147 | -- |@'verifyX509Req'@ verifies a signature of certificate request with 148 | -- a subject public key. 149 | verifyX509Req :: PublicKey key => 150 | X509Req -- ^ The request to be verified. 151 | -> key -- ^ The public key to verify with. 152 | -> IO VerifyStatus 153 | verifyX509Req req pkey 154 | = withX509ReqPtr req $ \ reqPtr -> 155 | withPKeyPtr' pkey $ \ pkeyPtr -> 156 | _verify reqPtr pkeyPtr 157 | >>= interpret 158 | where 159 | interpret :: CInt -> IO VerifyStatus 160 | interpret 1 = return VerifySuccess 161 | interpret 0 = return VerifyFailure 162 | interpret _ = raiseOpenSSLError 163 | 164 | -- |@'printX509Req' req@ translates a certificate request into 165 | -- human-readable format. 166 | printX509Req :: X509Req -> IO String 167 | printX509Req req 168 | = do mem <- newMem 169 | withBioPtr mem $ \ memPtr -> 170 | withX509ReqPtr req $ \ reqPtr -> 171 | _print memPtr reqPtr 172 | >>= failIf_ (/= 1) 173 | bioRead mem 174 | 175 | {- DER encoding ------------------------------------------------------------- -} 176 | 177 | -- |@'writeX509ReqDER' req@ writes a PKCS#10 certificate request to DER string. 178 | writeX509ReqDER :: X509Req -> IO ByteString 179 | writeX509ReqDER req 180 | = do mem <- newMem 181 | withBioPtr mem $ \ memPtr -> 182 | withX509ReqPtr req $ \ reqPtr -> 183 | _req_to_der memPtr reqPtr 184 | >>= failIf_ (< 0) 185 | bioReadLBS mem 186 | 187 | 188 | -- |@'getVersion' req@ returns the version number of certificate 189 | -- request. 190 | getVersion :: X509Req -> IO Int 191 | getVersion req 192 | = withX509ReqPtr req $ \ reqPtr -> 193 | liftM fromIntegral $ _get_version reqPtr 194 | 195 | -- |@'setVersion' req ver@ updates the version number of certificate 196 | -- request. 197 | setVersion :: X509Req -> Int -> IO () 198 | setVersion req ver 199 | = withX509ReqPtr req $ \ reqPtr -> 200 | _set_version reqPtr (fromIntegral ver) 201 | >>= failIf (/= 1) 202 | >> return () 203 | 204 | -- |@'getSubjectName' req wantLongName@ returns the subject name of 205 | -- certificate request. See 'OpenSSL.X509.getSubjectName' of 206 | -- "OpenSSL.X509". 207 | getSubjectName :: X509Req -> Bool -> IO [(String, String)] 208 | getSubjectName req wantLongName 209 | = withX509ReqPtr req $ \ reqPtr -> 210 | do namePtr <- _get_subject_name reqPtr 211 | peekX509Name namePtr wantLongName 212 | 213 | -- |@'setSubjectName' req name@ updates the subject name of 214 | -- certificate request. See 'OpenSSL.X509.setSubjectName' of 215 | -- "OpenSSL.X509". 216 | setSubjectName :: X509Req -> [(String, String)] -> IO () 217 | setSubjectName req subject 218 | = withX509ReqPtr req $ \ reqPtr -> 219 | withX509Name subject $ \ namePtr -> 220 | _set_subject_name reqPtr namePtr 221 | >>= failIf (/= 1) 222 | >> return () 223 | 224 | -- |@'getPublicKey' req@ returns the public key of the subject of 225 | -- certificate request. 226 | getPublicKey :: X509Req -> IO SomePublicKey 227 | getPublicKey req 228 | = withX509ReqPtr req $ \ reqPtr -> 229 | fmap fromJust 230 | ( _get_pubkey reqPtr 231 | >>= failIfNull 232 | >>= wrapPKeyPtr 233 | >>= fromPKey 234 | ) 235 | 236 | -- |@'setPublicKey' req@ updates the public key of the subject of 237 | -- certificate request. 238 | setPublicKey :: PublicKey key => X509Req -> key -> IO () 239 | setPublicKey req pkey 240 | = withX509ReqPtr req $ \ reqPtr -> 241 | withPKeyPtr' pkey $ \ pkeyPtr -> 242 | _set_pubkey reqPtr pkeyPtr 243 | >>= failIf (/= 1) 244 | >> return () 245 | 246 | 247 | -- |@'addExtensions' req [(nid, str)]@ 248 | -- 249 | -- E.g., nid 85 = 'subjectAltName' http://osxr.org:8080/openssl/source/crypto/objects/objects.h#0476 250 | -- 251 | -- (TODO: more docs; NID type) 252 | addExtensions :: X509Req -> [(Int, String)] -> IO CInt 253 | addExtensions req exts = 254 | withX509ReqPtr req $ \reqPtr -> do 255 | extPtrs <- forM exts make 256 | withStack extPtrs $ _req_add_extensions reqPtr 257 | 258 | where 259 | make (nid, str) = withCString str $ _ext_create nullPtr nullPtr (fromIntegral nid) 260 | 261 | 262 | -- |@'makeX509FromReq' req cert@ creates an empty X.509 certificate 263 | -- and copies as much data from the request as possible. The resulting 264 | -- certificate doesn't have the following data and it isn't signed so 265 | -- you must fill them and sign it yourself. 266 | -- 267 | -- * Serial number 268 | -- 269 | -- * Validity (Not Before and Not After) 270 | -- 271 | -- Example: 272 | -- 273 | -- > import Data.Time.Clock 274 | -- > 275 | -- > genCert :: X509 -> EvpPKey -> Integer -> Int -> X509Req -> IO X509 276 | -- > genCert caCert caKey serial days req 277 | -- > = do cert <- makeX509FromReq req caCert 278 | -- > now <- getCurrentTime 279 | -- > setSerialNumber cert serial 280 | -- > setNotBefore cert $ addUTCTime (-1) now 281 | -- > setNotAfter cert $ addUTCTime (days * 24 * 60 * 60) now 282 | -- > signX509 cert caKey Nothing 283 | -- > return cert 284 | -- 285 | makeX509FromReq :: X509Req 286 | -> X509 287 | -> IO X509 288 | makeX509FromReq req caCert 289 | = do reqPubKey <- getPublicKey req 290 | verified <- verifyX509Req req reqPubKey 291 | 292 | when (verified == VerifyFailure) 293 | $ fail "makeX509FromReq: the request isn't properly signed by its own key." 294 | 295 | cert <- Cert.newX509 296 | Cert.setVersion cert 2 -- Version 2 means X509 v3. It's confusing. 297 | Cert.setIssuerName cert =<< Cert.getSubjectName caCert False 298 | Cert.setSubjectName cert =<< getSubjectName req False 299 | Cert.setPublicKey cert =<< getPublicKey req 300 | 301 | return cert 302 | 303 | -- | Add Extensions to a certificate (when the Server accepting certs requires it) 304 | -- E.g.: 305 | -- 306 | -- > addExtensionToX509 cert1 87 "CA:FALSE" 307 | -- > addExtensionToX509 cert1 85 "critical,serverAuth, clientAuth" -- when this extension field is critical 308 | -- 309 | addExtensionToX509 :: X509 -> Int -> String -> IO Bool 310 | addExtensionToX509 (Cert.X509 certFPtr) nid value = do 311 | -- Context and config pointers are set to nullPtr for simplicity. 312 | -- Depending on your use case, you might need to provide actual values. 313 | result <- withForeignPtr certFPtr $ \certPtr -> 314 | withCString value $ \cValue -> do 315 | extPtr <- _ext_create nullPtr nullPtr (fromIntegral nid) cValue 316 | if extPtr /= nullPtr 317 | then do 318 | res <- _X509_add_ext certPtr extPtr (-1) -- Add to the end 319 | return (res == 0) 320 | else return False 321 | return result 322 | -------------------------------------------------------------------------------- /OpenSSL/X509/Revocation.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE ForeignFunctionInterface #-} 4 | {-# LANGUAGE CApiFFI #-} 5 | {-# OPTIONS_HADDOCK prune #-} 6 | -- |An interface to Certificate Revocation List. 7 | module OpenSSL.X509.Revocation 8 | ( -- * Types 9 | CRL 10 | , X509_CRL -- privae 11 | , RevokedCertificate(..) 12 | 13 | -- * Functions to manipulate revocation list 14 | , newCRL 15 | , wrapCRL -- private 16 | , withCRLPtr -- private 17 | 18 | , signCRL 19 | , verifyCRL 20 | 21 | , printCRL 22 | 23 | , sortCRL 24 | 25 | -- * Accessors 26 | , getVersion 27 | , setVersion 28 | 29 | , getLastUpdate 30 | , setLastUpdate 31 | 32 | , getNextUpdate 33 | , setNextUpdate 34 | 35 | , getIssuerName 36 | , setIssuerName 37 | 38 | , getRevokedList 39 | , addRevoked 40 | , getRevoked 41 | ) 42 | where 43 | #include "HsOpenSSL.h" 44 | import Control.Monad 45 | #if OPENSSL_VERSION_NUMBER < 0x10000000 46 | import Data.List 47 | #endif 48 | import Data.Time.Clock 49 | import Data.Typeable 50 | import Foreign 51 | import Foreign.C 52 | import OpenSSL.ASN1 53 | import OpenSSL.BIO 54 | import OpenSSL.EVP.Digest hiding (digest) 55 | import OpenSSL.EVP.PKey 56 | import OpenSSL.EVP.Verify 57 | import OpenSSL.EVP.Internal 58 | import OpenSSL.Stack 59 | import OpenSSL.Utils 60 | import OpenSSL.X509.Name 61 | 62 | -- |@'CRL'@ is an opaque object that represents Certificate Revocation 63 | -- List. 64 | newtype CRL = CRL (ForeignPtr X509_CRL) 65 | data {-# CTYPE "openssl/x509.h" "X509_CRL" #-} X509_CRL 66 | data {-# CTYPE "openssl/x509.h" "X509_REVOKED" #-} X509_REVOKED 67 | 68 | -- |@'RevokedCertificate'@ represents a revoked certificate in a 69 | -- list. Each certificates are supposed to be distinguishable by 70 | -- issuer name and serial number, so it is sufficient to have only 71 | -- serial number on each entries. 72 | data RevokedCertificate 73 | = RevokedCertificate { 74 | revSerialNumber :: Integer 75 | , revRevocationDate :: UTCTime 76 | } 77 | deriving (Show, Eq, Typeable) 78 | 79 | 80 | foreign import capi unsafe "openssl/x509.h X509_CRL_new" 81 | _new :: IO (Ptr X509_CRL) 82 | 83 | foreign import capi unsafe "openssl/x509.h &X509_CRL_free" 84 | _free :: FunPtr (Ptr X509_CRL -> IO ()) 85 | 86 | foreign import capi unsafe "openssl/x509.h X509_CRL_sign" 87 | _sign :: Ptr X509_CRL -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt 88 | 89 | foreign import capi unsafe "openssl/x509.h X509_CRL_verify" 90 | _verify :: Ptr X509_CRL -> Ptr EVP_PKEY -> IO CInt 91 | 92 | foreign import capi unsafe "openssl/x509.h X509_CRL_print" 93 | _print :: Ptr BIO_ -> Ptr X509_CRL -> IO CInt 94 | 95 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_version" 96 | _get_version :: Ptr X509_CRL -> IO CLong 97 | 98 | foreign import capi unsafe "openssl/x509.h X509_CRL_set_version" 99 | _set_version :: Ptr X509_CRL -> CLong -> IO CInt 100 | 101 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_lastUpdate" 102 | _get_lastUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME) 103 | 104 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_nextUpdate" 105 | _get_nextUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME) 106 | 107 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 108 | foreign import capi unsafe "openssl/x509.h X509_CRL_set1_lastUpdate" 109 | _set_lastUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt 110 | 111 | foreign import capi unsafe "openssl/x509.h X509_CRL_set1_nextUpdate" 112 | _set_nextUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt 113 | #else 114 | foreign import capi unsafe "openssl/x509.h X509_CRL_set_lastUpdate" 115 | _set_lastUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt 116 | 117 | foreign import capi unsafe "openssl/x509.h X509_CRL_set_nextUpdate" 118 | _set_nextUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO CInt 119 | #endif 120 | 121 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_issuer" 122 | _get_issuer_name :: Ptr X509_CRL -> IO (Ptr X509_NAME) 123 | 124 | foreign import capi unsafe "openssl/x509.h X509_CRL_set_issuer_name" 125 | _set_issuer_name :: Ptr X509_CRL -> Ptr X509_NAME -> IO CInt 126 | 127 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_get_REVOKED" 128 | _get_REVOKED :: Ptr X509_CRL -> IO (Ptr STACK) 129 | 130 | foreign import capi unsafe "openssl/x509.h X509_CRL_add0_revoked" 131 | _add0_revoked :: Ptr X509_CRL -> Ptr X509_REVOKED -> IO CInt 132 | 133 | #if OPENSSL_VERSION_NUMBER >= 0x10000000 134 | -- This function is only available on OpenSSL 1.0.0 or later. 135 | foreign import capi unsafe "openssl/x509.h X509_CRL_get0_by_serial" 136 | _get0_by_serial :: Ptr X509_CRL -> Ptr (Ptr X509_REVOKED) 137 | -> Ptr ASN1_INTEGER -> IO CInt 138 | #endif 139 | 140 | foreign import capi unsafe "openssl/x509.h X509_CRL_sort" 141 | _sort :: Ptr X509_CRL -> IO CInt 142 | 143 | 144 | 145 | foreign import capi unsafe "openssl/x509.h X509_REVOKED_new" 146 | _new_revoked :: IO (Ptr X509_REVOKED) 147 | 148 | foreign import capi unsafe "openssl/x509.h X509_REVOKED_free" 149 | freeRevoked :: Ptr X509_REVOKED -> IO () 150 | 151 | foreign import capi unsafe "openssl/x509.h X509_REVOKED_set_serialNumber" 152 | _set_serialNumber :: Ptr X509_REVOKED -> Ptr ASN1_INTEGER -> IO CInt 153 | 154 | foreign import capi unsafe "openssl/x509.h X509_REVOKED_set_revocationDate" 155 | _set_revocationDate :: Ptr X509_REVOKED -> Ptr ASN1_TIME -> IO CInt 156 | 157 | -- |@'newCRL'@ creates an empty revocation list. You must set the 158 | -- following properties to and sign it (see 'signCRL') to actually use 159 | -- the revocation list. If you have any certificates to be listed, you 160 | -- must of course add them (see 'addRevoked') before signing the list. 161 | -- 162 | -- [/Version/] See 'setVersion'. 163 | -- 164 | -- [/Last Update/] See 'setLastUpdate'. 165 | -- 166 | -- [/Next Update/] See 'setNextUpdate'. 167 | -- 168 | -- [/Issuer Name/] See 'setIssuerName'. 169 | -- 170 | newCRL :: IO CRL 171 | newCRL = _new >>= wrapCRL 172 | 173 | 174 | wrapCRL :: Ptr X509_CRL -> IO CRL 175 | wrapCRL = fmap CRL . newForeignPtr _free 176 | 177 | 178 | withCRLPtr :: CRL -> (Ptr X509_CRL -> IO a) -> IO a 179 | withCRLPtr (CRL crl) = withForeignPtr crl 180 | 181 | -- |@'signCRL'@ signs a revocation list with an issuer private key. 182 | signCRL :: KeyPair key => 183 | CRL -- ^ The revocation list to be signed. 184 | -> key -- ^ The private key to sign with. 185 | -> Maybe Digest -- ^ A hashing algorithm to use. If @Nothing@ 186 | -- the most suitable algorithm for the key 187 | -- is automatically used. 188 | -> IO () 189 | signCRL crl key mDigest 190 | = withCRLPtr crl $ \ crlPtr -> 191 | withPKeyPtr' key $ \ pkeyPtr -> 192 | do digest <- case mDigest of 193 | Just md -> return md 194 | Nothing -> pkeyDefaultMD key 195 | withMDPtr digest $ \ digestPtr -> 196 | _sign crlPtr pkeyPtr digestPtr 197 | >>= failIf_ (== 0) 198 | return () 199 | 200 | -- |@'verifyCRL'@ verifies a signature of revocation list with an 201 | -- issuer public key. 202 | verifyCRL :: PublicKey key => CRL -> key -> IO VerifyStatus 203 | verifyCRL crl key 204 | = withCRLPtr crl $ \ crlPtr -> 205 | withPKeyPtr' key $ \ pkeyPtr -> 206 | _verify crlPtr pkeyPtr 207 | >>= interpret 208 | where 209 | interpret :: CInt -> IO VerifyStatus 210 | interpret 1 = return VerifySuccess 211 | interpret 0 = return VerifyFailure 212 | interpret _ = raiseOpenSSLError 213 | 214 | -- |@'printCRL'@ translates a revocation list into human-readable 215 | -- format. 216 | printCRL :: CRL -> IO String 217 | printCRL crl 218 | = do mem <- newMem 219 | withBioPtr mem $ \ memPtr -> 220 | withCRLPtr crl $ \ crlPtr -> 221 | _print memPtr crlPtr 222 | >>= failIf_ (/= 1) 223 | bioRead mem 224 | 225 | -- |@'getVersion' crl@ returns the version number of revocation list. 226 | getVersion :: CRL -> IO Int 227 | getVersion crl 228 | = withCRLPtr crl $ \ crlPtr -> 229 | liftM fromIntegral $ _get_version crlPtr 230 | 231 | -- |@'setVersion' crl ver@ updates the version number of revocation 232 | -- list. 233 | setVersion :: CRL -> Int -> IO () 234 | setVersion crl ver 235 | = withCRLPtr crl $ \ crlPtr -> 236 | _set_version crlPtr (fromIntegral ver) 237 | >>= failIf (/= 1) 238 | >> return () 239 | 240 | -- |@'getLastUpdate' crl@ returns the time when the revocation list 241 | -- has last been updated. 242 | getLastUpdate :: CRL -> IO UTCTime 243 | getLastUpdate crl 244 | = withCRLPtr crl $ \ crlPtr -> 245 | _get_lastUpdate crlPtr 246 | >>= peekASN1Time 247 | 248 | -- |@'setLastUpdate' crl utc@ updates the time when the revocation 249 | -- list has last been updated. 250 | setLastUpdate :: CRL -> UTCTime -> IO () 251 | setLastUpdate crl utc 252 | = withCRLPtr crl $ \ crlPtr -> 253 | withASN1Time utc $ \ time -> 254 | _set_lastUpdate crlPtr time 255 | >>= failIf (/= 1) 256 | >> return () 257 | 258 | -- |@'getNextUpdate' crl@ returns the time when the revocation list 259 | -- will next be updated. 260 | getNextUpdate :: CRL -> IO UTCTime 261 | getNextUpdate crl 262 | = withCRLPtr crl $ \ crlPtr -> 263 | _get_nextUpdate crlPtr 264 | >>= peekASN1Time 265 | 266 | -- |@'setNextUpdate' crl utc@ updates the time when the revocation 267 | -- list will next be updated. 268 | setNextUpdate :: CRL -> UTCTime -> IO () 269 | setNextUpdate crl utc 270 | = withCRLPtr crl $ \ crlPtr -> 271 | withASN1Time utc $ \ time -> 272 | _set_nextUpdate crlPtr time 273 | >>= failIf (/= 1) 274 | >> return () 275 | 276 | -- |@'getIssuerName' crl wantLongName@ returns the issuer name of 277 | -- revocation list. See 'OpenSSL.X509.getIssuerName' of 278 | -- "OpenSSL.X509". 279 | getIssuerName :: CRL -> Bool -> IO [(String, String)] 280 | getIssuerName crl wantLongName 281 | = withCRLPtr crl $ \ crlPtr -> 282 | do namePtr <- _get_issuer_name crlPtr 283 | peekX509Name namePtr wantLongName 284 | 285 | -- |@'setIssuerName' crl name@ updates the issuer name of revocation 286 | -- list. See 'OpenSSL.X509.setIssuerName' of "OpenSSL.X509". 287 | setIssuerName :: CRL -> [(String, String)] -> IO () 288 | setIssuerName crl issuer 289 | = withCRLPtr crl $ \ crlPtr -> 290 | withX509Name issuer $ \ namePtr -> 291 | _set_issuer_name crlPtr namePtr 292 | >>= failIf (/= 1) 293 | >> return () 294 | 295 | -- |@'getRevokedList' crl@ returns the list of revoked certificates. 296 | getRevokedList :: CRL -> IO [RevokedCertificate] 297 | getRevokedList crl 298 | = withCRLPtr crl $ \ crlPtr -> 299 | _get_REVOKED crlPtr >>= mapStack peekRevoked 300 | 301 | getSerialNumber :: Ptr X509_REVOKED -> IO (Ptr ASN1_INTEGER) 302 | getRevocationDate :: Ptr X509_REVOKED -> IO (Ptr ASN1_TIME) 303 | 304 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 305 | 306 | foreign import capi unsafe "openssl/x509.h X509_REVOKED_get0_serialNumber" 307 | _get0_serialNumber :: Ptr X509_REVOKED -> IO (Ptr ASN1_INTEGER) 308 | 309 | foreign import capi unsafe "openssl/x509.h X509_REVOKED_get0_revocationDate" 310 | _get0_revocationDate :: Ptr X509_REVOKED -> IO (Ptr ASN1_TIME) 311 | 312 | getSerialNumber = _get0_serialNumber 313 | getRevocationDate = _get0_revocationDate 314 | 315 | #else 316 | 317 | getSerialNumber = (#peek X509_REVOKED, serialNumber ) 318 | getRevocationDate = (#peek X509_REVOKED, revocationDate) 319 | 320 | #endif 321 | 322 | peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate 323 | peekRevoked rev = do 324 | serial <- peekASN1Integer =<< getSerialNumber rev 325 | date <- peekASN1Time =<< getRevocationDate rev 326 | return RevokedCertificate { revSerialNumber = serial 327 | , revRevocationDate = date 328 | } 329 | 330 | newRevoked :: RevokedCertificate -> IO (Ptr X509_REVOKED) 331 | newRevoked revoked 332 | = do revPtr <- _new_revoked 333 | 334 | seriRet <- withASN1Integer (revSerialNumber revoked) $ 335 | _set_serialNumber revPtr 336 | 337 | dateRet <- withASN1Time (revRevocationDate revoked) $ 338 | _set_revocationDate revPtr 339 | 340 | if seriRet /= 1 || dateRet /= 1 then 341 | freeRevoked revPtr >> raiseOpenSSLError 342 | else 343 | return revPtr 344 | 345 | -- |@'addRevoked' crl revoked@ add the certificate to the revocation 346 | -- list. 347 | addRevoked :: CRL -> RevokedCertificate -> IO () 348 | addRevoked crl revoked 349 | = withCRLPtr crl $ \ crlPtr -> 350 | do revPtr <- newRevoked revoked 351 | ret <- _add0_revoked crlPtr revPtr 352 | case ret of 353 | 1 -> return () 354 | _ -> freeRevoked revPtr >> raiseOpenSSLError 355 | 356 | -- |@'getRevoked' crl serial@ looks up the corresponding revocation. 357 | getRevoked :: CRL -> Integer -> IO (Maybe RevokedCertificate) 358 | #if OPENSSL_VERSION_NUMBER >= 0x10000000 359 | getRevoked crl serial = 360 | withCRLPtr crl $ \crlPtr -> 361 | alloca $ \revPtr -> 362 | withASN1Integer serial $ \serialPtr -> do 363 | r <- _get0_by_serial crlPtr revPtr serialPtr 364 | if r == 1 365 | then fmap Just $ peek revPtr >>= peekRevoked 366 | else return Nothing 367 | #else 368 | getRevoked crl serial = find p `fmap` getRevokedList crl 369 | where 370 | p :: RevokedCertificate -> Bool 371 | p = ((==) serial) . revSerialNumber 372 | #endif 373 | 374 | -- |@'sortCRL' crl@ sorts the certificates in the revocation list. 375 | sortCRL :: CRL -> IO () 376 | sortCRL crl 377 | = withCRLPtr crl $ \ crlPtr -> 378 | _sort crlPtr >>= failIf_ (/= 1) 379 | -------------------------------------------------------------------------------- /OpenSSL/X509/Store.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE CApiFFI #-} 4 | {-# OPTIONS_HADDOCK prune #-} 5 | -- |An interface to X.509 certificate store. 6 | module OpenSSL.X509.Store 7 | ( X509Store 8 | , X509_STORE -- private 9 | 10 | , newX509Store 11 | 12 | , wrapX509Store -- private 13 | , withX509StorePtr -- private 14 | 15 | , addCertToStore 16 | , addCRLToStore 17 | 18 | , X509StoreCtx 19 | , X509_STORE_CTX -- private 20 | 21 | , withX509StoreCtxPtr -- private 22 | , wrapX509StoreCtx -- private 23 | 24 | , getStoreCtxCert 25 | , getStoreCtxIssuer 26 | , getStoreCtxCRL 27 | , getStoreCtxChain 28 | ) 29 | where 30 | #include "HsOpenSSL.h" 31 | #if !MIN_VERSION_base(4,8,0) 32 | import Control.Applicative ((<$>)) 33 | #endif 34 | import Control.Exception (throwIO, mask_) 35 | import Foreign 36 | import Foreign.C 37 | import Foreign.Concurrent as FC 38 | import OpenSSL.X509 39 | import OpenSSL.X509.Revocation 40 | import OpenSSL.Stack 41 | import OpenSSL.Utils 42 | 43 | -- |@'X509Store'@ is an opaque object that represents X.509 44 | -- certificate store. The certificate store is usually used for chain 45 | -- verification. 46 | newtype X509Store = X509Store (ForeignPtr X509_STORE) 47 | data {-# CTYPE "openssl/x509.h" "X509_STORE" #-} X509_STORE 48 | 49 | 50 | foreign import capi unsafe "openssl/x509.h X509_STORE_new" 51 | _new :: IO (Ptr X509_STORE) 52 | 53 | foreign import capi unsafe "openssl/x509.h X509_STORE_free" 54 | _free :: Ptr X509_STORE -> IO () 55 | 56 | foreign import capi unsafe "openssl/x509.h X509_STORE_add_cert" 57 | _add_cert :: Ptr X509_STORE -> Ptr X509_ -> IO CInt 58 | 59 | foreign import capi unsafe "openssl/x509.h X509_STORE_add_crl" 60 | _add_crl :: Ptr X509_STORE -> Ptr X509_CRL -> IO CInt 61 | 62 | -- |@'newX509Store'@ creates an empty X.509 certificate store. 63 | newX509Store :: IO X509Store 64 | newX509Store = _new 65 | >>= failIfNull 66 | >>= \ ptr -> wrapX509Store (_free ptr) ptr 67 | 68 | wrapX509Store :: IO () -> Ptr X509_STORE -> IO X509Store 69 | wrapX509Store finaliser ptr 70 | = do fp <- newForeignPtr_ ptr 71 | FC.addForeignPtrFinalizer fp finaliser 72 | return $ X509Store fp 73 | 74 | withX509StorePtr :: X509Store -> (Ptr X509_STORE -> IO a) -> IO a 75 | withX509StorePtr (X509Store store) 76 | = withForeignPtr store 77 | 78 | -- |@'addCertToStore' store cert@ adds a certificate to store. 79 | addCertToStore :: X509Store -> X509 -> IO () 80 | addCertToStore store cert 81 | = withX509StorePtr store $ \ storePtr -> 82 | withX509Ptr cert $ \ certPtr -> 83 | _add_cert storePtr certPtr 84 | >>= failIf (/= 1) 85 | >> return () 86 | 87 | -- |@'addCRLToStore' store crl@ adds a revocation list to store. 88 | addCRLToStore :: X509Store -> CRL -> IO () 89 | addCRLToStore store crl 90 | = withX509StorePtr store $ \ storePtr -> 91 | withCRLPtr crl $ \ crlPtr -> 92 | _add_crl storePtr crlPtr 93 | >>= failIf (/= 1) 94 | >> return () 95 | 96 | data {-# CTYPE "openssl/x509.h" "X509_STORE_CTX" #-} X509_STORE_CTX 97 | newtype X509StoreCtx = X509StoreCtx (ForeignPtr X509_STORE_CTX) 98 | 99 | foreign import capi unsafe "openssl/x509.h X509_STORE_CTX_get_current_cert" 100 | _store_ctx_get_current_cert :: Ptr X509_STORE_CTX -> IO (Ptr X509_) 101 | 102 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_STORE_CTX_get0_current_issuer" 103 | _store_ctx_get0_current_issuer :: Ptr X509_STORE_CTX -> IO (Ptr X509_) 104 | 105 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_STORE_CTX_get0_current_crl" 106 | _store_ctx_get0_current_crl :: Ptr X509_STORE_CTX -> IO (Ptr X509_CRL) 107 | 108 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 109 | foreign import capi unsafe "openssl/x509.h X509_STORE_CTX_get1_chain" 110 | _store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK) 111 | #else 112 | foreign import capi unsafe "openssl/x509.h X509_STORE_CTX_get_chain" 113 | _store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK) 114 | #endif 115 | 116 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_ref" 117 | _x509_ref :: Ptr X509_ -> IO () 118 | 119 | foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_CRL_ref" 120 | _crl_ref :: Ptr X509_CRL -> IO () 121 | 122 | withX509StoreCtxPtr :: X509StoreCtx -> (Ptr X509_STORE_CTX -> IO a) -> IO a 123 | withX509StoreCtxPtr (X509StoreCtx fp) = withForeignPtr fp 124 | 125 | wrapX509StoreCtx :: IO () -> Ptr X509_STORE_CTX -> IO X509StoreCtx 126 | wrapX509StoreCtx finaliser ptr = 127 | X509StoreCtx <$> FC.newForeignPtr ptr finaliser 128 | 129 | getStoreCtxCert :: X509StoreCtx -> IO X509 130 | getStoreCtxCert ctx = withX509StoreCtxPtr ctx $ \pCtx -> do 131 | pCert <- _store_ctx_get_current_cert pCtx 132 | if pCert == nullPtr 133 | then throwIO $ userError "BUG: NULL certificate in X509_STORE_CTX" 134 | else mask_ $ _x509_ref pCert >> wrapX509 pCert 135 | 136 | getStoreCtxIssuer :: X509StoreCtx -> IO (Maybe X509) 137 | getStoreCtxIssuer ctx = withX509StoreCtxPtr ctx $ \pCtx -> do 138 | pCert <- _store_ctx_get0_current_issuer pCtx 139 | if pCert == nullPtr 140 | then return Nothing 141 | else fmap Just $ mask_ $ _x509_ref pCert >> wrapX509 pCert 142 | 143 | getStoreCtxCRL :: X509StoreCtx -> IO (Maybe CRL) 144 | getStoreCtxCRL ctx = withX509StoreCtxPtr ctx $ \pCtx -> do 145 | pCrl <- _store_ctx_get0_current_crl pCtx 146 | if pCrl == nullPtr 147 | then return Nothing 148 | else fmap Just $ mask_ $ _crl_ref pCrl >> wrapCRL pCrl 149 | 150 | getStoreCtxChain :: X509StoreCtx -> IO [X509] 151 | getStoreCtxChain ctx = withX509StoreCtxPtr ctx $ \pCtx -> do 152 | stack <- _store_ctx_get_chain pCtx 153 | (`mapStack` stack) $ \pCert -> mask_ $ _x509_ref pCert >> wrapX509 pCert 154 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | HsOpenSSL 2 | ========== 3 | 4 | [![Build Status](https://travis-ci.org/vshabanov/HsOpenSSL.svg?branch=master)](https://travis-ci.org/vshabanov/HsOpenSSL) 5 | 6 | HsOpenSSL is an (incomplete) OpenSSL binding for Haskell. It can 7 | generate RSA and DSA keys, read and write PEM files, generate message 8 | digests, sign and verify messages, encrypt and decrypt messages. It 9 | also has some capabilities of creating SSL clients and servers. 10 | -------------------------------------------------------------------------------- /Test/OpenSSL/Cipher.hs: -------------------------------------------------------------------------------- 1 | -- TODO: This test needs to be updated or removed. 2 | -- 3 | -- It seems that AES_ctr128_encrypt is unavailable in OpenSSL 1.1.0 4 | -- (as I understand, EVP is suggested instead). 5 | -- 6 | -- | Tests for the non-EVP ciphers 7 | module Main (main) where 8 | 9 | import qualified Data.ByteString as BS 10 | import OpenSSL.Cipher 11 | import TestUtils 12 | 13 | -- | Convert a hex string to a ByteString (e.g. "0011" == BS.pack [0, 0x11]) 14 | hexToBS :: String -> BS.ByteString 15 | hexToBS [] = BS.empty 16 | hexToBS (a : b : rest) = BS.append (BS.singleton ((valueOfHexChar a * 16) + valueOfHexChar b)) 17 | (hexToBS rest) 18 | hexToBS xs = error ("hexToBS: invalid hex string: " ++ xs) 19 | 20 | valueOfHexChar :: Integral a => Char -> a 21 | valueOfHexChar '0' = 0 22 | valueOfHexChar '1' = 1 23 | valueOfHexChar '2' = 2 24 | valueOfHexChar '3' = 3 25 | valueOfHexChar '4' = 4 26 | valueOfHexChar '5' = 5 27 | valueOfHexChar '6' = 6 28 | valueOfHexChar '7' = 7 29 | valueOfHexChar '8' = 8 30 | valueOfHexChar '9' = 9 31 | valueOfHexChar 'a' = 10 32 | valueOfHexChar 'b' = 11 33 | valueOfHexChar 'c' = 12 34 | valueOfHexChar 'd' = 13 35 | valueOfHexChar 'e' = 14 36 | valueOfHexChar 'f' = 15 37 | valueOfHexChar 'A' = 10 38 | valueOfHexChar 'B' = 11 39 | valueOfHexChar 'C' = 12 40 | valueOfHexChar 'D' = 13 41 | valueOfHexChar 'E' = 14 42 | valueOfHexChar 'F' = 15 43 | valueOfHexChar x = error ("valueOfHexChar: invalid char: " ++ show x) 44 | 45 | -- | A test containing counter mode test vectors 46 | data CTRTest = CTRTest BS.ByteString -- ^ key 47 | BS.ByteString -- ^ IV 48 | BS.ByteString -- ^ plaintext 49 | BS.ByteString -- ^ cipher text 50 | 51 | -- Test vectors from draft-ietf-ipsec-ciph-aes-ctr-05 section 6 52 | ctrTests :: [CTRTest] 53 | ctrTests = [ 54 | CTRTest (hexToBS "AE6852F8121067CC4BF7A5765577F39E") 55 | (hexToBS "00000030000000000000000000000001") 56 | (hexToBS "53696E676C6520626C6F636B206D7367") 57 | (hexToBS "E4095D4FB7A7B3792D6175A3261311B8"), 58 | CTRTest (hexToBS "7691BE035E5020A8AC6E618529F9A0DC") 59 | (hexToBS "00E0017B27777F3F4A1786F000000001") 60 | (hexToBS "000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F20212223") 61 | (hexToBS "C1CF48A89F2FFDD9CF4652E9EFDB72D74540A42BDE6D7836D59A5CEAAEF3105325B2072F"), 62 | CTRTest (hexToBS "16AF5B145FC9F579C175F93E3BFB0EED863D06CCFDB78515") 63 | (hexToBS "0000004836733C147D6D93CB00000001") 64 | (hexToBS "53696E676C6520626C6F636B206D7367") 65 | (hexToBS "4B55384FE259C9C84E7935A003CBE928"), 66 | CTRTest (hexToBS "FF7A617CE69148E4F1726E2F43581DE2AA62D9F805532EDFF1EED687FB54153D") 67 | (hexToBS "001CC5B751A51D70A1C1114800000001") 68 | (hexToBS "000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F20212223") 69 | (hexToBS "EB6C52821D0BBBF7CE7594462ACA4FAAB407DF866569FD07F48CC0B583D6071F1EC0E6B8") ] 70 | 71 | runCtrTest :: CTRTest -> IO () 72 | runCtrTest (CTRTest key iv plaintext ciphertext) = do 73 | ctx <- newAESCtx Encrypt key iv 74 | ct <- aesCTR ctx plaintext 75 | assertEqual "" ciphertext ct 76 | 77 | main :: IO () 78 | main = 79 | mapM_ runCtrTest ctrTests 80 | -------------------------------------------------------------------------------- /Test/OpenSSL/DER.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import OpenSSL.RSA 4 | import OpenSSL.DER 5 | import TestUtils 6 | 7 | main :: IO () 8 | main = do 9 | keyPair <- generateRSAKey 1024 3 Nothing 10 | pubKey <- rsaCopyPublic keyPair 11 | assertEqual "encodeDecode" (Just pubKey) (fromDERPub (toDERPub keyPair)) 12 | -------------------------------------------------------------------------------- /Test/OpenSSL/DSA.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified Data.ByteString as BS 4 | import OpenSSL.DSA 5 | import TestUtils 6 | 7 | -- | This function just runs the example DSA generation, as given in FIP 186-2, 8 | -- app 5. 9 | test_generateParameters :: IO () 10 | test_generateParameters = do 11 | let seed = BS.pack [0xd5, 0x01, 0x4e, 0x4b, 12 | 0x60, 0xef, 0x2b, 0xa8, 13 | 0xb6, 0x21, 0x1b, 0x40, 14 | 0x62, 0xba, 0x32, 0x24, 15 | 0xe0, 0x42, 0x7d, 0xd3] 16 | (a, _, p, q, g) <- generateDSAParameters 512 $ Just seed 17 | assertEqual "generateParameters" 18 | ( 105 19 | , 0x8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291 20 | , 0xc773218c737ec8ee993b4f2ded30f48edace915f 21 | , 0x626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802 22 | ) (a, p, q, g) 23 | 24 | testMessage :: BS.ByteString 25 | testMessage = BS.pack [1..20] 26 | 27 | test_signVerify :: IO () 28 | test_signVerify = do 29 | dsa <- generateDSAParametersAndKey 512 Nothing 30 | (a, b) <- signDigestedDataWithDSA dsa testMessage 31 | valid <- verifyDigestedDataWithDSA dsa testMessage (a, b) 32 | assertBool "signVerify" valid 33 | 34 | main :: IO () 35 | main = do 36 | test_generateParameters 37 | test_signVerify 38 | -------------------------------------------------------------------------------- /Test/OpenSSL/EVP/Base64.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | -- | Unittest for Base64 [en|de]coding. 4 | module Main (main) where 5 | #if !MIN_VERSION_bytestring(0,9,1) 6 | import Data.Char (ord) 7 | import Data.String 8 | #endif 9 | import qualified Data.ByteString as BS 10 | import qualified Data.ByteString.Lazy as BSL 11 | import OpenSSL.EVP.Base64 12 | import TestUtils 13 | 14 | -- NOTE: bytestring-0.9.0.4 has these instances too, while 15 | -- bytestring-0.9.0.3 does not. If our bytestring is 0.9.0.4 we'll 16 | -- have duplicate instances, but that's not our fault, is it? 17 | #if !MIN_VERSION_bytestring(0,9,1) 18 | instance IsString BS.ByteString where 19 | fromString = BS.pack . map (fromIntegral . ord) 20 | 21 | -- Note that this instance packs each charactor as a separate lazy chunk. 22 | -- This is to stress the lazy code - not because it's a good idea generally 23 | instance IsString BSL.ByteString where 24 | fromString = BSL.fromChunks . map (BS.singleton . fromIntegral . ord) 25 | #endif 26 | 27 | encodeTests :: IO () 28 | encodeTests = 29 | assertFunction "encodeBase64BS" encodeBase64BS pairs 30 | where 31 | pairs :: [(BS.ByteString, BS.ByteString)] 32 | pairs = [ ("" , "" ) 33 | , ("a" , "YQ==") 34 | , ("aa" , "YWE=") 35 | , ("aaa", "YWFh") 36 | ] 37 | 38 | lazyEncodeTests :: IO () 39 | lazyEncodeTests = 40 | assertFunction "encodeBase64LBS" encodeBase64LBS pairs 41 | where 42 | pairs :: [(BSL.ByteString, BSL.ByteString)] 43 | pairs = [ ("" , "" ) 44 | , ("a" , "YQ==") 45 | , ("aa" , "YWE=") 46 | , ("aaa", "YWFh") 47 | ] 48 | 49 | decodeTests :: IO () 50 | decodeTests = 51 | assertFunction "decodeBase64BS" decodeBase64BS pairs 52 | where 53 | pairs :: [(BS.ByteString, BS.ByteString)] 54 | pairs = [ ("" , "" ) 55 | , ("aGFza2VsbA==" , "haskell" ) 56 | , ("YWJjZGVmZ2hpams=" , "abcdefghijk") 57 | , ("YWJjZGVmZ2hpams=\n", "abcdefghijk") 58 | ] 59 | 60 | main :: IO () 61 | main = do 62 | encodeTests 63 | lazyEncodeTests 64 | decodeTests 65 | -------------------------------------------------------------------------------- /Test/OpenSSL/EVP/Digest.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified Data.ByteString.Char8 as B 4 | import qualified Data.ByteString.Lazy.Char8 as BL 5 | import Data.Char 6 | import OpenSSL 7 | import Text.Printf 8 | import OpenSSL.EVP.Digest 9 | import TestUtils 10 | 11 | main :: IO () 12 | main = withOpenSSL $ do 13 | Just md5 <- getDigestByName "MD5" 14 | Just sha1 <- getDigestByName "SHA1" 15 | Just sha256 <- getDigestByName "SHA256" 16 | let hex = concatMap (printf "%02x" . ord) . B.unpack 17 | checkHMAC digestName key testData result = do 18 | assertEqual what result $ 19 | hex $ hmacBS d (B.pack key) (B.pack testData) 20 | assertEqual ("lazy " ++ what) result $ 21 | hex $ hmacLBS d (B.pack key) (BL.pack testData) 22 | where what = 23 | "HMAC_" ++ digestName ++ 24 | "(" ++ show key ++ ", " ++ show testData ++ ")" 25 | d = case digestName of 26 | "MD5" -> md5 27 | "SHA1" -> sha1 28 | "SHA256" -> sha256 29 | _ -> error digestName 30 | -- test data from 31 | -- https://en.wikipedia.org/wiki/Hash-based_message_authentication_code 32 | 33 | checkHMAC "MD5" "" "" "74e6f7298a9c2d168935f58c001bad88" 34 | checkHMAC "SHA1" "" "" "fbdb1d1b18aa6c08324b7d64b71fb76370690e1d" 35 | checkHMAC "SHA256" "" "" "b613679a0814d9ec772f95d778c35fc5ff1697c493715653c6c712144292c5ad" 36 | checkHMAC "MD5" "key" "The quick brown fox jumps over the lazy dog" "80070713463e7749b90c2dc24911e275" 37 | checkHMAC "SHA1" "key" "The quick brown fox jumps over the lazy dog" "de7c9b85b8b78aa6bc8a7a36f70a90701c9db4d9" 38 | checkHMAC "SHA256" "key" "The quick brown fox jumps over the lazy dog" "f7bc83f430538424b13298e6aa6fb143ef4d59a14946175997479dbc2d1a3cd8" 39 | -------------------------------------------------------------------------------- /Test/OpenSSL/TestUtils.hs: -------------------------------------------------------------------------------- 1 | module TestUtils where 2 | 3 | import qualified Control.Exception as E 4 | import Control.Monad 5 | 6 | assertBool :: String -> Bool -> IO () 7 | assertBool n ok = 8 | unless ok $ E.throw $ E.AssertionFailed $ "Assertion failed: " ++ n 9 | 10 | assertEqual :: (Show a, Eq a) => String -> a -> a -> IO () 11 | assertEqual n a b = 12 | assertBool (n ++ "\n" ++ show a ++ " /= " ++ show b) (a == b) 13 | 14 | assertFunction 15 | :: (Show x, Show y, Eq y) => String -> (x -> y) -> [(x, y)] -> IO () 16 | assertFunction n f points = 17 | forM_ points $ \ (x, y) -> 18 | let r = f x in 19 | assertBool 20 | (n ++ " " ++ showsPrec 11 x "" ++ " == " ++ show r 21 | ++ " /= " ++ show y) 22 | (r == y) 23 | 24 | -- assertFunction "asdf" (fmap (+1)) [(Just 1, Nothing)] 25 | -- *** Exception: Assertion failed: asdf (Just 1) == Just 2 /= Nothing 26 | -------------------------------------------------------------------------------- /cabal-package.mk: -------------------------------------------------------------------------------- 1 | # -*- makefile-gmake -*- 2 | # 3 | # Variables: 4 | # 5 | # CONFIGURE_ARGS :: arguments to be passed to ./Setup configure 6 | # default: --disable-optimization 7 | # 8 | # RUN_COMMAND :: command to be run for "make run" 9 | # 10 | 11 | GHC ?= ghc 12 | FIND ?= find 13 | RM_RF ?= rm -rf 14 | SUDO ?= sudo 15 | AUTOCONF ?= autoconf 16 | HLINT ?= hlint 17 | HPC ?= hpc 18 | DITZ ?= ditz 19 | 20 | CONFIGURE_ARGS ?= --disable-optimization 21 | HADDOCK_OPTS ?= --hyperlink-source 22 | HLINT_OPTS ?= \ 23 | --hint=Default --hint=Dollar --hint=Generalise \ 24 | --cross \ 25 | --ignore="Parse error" \ 26 | --report=dist/report.html 27 | 28 | SETUP_FILE := $(wildcard Setup.*hs) 29 | CABAL_FILE := $(wildcard *.cabal) 30 | PKG_NAME := $(CABAL_FILE:.cabal=) 31 | 32 | ifeq ($(shell ls configure.ac 2>/dev/null),configure.ac) 33 | AUTOCONF_AC_FILE := configure.ac 34 | AUTOCONF_FILE := configure 35 | else 36 | ifeq ($(shell ls configure.in 2>/dev/null),configure.in) 37 | AUTOCONF_AC_FILE := configure.in 38 | AUTOCONF_FILE := configure 39 | else 40 | AUTOCONF_AC_FILE := 41 | AUTOCONF_FILE := 42 | endif 43 | endif 44 | 45 | BUILDINFO_IN_FILE := $(wildcard *.buildinfo.in) 46 | BUILDINFO_FILE := $(BUILDINFO_IN_FILE:.in=) 47 | 48 | all: build 49 | 50 | build: setup-config build-hook 51 | ./Setup build 52 | $(RM_RF) *.tix 53 | 54 | build-hook: 55 | 56 | ifeq ($(RUN_COMMAND),) 57 | run: 58 | @echo "cabal-package.mk: No command to run." 59 | @echo "cabal-package.mk: If you want to run something, define RUN_COMMAND variable." 60 | else 61 | run: build 62 | @echo ".:.:. Let's go .:.:." 63 | $(RUN_COMMAND) 64 | endif 65 | 66 | setup-config: dist/setup-config setup-config-hook $(BUILDINFO_FILE) 67 | 68 | setup-config-hook: 69 | 70 | dist/setup-config: $(CABAL_FILE) Setup $(AUTOCONF_FILE) 71 | ./Setup configure $(CONFIGURE_ARGS) 72 | 73 | $(AUTOCONF_FILE): $(AUTOCONF_AC_FILE) 74 | $(AUTOCONF) 75 | 76 | $(BUILDINFO_FILE): $(BUILDINFO_IN_FILE) configure 77 | ./Setup configure $(CONFIGURE_ARGS) 78 | 79 | Setup: $(SETUP_FILE) 80 | $(GHC) --make Setup 81 | 82 | reconfigure: 83 | rm -f dist/setup-config 84 | $(MAKE) setup-config 85 | 86 | clean: clean-hook 87 | $(RM_RF) dist Setup *.o *.hi .setup-config *.buildinfo *.tix .hpc 88 | $(FIND) . -name '*~' -exec rm -f {} \; 89 | 90 | clean-hook: 91 | 92 | doc: 93 | rm -rf haddocks 94 | cabal haddock-project --hackage 95 | # then go to ./haddocks, rename -internal to -docs, tar and upload 96 | 97 | install: build 98 | $(SUDO) ./Setup install 99 | 100 | sdist: setup-config 101 | ./Setup sdist 102 | 103 | test: build 104 | $(RM_RF) dist/test 105 | ./Setup test 106 | if ls *.tix >/dev/null 2>&1; then \ 107 | $(HPC) sum --output="merged.tix" --union --exclude=Main *.tix; \ 108 | $(HPC) markup --destdir="dist/hpc" --fun-entry-count "merged.tix"; \ 109 | fi 110 | 111 | # -- Find FIXME Tags ---------------------------------------------------------- 112 | fixme: 113 | @$(FIND) . \ 114 | \( -name 'dist' -or -name '.git' -or -name '_darcs' \) -prune \ 115 | -or \ 116 | \( -name '*.c' -or -name '*.h' -or \ 117 | -name '*.hs' -or -name '*.lhs' -or \ 118 | -name '*.hsc' -or -name '*.cabal' \) \ 119 | -exec egrep 'FIXME|THINKME|TODO' {} \+ \ 120 | || echo 'No FIXME, THINKME, nor TODO found.' 121 | 122 | # -- HLint -------------------------------------------------------------------- 123 | HLINT_TARGETS ?= $$(find -E . -type d -name dist -prune -o -regex '.*\.(hsc?|lhs)' -print) 124 | lint: 125 | $(HLINT) $(HLINT_TARGETS) $(HLINT_OPTS) 126 | 127 | # -- Ditz the Distributed Issue Tracker --------------------------------------- 128 | ifeq (,$(wildcard .ditz-config)) 129 | ditz: 130 | else 131 | ditz: 132 | $(DITZ) html dist/ditz 133 | 134 | ChangeLog: 135 | rm -f $@ 136 | $(DITZ) releases | awk '{print $$1}' | sort --reverse | while read i; do \ 137 | $(DITZ) changelog $$i >> $@; \ 138 | done 139 | head $@ 140 | endif 141 | 142 | # -- Pushing to remote hosts -------------------------------------------------- 143 | push: push-repo push-ditz push-doc 144 | 145 | push-repo: 146 | if [ -d "_darcs" ]; then \ 147 | darcs push; \ 148 | elif [ -d ".git" ]; then \ 149 | git push --all && git push --tags; \ 150 | fi 151 | 152 | push-ditz: ditz 153 | if [ -d "dist/ditz" ]; then \ 154 | rsync -av --delete \ 155 | dist/ditz/ \ 156 | www@nem.cielonegro.org:static.cielonegro.org/htdocs/ditz/$(PKG_NAME); \ 157 | fi 158 | 159 | push-doc: doc 160 | if [ -d "dist/doc" ]; then \ 161 | rsync -av --delete \ 162 | dist/doc/html/$(PKG_NAME)/ \ 163 | www@nem.cielonegro.org:static.cielonegro.org/htdocs/doc/$(PKG_NAME); \ 164 | fi 165 | 166 | # -- Phony Targets ------------------------------------------------------------ 167 | .PHONY: build build-hook setup-config setup-config-hook run clean clean-hook \ 168 | install doc sdist test lint push push-repo push-ditz push-doc \ 169 | ChangeLog 170 | -------------------------------------------------------------------------------- /cbits/HsOpenSSL.c: -------------------------------------------------------------------------------- 1 | #define HSOPENSSL_NEED_NOT_INCLUDE_CABAL_MACROS_H 1 2 | #include "HsOpenSSL.h" 3 | #include 4 | #include "mutex.h" 5 | 6 | /* OpenSSL ********************************************************************/ 7 | void HsOpenSSL_init() { 8 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 9 | // OPENSSL_init_ssl(OPENSSL_INIT_LOAD_SSL_STRINGS, NULL); 10 | // unnecessary in OpenSSL 1.1.0 11 | #else 12 | SSL_load_error_strings(); 13 | OpenSSL_add_all_algorithms(); 14 | SSL_library_init(); 15 | #endif 16 | } 17 | 18 | void HsOpenSSL_OPENSSL_free(void* ptr) { 19 | OPENSSL_free(ptr); 20 | } 21 | 22 | /* BIO ************************************************************************/ 23 | void HsOpenSSL_BIO_set_flags(BIO* bio, int flags) { 24 | BIO_set_flags(bio, flags); 25 | } 26 | 27 | int HsOpenSSL_BIO_flush(BIO* bio) { 28 | return BIO_flush(bio); 29 | } 30 | 31 | int HsOpenSSL_BIO_reset(BIO* bio) { 32 | return BIO_reset(bio); 33 | } 34 | 35 | int HsOpenSSL_BIO_eof(BIO* bio) { 36 | return BIO_eof(bio); 37 | } 38 | 39 | int HsOpenSSL_BIO_set_md(BIO* bio, EVP_MD* md) { 40 | return BIO_set_md(bio, md); 41 | } 42 | 43 | int HsOpenSSL_BIO_set_buffer_size(BIO* bio, int bufSize) { 44 | return BIO_set_buffer_size(bio, bufSize); 45 | } 46 | 47 | int HsOpenSSL_BIO_should_retry(BIO* bio) { 48 | return BIO_should_retry(bio); 49 | } 50 | 51 | int HsOpenSSL_BIO_FLAGS_BASE64_NO_NL() { 52 | return BIO_FLAGS_BASE64_NO_NL; 53 | } 54 | 55 | /* DH *************************************************************************/ 56 | DH* HsOpenSSL_DHparams_dup(DH* dh) { 57 | return DHparams_dup(dh); 58 | } 59 | 60 | /* EVP ************************************************************************/ 61 | int HsOpenSSL_EVP_MD_size(EVP_MD* md) { 62 | return EVP_MD_size(md); 63 | } 64 | 65 | int HsOpenSSL_EVP_CIPHER_CTX_block_size(EVP_CIPHER_CTX* ctx) { 66 | return EVP_CIPHER_CTX_block_size(ctx); 67 | } 68 | 69 | int HsOpenSSL_EVP_CIPHER_iv_length(EVP_CIPHER* cipher) { 70 | return EVP_CIPHER_iv_length(cipher); 71 | } 72 | 73 | /* EVP HMAC *******************************************************************/ 74 | HMAC_CTX *HsOpenSSL_HMAC_CTX_new(void) { 75 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 76 | return HMAC_CTX_new(); 77 | #else 78 | HMAC_CTX *ctx = (HMAC_CTX *)malloc(sizeof(HMAC_CTX)); 79 | HMAC_CTX_init(ctx); 80 | return ctx; 81 | #endif 82 | } 83 | 84 | void HsOpenSSL_HMAC_CTX_free(HMAC_CTX *ctx) { 85 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 86 | HMAC_CTX_free(ctx); 87 | #else 88 | HMAC_CTX_cleanup(ctx); 89 | free(ctx); 90 | #endif 91 | } 92 | 93 | /* X509 ***********************************************************************/ 94 | long HsOpenSSL_X509_get_version(X509* x509) { 95 | return X509_get_version(x509); 96 | } 97 | 98 | ASN1_TIME* HsOpenSSL_X509_get_notBefore(X509* x509) { 99 | return X509_get_notBefore(x509); 100 | } 101 | 102 | ASN1_TIME* HsOpenSSL_X509_get_notAfter(X509* x509) { 103 | return X509_get_notAfter(x509); 104 | } 105 | 106 | long HsOpenSSL_X509_REQ_get_version(X509_REQ* req) { 107 | return X509_REQ_get_version(req); 108 | } 109 | 110 | X509_NAME* HsOpenSSL_X509_REQ_get_subject_name(X509_REQ* req) { 111 | return X509_REQ_get_subject_name(req); 112 | } 113 | 114 | long HsOpenSSL_X509_CRL_get_version(X509_CRL* crl) { 115 | return X509_CRL_get_version(crl); 116 | } 117 | 118 | const ASN1_TIME* HsOpenSSL_X509_CRL_get_lastUpdate(const X509_CRL* crl) { 119 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 120 | return X509_CRL_get0_lastUpdate(crl); 121 | #else 122 | return X509_CRL_get_lastUpdate((X509_CRL*) crl); 123 | #endif 124 | } 125 | 126 | const ASN1_TIME* HsOpenSSL_X509_CRL_get_nextUpdate(const X509_CRL* crl) { 127 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 128 | return X509_CRL_get0_nextUpdate(crl); 129 | #else 130 | return X509_CRL_get_nextUpdate((X509_CRL*) crl); 131 | #endif 132 | } 133 | 134 | X509_NAME* HsOpenSSL_X509_CRL_get_issuer(X509_CRL* crl) { 135 | return X509_CRL_get_issuer(crl); 136 | } 137 | 138 | STACK_OF(X509_REVOKED)* HsOpenSSL_X509_CRL_get_REVOKED(X509_CRL* crl) { 139 | return X509_CRL_get_REVOKED(crl); 140 | } 141 | 142 | void HsOpenSSL_X509_ref(X509* x509) { 143 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 144 | X509_up_ref(x509); 145 | #else 146 | CRYPTO_add(&x509->references, 1, CRYPTO_LOCK_X509); 147 | #endif 148 | } 149 | 150 | void HsOpenSSL_X509_CRL_ref(X509_CRL* crl) { 151 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 152 | X509_CRL_up_ref(crl); 153 | #else 154 | CRYPTO_add(&crl->references, 1, CRYPTO_LOCK_X509_CRL); 155 | #endif 156 | } 157 | 158 | X509* HsOpenSSL_X509_STORE_CTX_get0_current_issuer(X509_STORE_CTX *ctx) { 159 | #if OPENSSL_VERSION_NUMBER >= 0x10000000L 160 | return X509_STORE_CTX_get0_current_issuer(ctx); 161 | #else 162 | return ctx->current_issuer; 163 | #endif 164 | } 165 | 166 | X509_CRL* HsOpenSSL_X509_STORE_CTX_get0_current_crl(X509_STORE_CTX *ctx) { 167 | #if OPENSSL_VERSION_NUMBER >= 0x10000000L 168 | return X509_STORE_CTX_get0_current_crl(ctx); 169 | #else 170 | return ctx->current_crl; 171 | #endif 172 | } 173 | 174 | /* PKCS#7 *********************************************************************/ 175 | long HsOpenSSL_PKCS7_is_detached(PKCS7* pkcs7) { 176 | return PKCS7_is_detached(pkcs7); 177 | } 178 | 179 | 180 | /* DH *************************************************************************/ 181 | const BIGNUM *HsOpenSSL_DH_get_pub_key(DH *dh) { 182 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 183 | const BIGNUM** pub_key = 0; 184 | const BIGNUM** priv_key = 0; 185 | DH_get0_key(dh, pub_key, priv_key); 186 | return *pub_key; 187 | #else 188 | return dh->pub_key; 189 | #endif 190 | } 191 | 192 | int HsOpenSSL_DH_length(DH *dh) { 193 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 194 | const BIGNUM** p = 0; 195 | const BIGNUM** q = 0; 196 | const BIGNUM** g = 0; 197 | DH_get0_pqg(dh, p, q, g); 198 | return BN_num_bits(*p); 199 | #else 200 | return BN_num_bits(dh->p); 201 | #endif 202 | } 203 | 204 | 205 | /* ASN1 ***********************************************************************/ 206 | 207 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L || defined(LIBRESSL_VERSION_NUMBER) 208 | #define M_ASN1_INTEGER_new() (ASN1_INTEGER *)\ 209 | ASN1_STRING_type_new(V_ASN1_INTEGER) 210 | #define M_ASN1_TIME_new() (ASN1_TIME *)\ 211 | ASN1_STRING_type_new(V_ASN1_UTCTIME) 212 | #define M_ASN1_TIME_free(a) ASN1_STRING_free((ASN1_STRING *)a) 213 | #endif 214 | 215 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 216 | #define M_ASN1_INTEGER_free(a) ASN1_STRING_free((ASN1_STRING *)a) 217 | #endif 218 | 219 | 220 | ASN1_INTEGER* HsOpenSSL_M_ASN1_INTEGER_new() { 221 | return M_ASN1_INTEGER_new(); 222 | } 223 | 224 | void HsOpenSSL_M_ASN1_INTEGER_free(ASN1_INTEGER* intPtr) { 225 | M_ASN1_INTEGER_free(intPtr); 226 | } 227 | 228 | ASN1_INTEGER* HsOpenSSL_M_ASN1_TIME_new() { 229 | return M_ASN1_TIME_new(); 230 | } 231 | 232 | void HsOpenSSL_M_ASN1_TIME_free(ASN1_TIME* timePtr) { 233 | M_ASN1_TIME_free(timePtr); 234 | } 235 | 236 | /* Threads ********************************************************************/ 237 | static mutex_t* mutex_at; 238 | 239 | struct CRYPTO_dynlock_value { 240 | mutex_t mutex; 241 | }; 242 | 243 | static void HsOpenSSL_lockingCallback(int mode, int n, const char* file, int line) { 244 | if (mode & CRYPTO_LOCK) { 245 | mutex_lock(&mutex_at[n]); 246 | } 247 | else { 248 | mutex_unlock(&mutex_at[n]); 249 | } 250 | } 251 | 252 | static unsigned long HsOpenSSL_idCallback() { 253 | return (unsigned long)self(); 254 | } 255 | 256 | static struct CRYPTO_dynlock_value* HsOpenSSL_dynlockCreateCallback(const char* file, int line) { 257 | struct CRYPTO_dynlock_value* val; 258 | 259 | val = OPENSSL_malloc(sizeof(struct CRYPTO_dynlock_value)); 260 | mutex_init(&val->mutex); 261 | 262 | return val; 263 | } 264 | 265 | static void HsOpenSSL_dynlockLockCallback(int mode, struct CRYPTO_dynlock_value* val, const char* file, int line) { 266 | if (mode & CRYPTO_LOCK) { 267 | mutex_lock(&val->mutex); 268 | } 269 | else { 270 | mutex_unlock(&val->mutex); 271 | } 272 | } 273 | 274 | static void HsOpenSSL_dynlockDestroyCallback(struct CRYPTO_dynlock_value* val, const char* file, int line) { 275 | mutex_destroy(&val->mutex); 276 | OPENSSL_free(val); 277 | } 278 | 279 | void HsOpenSSL_setupMutex() { 280 | int i; 281 | 282 | mutex_at = OPENSSL_malloc(CRYPTO_num_locks() * sizeof(*mutex_at)); 283 | 284 | for (i = 0; i < CRYPTO_num_locks(); i++) { 285 | mutex_init(&mutex_at[i]); 286 | } 287 | 288 | CRYPTO_set_locking_callback(HsOpenSSL_lockingCallback); 289 | CRYPTO_set_id_callback(HsOpenSSL_idCallback); 290 | 291 | CRYPTO_set_dynlock_create_callback(HsOpenSSL_dynlockCreateCallback); 292 | CRYPTO_set_dynlock_lock_callback(HsOpenSSL_dynlockLockCallback); 293 | CRYPTO_set_dynlock_destroy_callback(HsOpenSSL_dynlockDestroyCallback); 294 | } 295 | 296 | /* DSA ************************************************************************/ 297 | 298 | /* OpenSSL sadly wants to ASN1 encode the resulting bignums so we use this 299 | * function to skip that. Returns > 0 on success */ 300 | int HsOpenSSL_dsa_sign(DSA *dsa, const unsigned char *ddata, int dlen, 301 | const BIGNUM **r, const BIGNUM **s) { 302 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 303 | DSA_SIG *const sig = DSA_do_sign(ddata, dlen, dsa); 304 | if (!sig) return 0; 305 | DSA_SIG_get0(sig, r, s); 306 | *r = BN_dup(*r); 307 | *s = BN_dup(*s); 308 | DSA_SIG_free(sig); 309 | return 1; 310 | #else 311 | DSA_SIG *const sig = dsa->meth->dsa_do_sign(ddata, dlen, dsa); 312 | if (!sig) return 0; 313 | *r = sig->r; 314 | *s = sig->s; 315 | free(sig); 316 | return 1; 317 | #endif 318 | } 319 | 320 | int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int dlen, 321 | const BIGNUM *r, const BIGNUM *s) { 322 | #if OPENSSL_VERSION_NUMBER >= 0x10100000L 323 | DSA_SIG* sig = DSA_SIG_new(); 324 | DSA_SIG_set0(sig, BN_dup(r), BN_dup(s)); 325 | int res = DSA_do_verify(ddata, dlen, sig, dsa); 326 | DSA_SIG_free(sig); 327 | return res; 328 | #else 329 | DSA_SIG sig; 330 | sig.r = (BIGNUM *)r; 331 | sig.s = (BIGNUM *)s; 332 | return dsa->meth->dsa_do_verify(ddata, dlen, &sig, dsa); 333 | #endif 334 | } 335 | 336 | #if !defined(DSAPublicKey_dup) 337 | # define DSAPublicKey_dup(dsa) \ 338 | (DSA *)ASN1_dup((i2d_of_void *)i2d_DSAPublicKey, \ 339 | (d2i_of_void *)d2i_DSAPublicKey,(char *)dsa) 340 | #endif 341 | 342 | #if !defined(DSAPrivateKey_dup) 343 | #define DSAPrivateKey_dup(dsa) \ 344 | (DSA *)ASN1_dup((i2d_of_void *)i2d_DSAPrivateKey, \ 345 | (d2i_of_void *)d2i_DSAPrivateKey,(char *)dsa) 346 | #endif 347 | 348 | DSA* HsOpenSSL_DSAPublicKey_dup(const DSA* dsa) { 349 | return DSAPublicKey_dup(dsa); 350 | } 351 | 352 | DSA* HsOpenSSL_DSAPrivateKey_dup(const DSA* dsa) { 353 | return DSAPrivateKey_dup(dsa); 354 | } 355 | 356 | /* SSL ************************************************************************/ 357 | long HsOpenSSL_SSL_CTX_set_options(SSL_CTX* ctx, long options) { 358 | return SSL_CTX_set_options(ctx, options); 359 | } 360 | 361 | /* OpenSSL < 0.9.8m does not have SSL_CTX_clear_options() */ 362 | long HsOpenSSL_SSL_CTX_clear_options(SSL_CTX* ctx, long options) { 363 | #if defined(SSL_CTX_clear_options) 364 | return SSL_CTX_clear_options(ctx, options); 365 | #else 366 | long tmp = SSL_CTX_get_options(ctx); 367 | return SSL_CTX_set_options(ctx, tmp & ~options); 368 | #endif 369 | } 370 | 371 | long HsOpenSSL_SSL_set_options(SSL* ssl, long options) { 372 | return SSL_set_options(ssl, options); 373 | } 374 | 375 | /* OpenSSL < 1.0.0 does not have SSL_set_tlsext_host_name() */ 376 | long HsOpenSSL_SSL_set_tlsext_host_name(SSL* ssl, char* host_name) { 377 | #if defined(SSL_set_tlsext_host_name) 378 | return SSL_set_tlsext_host_name(ssl, host_name); 379 | #else 380 | return 0; 381 | #endif 382 | } 383 | 384 | /* OpenSSL < 0.9.8m does not have SSL_clear_options() */ 385 | long HsOpenSSL_SSL_clear_options(SSL* ssl, long options) { 386 | #if defined(SSL_clear_options) 387 | return SSL_clear_options(ssl, options); 388 | #else 389 | long tmp = SSL_get_options(ssl); 390 | return SSL_set_options(ssl, tmp & ~options); 391 | #endif 392 | } 393 | 394 | int HsOpenSSL_enable_hostname_validation(SSL* ssl, char* host_name, size_t host_len) { 395 | #if defined(X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS) 396 | X509_VERIFY_PARAM* param = SSL_get0_param(ssl); 397 | X509_VERIFY_PARAM_set_hostflags(param, X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS); 398 | return X509_VERIFY_PARAM_set1_host(param, host_name, host_len); 399 | #else 400 | return 0; 401 | #endif 402 | } 403 | -------------------------------------------------------------------------------- /cbits/HsOpenSSL.h: -------------------------------------------------------------------------------- 1 | #ifndef HSOPENSSL_H_INCLUDED 2 | #define HSOPENSSL_H_INCLUDED 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | 23 | /* LibreSSL *******************************************************************/ 24 | #if (defined LIBRESSL_VERSION_NUMBER && OPENSSL_VERSION_NUMBER == 0x20000000L) 25 | #undef OPENSSL_VERSION_NUMBER 26 | #define OPENSSL_VERSION_NUMBER 0x1000107fL 27 | #endif 28 | 29 | /* OpenSSL 3.0 ****************************************************************/ 30 | 31 | #ifndef OPENSSL_VERSION_PREREQ 32 | #define OPENSSL_VERSION_PREREQ(maj,min) 0 33 | #endif 34 | 35 | 36 | /* OpenSSL ********************************************************************/ 37 | void HsOpenSSL_init(); 38 | void HsOpenSSL_OPENSSL_free(void* ptr); 39 | 40 | /* BIO ************************************************************************/ 41 | void HsOpenSSL_BIO_set_flags(BIO* bio, int flags); 42 | int HsOpenSSL_BIO_flush(BIO* bio); 43 | int HsOpenSSL_BIO_reset(BIO* bio); 44 | int HsOpenSSL_BIO_eof(BIO* bio); 45 | int HsOpenSSL_BIO_set_md(BIO* bio, EVP_MD* md); 46 | int HsOpenSSL_BIO_set_buffer_size(BIO* bio, int bufSize); 47 | int HsOpenSSL_BIO_should_retry(BIO* bio); 48 | int HsOpenSSL_BIO_FLAGS_BASE64_NO_NL(); 49 | 50 | /* DH *************************************************************************/ 51 | DH* HsOpenSSL_DHparams_dup(DH* dh); 52 | const BIGNUM *HsOpenSSL_DH_get_pub_key(DH *dh); 53 | int HsOpenSSL_DH_length(DH *dh); 54 | 55 | /* EVP ************************************************************************/ 56 | int HsOpenSSL_EVP_MD_size(EVP_MD* md); 57 | int HsOpenSSL_EVP_CIPHER_CTX_block_size(EVP_CIPHER_CTX* ctx); 58 | int HsOpenSSL_EVP_CIPHER_iv_length(EVP_CIPHER* cipher); 59 | 60 | /* EVP HMAC *******************************************************************/ 61 | HMAC_CTX *HsOpenSSL_HMAC_CTX_new(void); 62 | void HsOpenSSL_HMAC_CTX_free(HMAC_CTX *ctx); 63 | 64 | /* X509 ***********************************************************************/ 65 | long HsOpenSSL_X509_get_version(X509* x509); 66 | ASN1_TIME* HsOpenSSL_X509_get_notBefore(X509* x509); 67 | ASN1_TIME* HsOpenSSL_X509_get_notAfter(X509* x509); 68 | 69 | long HsOpenSSL_X509_REQ_get_version(X509_REQ* req); 70 | X509_NAME* HsOpenSSL_X509_REQ_get_subject_name(X509_REQ* req); 71 | 72 | long HsOpenSSL_X509_CRL_get_version(X509_CRL* crl); 73 | const ASN1_TIME* HsOpenSSL_X509_CRL_get_lastUpdate(const X509_CRL* crl); 74 | const ASN1_TIME* HsOpenSSL_X509_CRL_get_nextUpdate(const X509_CRL* crl); 75 | X509_NAME* HsOpenSSL_X509_CRL_get_issuer(X509_CRL* crl); 76 | STACK_OF(X509_REVOKED)* HsOpenSSL_X509_CRL_get_REVOKED(X509_CRL* crl); 77 | void HsOpenSSL_X509_ref(X509* x509); 78 | void HsOpenSSL_X509_CRL_ref(X509_CRL* crl); 79 | X509* HsOpenSSL_X509_STORE_CTX_get0_current_issuer(X509_STORE_CTX *ctx); 80 | X509_CRL* HsOpenSSL_X509_STORE_CTX_get0_current_crl(X509_STORE_CTX *ctx); 81 | 82 | /* PKCS#7 *********************************************************************/ 83 | long HsOpenSSL_PKCS7_is_detached(PKCS7* pkcs7); 84 | 85 | /* ASN1 ***********************************************************************/ 86 | ASN1_INTEGER* HsOpenSSL_M_ASN1_INTEGER_new(); 87 | void HsOpenSSL_M_ASN1_INTEGER_free(ASN1_INTEGER* intPtr); 88 | ASN1_INTEGER* HsOpenSSL_M_ASN1_TIME_new(); 89 | void HsOpenSSL_M_ASN1_TIME_free(ASN1_TIME* timePtr); 90 | 91 | /* Threads ********************************************************************/ 92 | void HsOpenSSL_setupMutex(); 93 | 94 | /* DSA ************************************************************************/ 95 | int HsOpenSSL_dsa_sign(DSA *dsa, const unsigned char *ddata, int len, 96 | const BIGNUM **r, const BIGNUM **s); 97 | int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int len, 98 | const BIGNUM *r, const BIGNUM *s); 99 | DSA* HsOpenSSL_DSAPublicKey_dup(const DSA* dsa); 100 | DSA* HsOpenSSL_DSAPrivateKey_dup(const DSA* dsa); 101 | 102 | /* SSL ************************************************************************/ 103 | long HsOpenSSL_SSL_CTX_set_options(SSL_CTX* ctx, long options); 104 | long HsOpenSSL_SSL_CTX_clear_options(SSL_CTX* ctx, long options); 105 | long HsOpenSSL_SSL_set_options(SSL* ssl, long options); 106 | long HsOpenSSL_SSL_clear_options(SSL* ssl, long options); 107 | long HsOpenSSL_SSL_set_tlsext_host_name(SSL* ssl, char* host_name); 108 | 109 | int HsOpenSSL_enable_hostname_validation(SSL* ssl, char* host_name, size_t host_len); 110 | 111 | #endif 112 | -------------------------------------------------------------------------------- /cbits/mutex-pthread.c: -------------------------------------------------------------------------------- 1 | #include "mutex.h" 2 | 3 | void mutex_init(mutex_t* mutex) 4 | { 5 | pthread_mutex_init(mutex, NULL); 6 | } 7 | 8 | void mutex_destroy(mutex_t* mutex) 9 | { 10 | pthread_mutex_destroy(mutex); 11 | } 12 | 13 | void mutex_lock(mutex_t* mutex) 14 | { 15 | pthread_mutex_lock(mutex); 16 | } 17 | 18 | void mutex_unlock(mutex_t* mutex) 19 | { 20 | pthread_mutex_unlock(mutex); 21 | } 22 | 23 | unsigned long self() 24 | { 25 | return (unsigned long)pthread_self(); 26 | } 27 | -------------------------------------------------------------------------------- /cbits/mutex-win.c: -------------------------------------------------------------------------------- 1 | #include "mutex.h" 2 | 3 | void mutex_init(mutex_t* mutex) 4 | { 5 | *mutex = CreateMutex(NULL, FALSE, NULL); 6 | } 7 | void mutex_destroy(mutex_t* mutex) 8 | { 9 | CloseHandle(*mutex); 10 | } 11 | void mutex_lock(mutex_t* mutex) 12 | { 13 | WaitForSingleObject(mutex, INFINITE); 14 | } 15 | void mutex_unlock(mutex_t* mutex) 16 | { 17 | ReleaseMutex(mutex); 18 | } 19 | unsigned long self() 20 | { 21 | return GetCurrentThreadId(); 22 | } 23 | -------------------------------------------------------------------------------- /cbits/mutex.h: -------------------------------------------------------------------------------- 1 | #ifndef HSOPENSSL_MUTEX_H_INCLUDED 2 | #define HSOPENSSL_MUTEX_H_INCLUDED 3 | 4 | #if defined(MINGW32) 5 | #include 6 | typedef HANDLE mutex_t; 7 | #elif defined(PTHREAD) 8 | #include 9 | typedef pthread_mutex_t mutex_t; 10 | #else 11 | #error "ERROR: This platform is not supported." 12 | #endif 13 | 14 | void mutex_init(mutex_t* mutex); 15 | void mutex_destroy(mutex_t* mutex); 16 | void mutex_lock(mutex_t* mutex); 17 | void mutex_unlock(mutex_t* mutex); 18 | unsigned long self(); 19 | 20 | #endif 21 | 22 | -------------------------------------------------------------------------------- /examples/Client.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import OpenSSL 4 | import Network.Socket as S 5 | import OpenSSL.Session as SSL 6 | import Data.ByteString.Char8 as BC 7 | 8 | main = withOpenSSL (main') 9 | 10 | main' = do 11 | -- open bare socket 12 | host <- inet_addr "127.0.0.1" 13 | socket <- socket AF_INET Stream defaultProtocol 14 | S.connect socket (SockAddrInet (fromIntegral 4112) host) 15 | 16 | -- setup context 17 | ctx <- SSL.context 18 | SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2 19 | SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 20 | SSL.contextSetPrivateKeyFile ctx "client.pem" 21 | SSL.contextSetCertificateFile ctx "client.crt" 22 | SSL.contextSetVerificationMode ctx SSL.VerifyNone 23 | SSL.contextSetCiphers ctx "DEFAULT" 24 | SSL.contextCheckPrivateKey ctx >>= print 25 | 26 | -- wrap bare socket in an SSL connection 27 | wrappedSSLSocket <- SSL.connection ctx socket 28 | 29 | -- perform SSL client handshake 30 | _ <- SSL.connect wrappedSSLSocket 31 | 32 | -- write to socket 33 | SSL.write wrappedSSLSocket (BC.pack "Hello World!") 34 | 35 | -- read one response from peer 36 | b <- SSL.read wrappedSSLSocket 1024 37 | Prelude.putStrLn $ show b 38 | 39 | -- shutdown without waiting for peer to also shutdown 40 | SSL.shutdown wrappedSSLSocket SSL.Unidirectional 41 | Prelude.putStrLn "Done!" 42 | -------------------------------------------------------------------------------- /examples/GenRSAKey.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad hiding (join) 2 | import OpenSSL 3 | import OpenSSL.EVP.PKey 4 | import OpenSSL.PEM 5 | import OpenSSL.RSA 6 | import System.IO 7 | import Text.Printf 8 | 9 | main = withOpenSSL $ 10 | do let keyBits = 512 11 | keyE = 65537 12 | 13 | printf "Generating RSA key-pair, nbits = %d, e = %d:\n" keyBits keyE 14 | 15 | rsa <- generateRSAKey keyBits keyE $ Just $ \ phase _ -> 16 | do putChar $ case phase of 17 | 0 -> '.' 18 | 1 -> '+' 19 | 2 -> '*' 20 | 3 -> '\n' 21 | n -> head $ show n 22 | hFlush stdout 23 | 24 | printf "Done.\n" 25 | 26 | let n = rsaN rsa 27 | e = rsaE rsa 28 | d = rsaD rsa 29 | p = rsaP rsa 30 | q = rsaQ rsa 31 | 32 | printf "n (public modulus) = %s\n" (show n) 33 | printf "e (public exponent) = %s\n" (show e) 34 | printf "d (private exponent) = %s\n" (show d) 35 | printf "p (secret prime factor) = %s\n" (show p) 36 | printf "q (secret prime factor) = %s\n" (show q) 37 | 38 | writePKCS8PrivateKey rsa Nothing >>= putStr 39 | writePublicKey rsa >>= putStr 40 | -------------------------------------------------------------------------------- /examples/HelloWorld.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Control.Monad 3 | import qualified Data.ByteString.Char8 as B8 4 | import Data.List 5 | import Data.Maybe 6 | import Data.Monoid 7 | import OpenSSL 8 | import OpenSSL.EVP.Cipher 9 | import OpenSSL.EVP.Open 10 | import OpenSSL.EVP.PKey 11 | import OpenSSL.EVP.Seal 12 | import OpenSSL.PEM 13 | import OpenSSL.RSA 14 | import Text.Printf 15 | 16 | 17 | main = withOpenSSL $ 18 | do putStrLn "cipher: DES3" 19 | des <- liftM fromJust $ getCipherByName "DES3" 20 | 21 | putStrLn "generating RSA keypair..." 22 | rsa <- generateRSAKey 512 65537 Nothing 23 | 24 | let plainText = "Hello, world!" 25 | B8.putStrLn ("plain text to encrypt: " `mappend` plainText) 26 | 27 | putStrLn "" 28 | 29 | putStrLn "encrypting..." 30 | (encrypted, [encKey], iv) <- sealBS des [fromPublicKey rsa] plainText 31 | 32 | B8.putStrLn ("encrypted symmetric key: " `mappend` binToHex encKey) 33 | B8.putStrLn ("IV: " `mappend` binToHex iv) 34 | B8.putStrLn ("encrypted message: " `mappend` binToHex encrypted) 35 | 36 | putStrLn "" 37 | 38 | putStrLn "decrypting..." 39 | let decrypted = openBS des encKey iv rsa encrypted 40 | 41 | B8.putStrLn ("decrypted message: " `mappend` decrypted) 42 | 43 | 44 | binToHex :: B8.ByteString -> B8.ByteString 45 | binToHex = B8.pack . intercalate ":" . map (printf "%02x" . fromEnum) . B8.unpack 46 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | GHCFLAGS = -O2 2 | 3 | build: 4 | ghc $(GHCFLAGS) --make GenRSAKey 5 | ghc $(GHCFLAGS) --make HelloWorld 6 | ghc $(GHCFLAGS) --make PKCS7 7 | ghc $(GHCFLAGS) --make -threaded Server 8 | ghc $(GHCFLAGS) --make Client 9 | 10 | run: build 11 | ./PKCS7 12 | # ./HelloWorld 13 | 14 | clean: 15 | rm -f HelloWorld GenRSAKey PKCS7 Server Client *.hi *.o 16 | 17 | .PHONY: build run clean 18 | -------------------------------------------------------------------------------- /examples/PKCS7.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | import Data.Time.Clock 3 | import Data.Time.Calendar 4 | import Data.Maybe 5 | import OpenSSL 6 | import OpenSSL.PKCS7 7 | import OpenSSL.EVP.Cipher 8 | import OpenSSL.EVP.PKey 9 | import OpenSSL.PEM 10 | import OpenSSL.RSA 11 | import OpenSSL.X509 12 | import OpenSSL.X509.Store 13 | 14 | main = withOpenSSL $ 15 | do rsa <- generateRSAKey 512 65537 Nothing 16 | cert <- genCert rsa 17 | 18 | pkcs7 <- pkcs7Sign cert rsa [] "Hello, world!" [Pkcs7NoCerts] 19 | 20 | store <- newX509Store 21 | addCertToStore store cert 22 | 23 | pkcs7Verify pkcs7 [cert] store Nothing [] >>= print 24 | return () 25 | 26 | 27 | genCert :: KeyPair k => k -> IO X509 28 | genCert pkey 29 | = do x509 <- newX509 30 | setVersion x509 2 31 | setSerialNumber x509 1 32 | setIssuerName x509 [("C", "JP")] 33 | setSubjectName x509 [("C", "JP")] 34 | setNotBefore x509 =<< liftM (addUTCTime (-1)) getCurrentTime 35 | setNotAfter x509 =<< liftM (addUTCTime (365 * 24 * 60 * 60)) getCurrentTime 36 | setPublicKey x509 pkey 37 | signX509 x509 pkey Nothing 38 | return x509 39 | -------------------------------------------------------------------------------- /examples/Server.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Monad 5 | import Network.Socket 6 | import OpenSSL 7 | import OpenSSL.EVP.PKey 8 | import OpenSSL.PEM 9 | import OpenSSL.RSA 10 | import qualified OpenSSL.Session as SSL 11 | import Text.Printf 12 | 13 | main = withOpenSSL (dumpPEM >> main') 14 | 15 | dumpPEM = do pem <- readFile "server.pem" 16 | Just key <- liftM toKeyPair $ readPrivateKey pem PwNone 17 | 18 | let n = rsaN key 19 | e = rsaE key 20 | d = rsaD key 21 | printf "n (public modulus) = %s\n" (show n) 22 | printf "e (public exponent) = %s\n" (show e) 23 | printf "d (private exponent) = %s\n" (show d) 24 | 25 | main' = do 26 | sock <- socket AF_INET Stream 0 27 | bindSocket sock $ SockAddrInet (fromIntegral 4112) iNADDR_ANY 28 | setSocketOption sock ReuseAddr 1 29 | putStrLn "\n*** Listening to 4112/tcp ***" 30 | listen sock 1 31 | (sock', sockaddr) <- accept sock 32 | print $ "Accepted connection from " ++ show sockaddr 33 | 34 | ctx <- SSL.context 35 | SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2 36 | SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 37 | SSL.contextSetPrivateKeyFile ctx "server.pem" 38 | SSL.contextSetCertificateFile ctx "server.crt" 39 | SSL.contextSetCiphers ctx "DEFAULT" 40 | SSL.contextCheckPrivateKey ctx >>= print 41 | conn <- SSL.connection ctx sock' 42 | SSL.accept conn 43 | b <- SSL.read conn 1024 44 | SSL.write conn b 45 | SSL.shutdown conn SSL.Bidirectional 46 | -------------------------------------------------------------------------------- /examples/server.crt: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIC1TCCAj6gAwIBAgIJAK8d9L3ArBp+MA0GCSqGSIb3DQEBBQUAMFExCzAJBgNV 3 | BAYTAlVTMRMwEQYDVQQIEwpDYWxpZm9ybmlhMRYwFAYDVQQHEw1TYW4gRnJhbmNp 4 | c2NvMRUwEwYDVQQKEwxUZXN0aW5nIEx0ZC4wHhcNMDgwMjEzMTg1NzIwWhcNMTgw 5 | MjEwMTg1NzIwWjBRMQswCQYDVQQGEwJVUzETMBEGA1UECBMKQ2FsaWZvcm5pYTEW 6 | MBQGA1UEBxMNU2FuIEZyYW5jaXNjbzEVMBMGA1UEChMMVGVzdGluZyBMdGQuMIGf 7 | MA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCbeCZfNbMAGpFeE/ttioZhIWCP3xKU 8 | OX+ZNsMa3m3+olXx7xBjJIiF7u2VT7EqAnrdk2L8YqfDT543ihEJ6STBcrR8JCYw 9 | SE45QQNf02lRvXCG//s1H75cd/2fMeg6x8aQEgL8tFvNwTlsW9W61+qlLPanCz2s 10 | kkIqevMWcn/VVQIDAQABo4G0MIGxMB0GA1UdDgQWBBTqhsnHVVEunLFm+GyrnQBE 11 | uDCSUDCBgQYDVR0jBHoweIAU6obJx1VRLpyxZvhsq50ARLgwklChVaRTMFExCzAJ 12 | BgNVBAYTAlVTMRMwEQYDVQQIEwpDYWxpZm9ybmlhMRYwFAYDVQQHEw1TYW4gRnJh 13 | bmNpc2NvMRUwEwYDVQQKEwxUZXN0aW5nIEx0ZC6CCQCvHfS9wKwafjAMBgNVHRME 14 | BTADAQH/MA0GCSqGSIb3DQEBBQUAA4GBAEwbwKDRq1tYoEfbzX7W7iqnBHYgg0gy 15 | EbP4/7VCShUvZwdFWXe9om+W+3i83xeziBXFlNQfkXAKuoZRZSZ/6km9cbBNQYyx 16 | cAZwPGwmEQwVteLpIVqeFID5q9WTlb+PoTGhxsa36NLwzoFoptHGP9ou0X5FibDT 17 | X6eg/Y6Ie1bF 18 | -----END CERTIFICATE----- 19 | -------------------------------------------------------------------------------- /examples/server.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIICXQIBAAKBgQCbeCZfNbMAGpFeE/ttioZhIWCP3xKUOX+ZNsMa3m3+olXx7xBj 3 | JIiF7u2VT7EqAnrdk2L8YqfDT543ihEJ6STBcrR8JCYwSE45QQNf02lRvXCG//s1 4 | H75cd/2fMeg6x8aQEgL8tFvNwTlsW9W61+qlLPanCz2skkIqevMWcn/VVQIDAQAB 5 | AoGARGdJ4sw6tMn7ubvq/Rhc5bGMzeBlSUg/JwdcMp85IDcGv4ri1+xEEUG90Nse 6 | ZRBwRLtLayZxD9MhFuitdIHbBH7BMR9F/lOF/b9vItyUbH1TmPM+64Px5mwbnmXQ 7 | RPWUQbfg3GKjyycHjnLujmrD6kzocuUTxlOsaKBZFk+Q0yUCQQDLIcutn+3alc0A 8 | BFRlkPqZOPAIGEPs47dtc588MiV2fJOlzWub9wo6286wwtuDSmkw7PJDCdt9/jw1 9 | 6bep6kxDAkEAw+6z+X4/AYUqzP79Hr9f43x0ZfwmM7z6zbS5xAYDyyOV6jqNzlJw 10 | 84QAI8oIijPJqa2SLe48RzpdyiYDlz0KhwJBAMGJNI77RlqxyTzP4z1V0X21AvUj 11 | cWw9ViGBPODUgl8OuHoLaxCRYfzMOnStYwoHFowX5YY72RWE6gcP4/6PDhMCQQC+ 12 | M4c697cqPp/iCNandpgbOcG1DyX2q8m8z2hWRpCALrdlfhoS5C0J+GY6V/IaV1O5 13 | B+oT9GVHr/1EM8rgkj0ZAkBhVzqfVz/iMyYnOk0rusWUoDzWvKh+mS6o5UlWa6Ko 14 | jrwaPf6HhX1aP8d6W1jmfNXenuqH/uPBf8mJUCzrlsOX 15 | -----END RSA PRIVATE KEY----- 16 | --------------------------------------------------------------------------------