diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## 0.0.1 - 2024/02/05 + +Initial release. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# Welcome to botan-low + +Low-level bindings to the [Botan](https://botan.randombit.net/) cryptography library. + +> Botan's goal is to be the best option for cryptography in C++ by offering the tools necessary to implement a range of practical systems, such as TLS protocol, X.509 certificates, modern AEAD ciphers, PKCS#11 and TPM hardware support, password hashing, and post quantum crypto schemes. + +For more information, see the [README on Github](https://github.com/apotheca/botan) diff --git a/bench/Bcrypt.hs b/bench/Bcrypt.hs new file mode 100644 --- /dev/null +++ b/bench/Bcrypt.hs @@ -0,0 +1,70 @@ +import Test.Tasty.Bench + +import Prelude + +import Data.ByteString (ByteString(..)) +import qualified Data.ByteString as ByteString + +import qualified Botan.Bindings.RNG as Botan +import qualified Botan.Bindings.Bcrypt as Botan +import qualified Botan.Low.RNG as Botan +import qualified Botan.Low.Bcrypt as Botan +import qualified Botan.Low.Hash as Botan + + +import qualified Crypto.KDF.BCrypt as Crypton +import qualified Crypto.Hash as Crypton +import qualified Crypto.Hash.Algorithms as Crypton + +password :: ByteString +password = "Fee fi fo fum!" + +cryptonBcrypt :: Int -> IO ByteString +cryptonBcrypt factor = Crypton.hashPassword factor password + +botanBcrypt :: Int -> IO ByteString +botanBcrypt factor = do + rng <- Botan.rngInit "system" + Botan.bcryptGenerate password rng factor + + +plaintext :: ByteString +plaintext = "Fee fi fo fum! I smell the blood of an Englishman! Be he alive or be he dead, I'll grind his bones to make my bread!" + +longtext :: ByteString +longtext = ByteString.concat $ replicate 10000 $ plaintext + +cryptonHash :: ByteString -> Crypton.Digest Crypton.SHA3_512 +cryptonHash = Crypton.hash + +botanHash :: ByteString -> IO Botan.HashDigest +botanHash = Botan.hashWithName "SHA-3(512)" + +main :: IO () +main = defaultMain + [ bgroup "Bcrypt work factor" + [ bgroup "Crypton" + [ bench "twelve" $ nfIO $ cryptonBcrypt 12 + , bench "fourteen" $ nfIO $ cryptonBcrypt 14 + , bench "sixteen" $ nfIO $ cryptonBcrypt 16 + ] + , bgroup "Botan" + [ bench "twelve" $ nfIO $ botanBcrypt 12 + , bench "fourteen" $ nfIO $ botanBcrypt 14 + , bench "sixteen" $ nfIO $ botanBcrypt 16 + ] + ] + , bgroup "Hash" + [ bgroup "Crypton" + [ bench "password" $ nf cryptonHash password + , bench "plaintext" $ nf cryptonHash plaintext + , bench "longtext" $ nf cryptonHash longtext + ] + , bgroup "Botan" + [ bench "password" $ nfIO $ botanHash password + , bench "plaintext" $ nfIO $ botanHash plaintext + , bench "longtext" $ nfIO $ botanHash longtext + ] + ] + ] + diff --git a/botan-low.cabal b/botan-low.cabal new file mode 100644 --- /dev/null +++ b/botan-low.cabal @@ -0,0 +1,849 @@ +cabal-version: 3.0 +name: botan-low +version: 0.0.1.0 +license: BSD-3-Clause +author: Leo D. +maintainer: leo@apotheca.io +build-type: Simple +category: Cryptography +synopsis: Low-level Botan bindings +description: + + Welcome to botan-low + + Low-level bindings to the [Botan](https://botan.randombit.net/) cryptography library. + + > Botan's goal is to be the best option for cryptography in C++ by offering the + > tools necessary to implement a range of practical systems, such as TLS protocol, + > X.509 certificates, modern AEAD ciphers, PKCS#11 and TPM hardware support, + > password hashing, and post quantum crypto schemes. + + For more information, see the [README on Github](https://github.com/apotheca/botan) + +-- NOTE: Use data-files instead, if this is inappropriate +-- NOTE: This causes a soft error: +-- Ignoring trailing fields after sections: "extra-source-files" +-- unless placed here above source-repository and flag. +-- We can still use `extra-source-files` under `if flag(XFFI)` later without +-- causing problems +extra-source-files: + test-data/*.der + test-data/*.pem + +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/apotheca/botan.git + +flag XFFI + description: Enable experimental / upstream ffi support + manual: True + default: False + +library + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + ExistentialQuantification + NoImplicitPrelude + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + exposed-modules: + Botan.Low.Bcrypt + Botan.Low.BlockCipher + Botan.Low.Cipher + Botan.Low.Error + Botan.Low.FPE + Botan.Low.Hash + Botan.Low.HOTP + Botan.Low.KDF + Botan.Low.KeyWrap + Botan.Low.MAC + Botan.Low.MPI + Botan.Low.PubKey + Botan.Low.PubKey.Decrypt + Botan.Low.PubKey.DH + Botan.Low.PubKey.DSA + Botan.Low.PubKey.ECDH + Botan.Low.PubKey.ECDSA + Botan.Low.PubKey.Ed25519 + Botan.Low.PubKey.ElGamal + Botan.Low.PubKey.Encrypt + Botan.Low.PubKey.KeyAgreement + Botan.Low.PubKey.KeyEncapsulation + Botan.Low.PubKey.RSA + Botan.Low.PubKey.Sign + Botan.Low.PubKey.SM2 + Botan.Low.PubKey.Verify + Botan.Low.PubKey.X25519 + Botan.Low.PwdHash + Botan.Low.RNG + Botan.Low.SRP6 + Botan.Low.TOTP + Botan.Low.Utility + Botan.Low.Version + Botan.Low.View + Botan.Low.X509 + Botan.Low.ZFEC + other-modules: + Botan.Low.Prelude + Botan.Low.Make + Botan.Low.Remake + Paths_botan_low + autogen-modules: + Paths_botan_low + build-depends: + base >= 4 && < 5, + botan-bindings == 0.0.1.0, + bytestring >= 0.11 && < 0.13, + deepseq >= 1.4 && < 1.6, + text >= 1.2 && < 1.3 || >= 2.0 && < 2.2 + -- cc-options: -Wall + -- ghc-options: -Wall -funbox-strict-fields + if flag(XFFI) + exposed-modules: + Botan.Low.X509.CA + Botan.Low.X509.CSR + Botan.Low.X509.CRL + Botan.Low.X509.DN + Botan.Low.X509.Extensions + -- Botan.Low.X509.OCSP + Botan.Low.X509.Options + Botan.Low.X509.Path + Botan.Low.X509.Store + cpp-options: -DXFFI + +-- test-suite botan-low-tests +-- type: exitcode-stdio-1.0 +-- main-is: Spec.hs +-- hs-source-dirs: test/ +-- build-depends: +-- base, +-- botan-bindings, +-- botan-low, +-- bytestring, +-- directory, +-- hspec, +-- QuickCheck, +-- text +-- other-modules: +-- -- Botan.Low.BcryptSpec +-- Botan.Low.BlockCipherSpec +-- Botan.Low.CipherSpec +-- Botan.Low.FPESpec +-- Botan.Low.HashSpec +-- Botan.Low.HOTPSpec +-- Botan.Low.KDFSpec +-- Botan.Low.KeyWrapSpec +-- Botan.Low.MACSpec +-- Botan.Low.MPISpec +-- -- Botan.Low.PBKDFSpec +-- Botan.Low.PubKeySpec +-- Botan.Low.PubKey.DecryptSpec +-- Botan.Low.PubKey.DHSpec +-- Botan.Low.PubKey.DSASpec +-- Botan.Low.PubKey.ECDHSpec +-- Botan.Low.PubKey.ECDSASpec +-- Botan.Low.PubKey.Ed25519Spec +-- Botan.Low.PubKey.ElGamalSpec +-- Botan.Low.PubKey.EncryptSpec +-- Botan.Low.PubKey.KeyAgreementSpec +-- Botan.Low.PubKey.KeyEncapsulationSpec +-- Botan.Low.PubKey.RSASpec +-- Botan.Low.PubKey.SignSpec +-- Botan.Low.PubKey.SM2Spec +-- Botan.Low.PubKey.VerifySpec +-- Botan.Low.PubKey.X25519Spec +-- Botan.Low.PwdHashSpec +-- Botan.Low.RNGSpec +-- -- Botan.Low.ScryptSpec +-- Botan.Low.SRP6Spec +-- Botan.Low.TOTPSpec +-- Botan.Low.UtilitySpec +-- Botan.Low.X509Spec +-- Botan.Low.ZFECSpec +-- Test.Prelude +-- Paths_botan_low +-- -- ghc-options: +-- default-language: Haskell2010 +-- default-extensions: +-- NoImplicitPrelude +-- OverloadedStrings +-- -- NOTE: hspec-discover fails to respect the XFFI flag, and it tries +-- -- to begin loading modules that should not be built. Eg: +-- -- Could not find module ‘Botan.Low.X509.Store’ +-- -- if flag(XFFI) +-- -- other-modules: +-- -- Botan.Low.X509.CASpec +-- -- Botan.Low.X509.CSRSpec +-- -- Botan.Low.X509.CRLSpec +-- -- Botan.Low.X509.DNSpec +-- -- Botan.Low.X509.ExtensionsSpec +-- -- -- Botan.Low.X509.OCSPSpec +-- -- Botan.Low.X509.OptionsSpec +-- -- Botan.Low.X509.PathSpec +-- -- Botan.Low.X509.StoreSpec +-- -- cpp-options: -DXFFI + +-- +-- Unit tests +-- + +test-suite botan-low-bcrypt-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/BcryptSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-block-cipher-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/BlockCipherSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-cipher-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/CipherSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-fpe-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/FPESpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-hash-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/HashSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-hotp-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/HOTPSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-kdf-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/KDFSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-keywrap-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/KeyWrapSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-mac-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/MACSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-mpi-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/MPISpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKeySpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-decrypt-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/DecryptSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-dh-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/DHSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-dsa-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/DSASpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-ecdh-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/ECDHSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-ecdsa-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/ECDSASpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-ed25519-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/Ed25519Spec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-elgamal-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/ElGamalSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-encrypt-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/EncryptSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-keyagreement-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/KeyAgreementSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-keyencapsulation-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/KeyEncapsulationSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-rsa-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/RSASpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-sign-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/SignSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-sm2-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/SM2Spec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-verify-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/VerifySpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-pubkey-x25519-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PubKey/X25519Spec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +-- TODO: Pubkey folder tests + +test-suite botan-low-pwdhash-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/PwdHashSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-rng-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/RNGSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-srp6-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/SRP6Spec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-totp-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/TOTPSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-utility-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/UtilitySpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-x509-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/X509Spec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +test-suite botan-low-zfec-tests + type: exitcode-stdio-1.0 + main-is: Botan/Low/ZFECSpec.hs + hs-source-dirs: test/ + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + hspec, + QuickCheck + other-modules: + Test.Prelude + Paths_botan_low + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + +-- +-- Benchmarks +-- + +benchmark botan-low-bench + hs-source-dirs: bench + main-is: Bcrypt.hs + type: exitcode-stdio-1.0 + build-depends: + base, + botan-bindings, + botan-low, + bytestring, + crypton, + tasty-bench + default-language: Haskell2010 + default-extensions: + NoImplicitPrelude + OverloadedStrings + ghc-options: "-with-rtsopts=-A32m" + if impl(ghc >= 8.6) + ghc-options: -fproc-alignment=64 diff --git a/src/Botan/Low/Bcrypt.hs b/src/Botan/Low/Bcrypt.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/Bcrypt.hs @@ -0,0 +1,159 @@ +{-| +Module : Botan.Low.Bcrypt +Description : Bcrypt password hashing +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +Generate and validate Bcrypt password hashes +-} + +module Botan.Low.Bcrypt +( + +-- * Bcrypt +-- $introduction + +-- * Usage +-- $usage + +-- * Generate a bcrypt digest + bcryptGenerate + +-- * Validate a bcrypt digest +, bcryptIsValid + +-- * Work factor +, BcryptWorkFactor(..) +, pattern BcryptFast +, pattern BcryptGood +, pattern BcryptStrong +, BcryptPassword(..) +, BcryptDigest(..) + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.Bcrypt + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.RNG + +import Data.ByteString.Internal as ByteString + +{- $introduction + +`bcrypt` is a password-hashing algorithm designed to protect your passwords +against hackers using an expensive key setup phase. Instead of storing a user's +password in plaintext in the database, the server may instead generate a salted +bcrypt digest upon signup, and verify it upon login. + +The `bcrypt` implementation provided by `botan` generates a random salt for you +automatically. A work factor of 12 or greater is recommended. + +-} + +{- $usage + +To generate a bcrypt digest: + +> import Botan.Low.RNG +> import Botan.Low.Bcrypt +> +> -- The user has sent us a username and password in order to sign up +> onUserSignup :: ByteString -> ByteString -> IO () +> onUserSignup username password = do +> rng <- rngInit "user" +> digest <- bcryptGenerate password rng 12 +> createAndStoreNewUser username digest + +To validate a bcrypt digest: + +> import Botan.Low.RNG +> import Botan.Low.Bcrypt +> +> -- The user has sent us a username and password in order to log in +> onUserLogin :: ByteString -> ByteString -> IO Bool +> onUserLogin username password = do +> rng <- rngInit "user" +> digestMaybe <- getStoredUserDigest username +> case digestMaybe of +> Nothing -> return False +> Just digest -> bcryptIsValid password digest + +-} + +-- | A work factor to slow down guessing attacks. +type BcryptWorkFactor = Int + +pattern BcryptFast + , BcryptGood + , BcryptStrong + :: BcryptWorkFactor + +-- | Should not cause noticable CPU usage +pattern BcryptFast = BOTAN_BCRYPT_WORK_FACTOR_FAST + +-- | May cause noticable CPU usage +pattern BcryptGood = BOTAN_BCRYPT_WORK_FACTOR_GOOD + +-- | May block for several seconds +pattern BcryptStrong = BOTAN_BCRYPT_WORK_FACTOR_STRONG + +-- | A bcrypt password. +type BcryptPassword = ByteString + +-- | A bcrypt-hashed password digest. +type BcryptDigest = ByteString + +{- | +Create a password hash using Bcrypt + +> rng <- rngInit "user" +> digest <- bcryptGenerate password rng 12 + +Output is formatted bcrypt $2a$... +-} +bcryptGenerate + :: BcryptPassword -- ^ __password__: The password + -> RNG -- ^ __rng__: A random number generator + -> BcryptWorkFactor -- ^ __work_factor__: How much work to do to slow down guessing attacks. A value of 12 to 16 is probably fine. + -> IO BcryptDigest +bcryptGenerate password rng factor = asCString password $ \ passwordPtr -> do + withRNG rng $ \ botanRNG -> do + alloca $ \ szPtr -> do + -- NOTE: bcrypt max pass size should be < 72 in general, we'll + -- do 80 for safety + poke szPtr 80 + allocaBytes 80 $ \ outPtr -> do + throwBotanIfNegative_ $ botan_bcrypt_generate + outPtr + szPtr + (ConstPtr passwordPtr) + botanRNG + (fromIntegral factor) + 0 -- "@param flags should be 0 in current API revision, all other uses are reserved" + ByteString.packCString (castPtr outPtr) + +{- | +Check a previously created password hash + +> valid <- bcryptIsValid password digest +> if valid ... + +Returns True iff this password/hash combination is valid, +False if the combination is not valid (but otherwise well formed), +and otherwise throws an exception on error. +-} +bcryptIsValid + :: BcryptPassword -- ^ __password__: The password to check against + -> BcryptDigest -- ^ __hash__: The stored hash to check against + -> IO Bool +bcryptIsValid password hash = asCString password $ \ passwordPtr -> do + asCString hash $ \ hashPtr -> do + throwBotanCatchingSuccess $ botan_bcrypt_is_valid (ConstPtr passwordPtr) (ConstPtr hashPtr) diff --git a/src/Botan/Low/BlockCipher.hs b/src/Botan/Low/BlockCipher.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/BlockCipher.hs @@ -0,0 +1,337 @@ +{-| +Module : Botan.Low.BlockCipher +Description : Raw Block Cipher (PRP) interface +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +This is a ‘raw’ interface to ECB mode block ciphers. +Most applications want the higher level cipher API which provides authenticated encryption. +This API exists as an escape hatch for applications which need to implement custom primitives using a PRP. +-} + +module Botan.Low.BlockCipher +( + +-- * Block ciphers +-- $introduction + +-- * Usage +-- $usage + + BlockCipher(..) +, BlockCipherName(..) +, BlockCipher128Name(..) +, BlockCipherKey(..) +, BlockCipherCiphertext(..) +, withBlockCipher +, blockCipherInit +, blockCipherDestroy +, blockCipherName +, blockCipherBlockSize +, blockCipherGetKeyspec +, blockCipherSetKey +, blockCipherEncryptBlocks +, blockCipherDecryptBlocks +, blockCipherClear + +-- * 64-bit block ciphers + +, pattern Blowfish +, pattern CAST128 +, pattern DES +, pattern TripleDES +, pattern GOST_28147_89 +, pattern IDEA + +-- * 128-bit block ciphers + +, pattern AES128 +, pattern AES192 +, pattern AES256 +, pattern ARIA128 +, pattern ARIA192 +, pattern ARIA256 +, pattern Camellia128 +, pattern Camellia192 +, pattern Camellia256 +, pattern Noekeon +, pattern SEED +, pattern SM4 +, pattern Serpent +, pattern Twofish + +-- * 256-bit block ciphers + +, pattern SHACAL2 + +-- * 512-bit block ciphers + +, pattern Threefish512 + +-- * Convenience + +, blockCiphers +, blockCipher128s +, allBlockCiphers + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.BlockCipher + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.Remake + +{- $introduction + +A `block cipher` is a deterministic, cryptographic primitive suitable for +encrypting or decrypting a single, fixed-size block of data at a time. Block +ciphers are used as building blocks for more complex cryptographic operations. +If you are looking to encrypt user data, you are probably looking for +`Botan.Low.Cipher` instead. + +-} + +{- $usage + +Unless you need a specific block cipher, it is strongly recommended that you use the `AES256` algorithm. + +> import Botan.Low.BlockCipher +> blockCipher <- blockCipherInit AES256 + +To use a block cipher, we first need to generate (if we haven't already) a secret key. + +> import Botan.Low.RNG +> rng <- rngInit "user" +> -- We will use the maximum key size; AES256 keys are always 16 bytes +> (_,keySize,_) <- blockCipherGetKeyspec blockCipher +> -- Block cipher keys are randomly generated +> key <- rngGet rng keySize + +After the key is generated, we must set it as the block cipher key: + +> blockCipherSetKey blockCipher key + +To encrypt a message, it must be a multiple of the block size. + +> blockSize <- blockCipherBlockSize blockCipher +> -- AES256 block size is always 16 bytes +> message = "0000DEADBEEF0000" :: ByteString +> ciphertext <- blockCipherEncryptBlocks blockCipher message + +To decrypt a message, simply reverse the process: + +> plaintext <- blockCipherDecryptBlocks blockCipher ciphertext +> message == plaintext -- True + +-} + +-- | A mutable block cipher object +newtype BlockCipher = MkBlockCipher { getBlockCipherForeignPtr :: ForeignPtr BotanBlockCipherStruct } + +newBlockCipher :: BotanBlockCipher -> IO BlockCipher +withBlockCipher :: BlockCipher -> (BotanBlockCipher -> IO a) -> IO a +-- | Destroy a block cipher object immediately +blockCipherDestroy :: BlockCipher -> IO () +createBlockCipher :: (Ptr BotanBlockCipher -> IO CInt) -> IO BlockCipher +(newBlockCipher, withBlockCipher, blockCipherDestroy, createBlockCipher, _) + = mkBindings + MkBotanBlockCipher runBotanBlockCipher + MkBlockCipher getBlockCipherForeignPtr + botan_block_cipher_destroy + +-- | 128-bit block cipher name type +type BlockCipher128Name = BlockCipherName + +pattern AES128 + , AES192 + , AES256 + , ARIA128 + , ARIA192 + , ARIA256 + , Camellia128 + , Camellia192 + , Camellia256 + , Noekeon + , SEED + , SM4 + , Serpent + , Twofish + :: BlockCipher128Name + +pattern AES128 = BOTAN_BLOCK_CIPHER_128_AES_128 +pattern AES192 = BOTAN_BLOCK_CIPHER_128_AES_192 +pattern AES256 = BOTAN_BLOCK_CIPHER_128_AES_256 +pattern ARIA128 = BOTAN_BLOCK_CIPHER_128_ARIA_128 +pattern ARIA192 = BOTAN_BLOCK_CIPHER_128_ARIA_192 +pattern ARIA256 = BOTAN_BLOCK_CIPHER_128_ARIA_256 +pattern Camellia128 = BOTAN_BLOCK_CIPHER_128_CAMELLIA_128 +pattern Camellia192 = BOTAN_BLOCK_CIPHER_128_CAMELLIA_192 +pattern Camellia256 = BOTAN_BLOCK_CIPHER_128_CAMELLIA_256 +pattern Noekeon = BOTAN_BLOCK_CIPHER_128_NOEKEON +pattern SEED = BOTAN_BLOCK_CIPHER_128_SEED +pattern SM4 = BOTAN_BLOCK_CIPHER_128_SM4 +pattern Serpent = BOTAN_BLOCK_CIPHER_128_SERPENT +pattern Twofish = BOTAN_BLOCK_CIPHER_128_TWOFISH + +blockCipher128s = + [ AES128 + , AES192 + , AES256 + , ARIA128 + , ARIA192 + , ARIA256 + , Camellia128 + , Camellia192 + , Camellia256 + , Noekeon + , SEED + , SM4 + , Serpent + , Twofish + ] + +-- | Block cipher name type +type BlockCipherName = ByteString + +pattern Blowfish + , CAST128 + , DES + , TripleDES + , GOST_28147_89 + , IDEA + , SHACAL2 + , Threefish512 + :: BlockCipherName + +pattern Blowfish = BOTAN_BLOCK_CIPHER_BLOWFISH +pattern CAST128 = BOTAN_BLOCK_CIPHER_CAST_128 +pattern DES = BOTAN_BLOCK_CIPHER_DES +pattern TripleDES = BOTAN_BLOCK_CIPHER_TRIPLEDES +pattern GOST_28147_89 = BOTAN_BLOCK_CIPHER_GOST_28147_89 +pattern IDEA = BOTAN_BLOCK_CIPHER_IDEA +pattern SHACAL2 = BOTAN_BLOCK_CIPHER_SHACAL2 +pattern Threefish512 = BOTAN_BLOCK_CIPHER_THREEFISH_512 + +blockCiphers = + [ Blowfish + , CAST128 + , DES + , TripleDES + , GOST_28147_89 + , IDEA + , SHACAL2 + , Threefish512 + ] + +allBlockCiphers :: [BlockCipherName] +allBlockCiphers = blockCipher128s ++ blockCiphers + +-- | A block cipher secret key +type BlockCipherKey = ByteString + +-- | A block cipher ciphertext +type BlockCipherCiphertext = ByteString + +-- | Initialize a block cipher object +blockCipherInit + :: BlockCipherName -- ^ __cipher_name__ + -> IO BlockCipher -- ^ __bc__ +blockCipherInit = mkCreateObjectCString createBlockCipher botan_block_cipher_init + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withBlockCipherInit :: BlockCipherName -> (BlockCipher -> IO a) -> IO a +withBlockCipherInit = mkWithTemp1 blockCipherInit blockCipherDestroy + +{- | +Reinitializes a block cipher + +You must call blockCipherSetKey in order to use the block cipher again. +-} +blockCipherClear + :: BlockCipher -- ^ __bc__: The cipher object + -> IO () +blockCipherClear = mkWithObjectAction withBlockCipher botan_block_cipher_clear + +{- | +Set the key for a block cipher + +Throws an error if the key is not valid. +-} +blockCipherSetKey + :: BlockCipher -- ^ __bc__: The cipher object + -> BlockCipherKey -- ^ __key[]__: A cipher key + -> IO () +blockCipherSetKey = mkSetBytesLen withBlockCipher (\ cipher key -> botan_block_cipher_set_key cipher (ConstPtr key)) + +-- | Return the block size of a block cipher. +blockCipherBlockSize + :: BlockCipher -- ^ __bc__: The cipher object + -> IO Int +blockCipherBlockSize = mkGetIntCode withBlockCipher botan_block_cipher_block_size + +{- | +Encrypt one or more blocks with a block cipher + +The plaintext length should be a multiple of the block size. +-} +blockCipherEncryptBlocks + :: BlockCipher -- ^ __bc__: The cipher object + -> ByteString -- ^ __in[]__: The plaintext + -> IO BlockCipherCiphertext -- ^ __out[]__: The ciphertext +blockCipherEncryptBlocks blockCipher bytes = withBlockCipher blockCipher $ \ blockCipherPtr -> do + asBytesLen bytes $ \ bytesPtr bytesLen -> do + allocBytes (fromIntegral bytesLen) $ \ destPtr -> do + throwBotanIfNegative_ $ botan_block_cipher_encrypt_blocks + blockCipherPtr + (ConstPtr bytesPtr) + destPtr + bytesLen +{-# WARNING blockCipherEncryptBlocks "The plaintext length should be a multiple of the block size." #-} + +{- | +Decrypt one or more blocks with a block cipher. + +The ciphertext length should be a multiple of the block size. + +If an incorrect key was set, the content of the decrypted plaintext is unspecified. +-} +blockCipherDecryptBlocks + :: BlockCipher -- ^ __bc__: The cipher object + -> BlockCipherCiphertext -- ^ __in[]__: The ciphertext + -> IO ByteString -- ^ __out[]__: The plaintext +blockCipherDecryptBlocks blockCipher bytes = withBlockCipher blockCipher $ \ blockCipherPtr -> do + asBytesLen bytes $ \ bytesPtr bytesLen -> do + allocBytes (fromIntegral bytesLen) $ \ destPtr -> do + throwBotanIfNegative_ $ botan_block_cipher_decrypt_blocks + blockCipherPtr + (ConstPtr bytesPtr) + destPtr + bytesLen +{-# WARNING blockCipherDecryptBlocks "The ciphertext length should be a multiple of the block size." #-} + +{- | +Get the name of a block cipher. + +This function is not guaranteed to return the same exact value as used to initialize the context. +-} +blockCipherName + :: BlockCipher -- ^ __bc__ + -> IO BlockCipherName -- ^ __name__ +blockCipherName = mkGetCString withBlockCipher botan_block_cipher_name + +{- | +Get the key specification of a block cipher + +Returns the minimum, maximum, and modulo of valid keys. +-} +blockCipherGetKeyspec + :: BlockCipher -- ^ __bc__ + -> IO (Int,Int,Int) -- ^ __(min,max,mod)__ +blockCipherGetKeyspec = mkGetSizes3 withBlockCipher botan_block_cipher_get_keyspec diff --git a/src/Botan/Low/Cipher.hs b/src/Botan/Low/Cipher.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/Cipher.hs @@ -0,0 +1,617 @@ +{-| +Module : Botan.Low.Cipher +Description : Symmetric cipher modes +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +A block cipher by itself, is only able to securely encrypt a single +data block. To be able to securely encrypt data of arbitrary length, +a mode of operation applies the block cipher’s single block operation +repeatedly to encrypt an entire message. +-} + +module Botan.Low.Cipher +( + +-- * Cipher +-- $introduction + +-- * Usage +-- $usage + + Cipher(..) +, CipherName(..) +, CipherKey(..) +, CipherNonce(..) +, CipherInitFlags(..) +, pattern MaskDirection +, pattern Encrypt +, pattern Decrypt +, CipherUpdateFlags(..) +, pattern CipherUpdate +, pattern CipherFinal +, withCipher +, cipherInit +, cipherDestroy +, cipherName +, cipherOutputLength +, cipherValidNonceLength +, cipherGetTagLength +, cipherGetDefaultNonceLength +, cipherGetUpdateGranularity +, cipherGetIdealUpdateGranularity +, cipherQueryKeylen +, cipherGetKeyspec +, cipherSetKey +, cipherReset +, cipherSetAssociatedData +, cipherStart +, cipherUpdate +, cipherEncrypt +, cipherDecrypt +, cipherClear + +-- * Cipher modes +, CipherMode(..) +, cbcMode +, cfbMode +, cfbModeWith +, xtsMode + +-- ** CBC padding +, CBCPaddingName(..) +, pattern PKCS7 +, pattern OneAndZeros +, pattern X9_23 +, pattern ESP +, pattern CTS +, pattern NoPadding + +-- * AEAD +, AEADName(..) +, pattern ChaCha20Poly1305 +, chaCha20Poly1305 + +-- * AEAD modes +, AEADMode(..) +, gcmMode +, gcmModeWith +, ocbMode +, ocbModeWith +, eaxMode +, eaxModeWith +, sivMode +, ccmMode +, ccmModeWith + +-- * Convenience +, cipherEncryptOnline +, cipherDecryptOnline +, cipherModes +, cbcPaddings +, aeads +, allCiphers + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.Cipher + +import Botan.Low.BlockCipher +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.Remake + +import Botan.Low.RNG + +{- $introduction + +A `cipher` mode is a cryptographic algorithm suitable for encrypting and +decrypting large quantities of arbitrarily-sized data. An `aead` is a cipher +mode that also used to provide authentication of the ciphertext, potentially +with plaintext `associated data`. + +-} + +{- $usage + +Unless you need a specific `cipher` or `aead`, it is strongly recommended that you use the `cbcMode AES256 PKCS7` and `gcmMode AES256` (or `ChaCha20Poly1305`) algorithms respectively. + +> import Botan.Low.Cipher +> encrypter <- cipherInit ChaCha20Poly1305 Encrypt + +To use a cipher, we first need to generate (if we haven't already) a secret key. + +> import Botan.Low.RNG +> rng <- rngInit "user" +> -- We will use the maximum key size; ChaCha20Poly1305 keys are always 32 bytes +> (_,keySize,_) <- cipherGetKeyspec encrypter +> -- Block cipher keys are randomly generated +> key <- rngGet rng keySize + +After the key is generated, we must set it as the cipher key: + +> cipherSetKey encrypter key + +If the cipher is an `aead`, we may also set the `associated data`: + +> cipherSetAssociatedData encrypter "Fee fi fo fum!" + +To ensure that the key is not leaked, we should generate a new nonce for every encryption. The range of allowed nonce sizes depends on the specific algorithm. + +> import Botan.Low.RNG +> -- The default ChaCha20Poly1305 nonce is always 12 bytes. +> nonceSize <- cipherGetDefaultNonceLength encrypter +> nonce <- rngGet rng nonceSize + +To encrypt a message, it must be a multiple of the block size. If the cipher was an aead, the authentication tag will automatically be included in the ciphertext + +> -- Rarely, some cipher modes require that the message size be aligned to the block size +> -- Consult algorithm-specific documentation if this occurs. +> message = "I smell the blood of an Englishman!" +> cipherStart encrypter nonce +> ciphertext <- cipherEncrypt encrypter message + +To decrypt a message, we run the same process with a decrypter, using the same `key` and `nonce` to decode the `ciphertext`: + +> decrypter <- cipherInit ChaCha20Poly1305 Decrypt +> cipherSetKey decrypter key +> cipherSetAssociatedData decrypter "Fee fi fo fum!" +> cipherStart decrypter nonce +> plaintext <- cipherDecrypt decrypter ciphertext +> message == plaintext -- True + +You can completely clear a cipher's state, leaving it ready for reuse: + +> cipherClear encrypter +> -- You'll have to set the key, nonce, (and ad, if aead) again. +> cipherSetKey encrypter anotherKey +> cipherStart encrypter anotherNonce +> cipherSetAssociatedData encrypter anotherAD +> -- Process another message +> anotherCiphertext <- cipherEncrypt encrypter anotherMessage + +If you are encrypting or decrypting multiple messages with the same key, you can reset the cipher instead of clearing it, leaving the key set: + +> cipherClear encrypter +> -- This is equivalent to calling cipherClear followed by cipherSetKey with the original key. +> -- You'll have to set the nonce (and ad, if aead) again, but not the key. +> cipherStart encrypter anotherNonce +> cipherSetAssociatedData encrypter anotherAD +> -- Process another message with the same key +> anotherCiphertext <- cipherEncrypt encrypter anotherMessage + +-} + +-- NOTE: This is *symmetric* ciphers For the 'raw' interface to ECB mode block ciphers, see BlockCipher.hs + +newtype Cipher = MkCipher { getCipherForeignPtr :: ForeignPtr BotanCipherStruct } + +newCipher :: BotanCipher -> IO Cipher +withCipher :: Cipher -> (BotanCipher -> IO a) -> IO a +-- | Destroy the cipher object immediately +cipherDestroy :: Cipher -> IO () +createCipher :: (Ptr BotanCipher -> IO CInt) -> IO Cipher +(newCipher, withCipher, cipherDestroy, createCipher, _) + = mkBindings + MkBotanCipher runBotanCipher + MkCipher getCipherForeignPtr + botan_cipher_destroy + +type CipherInitFlags = Word32 +type CipherUpdateFlags = Int +type CipherNonce = ByteString +type CipherKey = ByteString + +type CipherName = ByteString + +type CipherMode = ByteString + +type CBCPaddingName = ByteString + +pattern PKCS7 + , OneAndZeros + , X9_23 + , ESP + , CTS + , NoPadding + :: CBCPaddingName + +pattern PKCS7 = BOTAN_CBC_PADDING_PKCS7 +pattern OneAndZeros = BOTAN_CBC_PADDING_ONE_AND_ZEROS +pattern X9_23 = BOTAN_CBC_PADDING_X9_23 +pattern ESP = BOTAN_CBC_PADDING_ESP +pattern CTS = BOTAN_CBC_PADDING_CTS +pattern NoPadding = BOTAN_CBC_PADDING_NO_PADDING + +cbcMode :: BlockCipherName -> CBCPaddingName -> CipherName +cbcMode bc padding = bc // BOTAN_CIPHER_MODE_CBC // padding + +cfbMode :: BlockCipherName -> CipherName +cfbMode bc = bc // BOTAN_CIPHER_MODE_CFB + +cfbModeWith :: BlockCipherName -> Int -> CipherName +cfbModeWith bc feedbackSz = cfbMode bc /$ showBytes feedbackSz + +xtsMode :: BlockCipherName -> CipherName +xtsMode bc = bc // BOTAN_CIPHER_MODE_XTS + +type AEADName = CipherName + +pattern ChaCha20Poly1305 :: CipherName +pattern ChaCha20Poly1305 = BOTAN_AEAD_CHACHA20POLY1305 + +chaCha20Poly1305 :: AEADName +chaCha20Poly1305 = BOTAN_AEAD_CHACHA20POLY1305 + +type AEADMode = ByteString + +gcmMode :: BlockCipher128Name -> AEADName +gcmMode bc = bc // BOTAN_AEAD_MODE_GCM + +gcmModeWith :: BlockCipher128Name -> Int -> AEADName +gcmModeWith bc tagSz = gcmMode bc /$ showBytes tagSz + +ocbMode :: BlockCipher128Name -> AEADName +ocbMode bc = bc // BOTAN_AEAD_MODE_OCB + +ocbModeWith :: BlockCipher128Name -> Int -> AEADName +ocbModeWith bc tagSz = ocbMode bc /$ showBytes tagSz + +eaxMode :: BlockCipherName -> AEADName +eaxMode bc = bc // BOTAN_AEAD_MODE_EAX + +eaxModeWith :: BlockCipherName -> Int -> AEADName +eaxModeWith bc tagSz = eaxMode bc /$ showBytes tagSz + +sivMode :: BlockCipher128Name -> AEADName +sivMode bc = bc // BOTAN_AEAD_MODE_SIV + +ccmMode :: BlockCipher128Name -> AEADName +ccmMode bc = bc // BOTAN_AEAD_MODE_CCM + +ccmModeWith :: BlockCipher128Name -> Int -> Int -> AEADName +ccmModeWith bc tagSz l = ccmMode bc /$ showBytes tagSz <> "," <> showBytes l + +cbcPaddings = + [ PKCS7 + , OneAndZeros + , X9_23 + , ESP + , CTS + , NoPadding + ] + +cipherModes = concat + [ [ cbcMode bc pd | bc <- allBlockCiphers, pd <- cbcPaddings ] + , [ cfbMode bc | bc <- allBlockCiphers ] + , [ xtsMode bc | bc <- allBlockCiphers ] + ] + +aeads = concat + [ [ chaCha20Poly1305 ] + , [ gcmMode bc | bc <- blockCipher128s ] + , [ ocbMode bc | bc <- blockCipher128s ] + , [ eaxMode bc | bc <- blockCiphers ] -- WARNING: Why just blockCiphers, why not allBlockCiphers? + , [ sivMode bc | bc <- blockCipher128s ] + , [ ccmMode bc | bc <- blockCipher128s ] + ] + +allCiphers = cipherModes ++ aeads + +-- TODO: Rename CipherMaskDirection, CipherEncrypt, CipherDecrypt; +-- Leave slim terminology for botan +pattern MaskDirection + , Encrypt -- ^ May be renamed Encipher to avoid confusion with PKEncrypt + , Decrypt -- ^ May be renamed Decipher to avoid confusion with PKDecrypt + :: CipherInitFlags + +pattern MaskDirection = BOTAN_CIPHER_INIT_FLAG_MASK_DIRECTION +pattern Encrypt = BOTAN_CIPHER_INIT_FLAG_ENCRYPT +pattern Decrypt = BOTAN_CIPHER_INIT_FLAG_DECRYPT + +pattern CipherUpdate + , CipherFinal + :: CipherUpdateFlags + +pattern CipherUpdate = BOTAN_CIPHER_UPDATE_FLAG_NONE +pattern CipherFinal = BOTAN_CIPHER_UPDATE_FLAG_FINAL + +-- |Initialize a cipher object +cipherInit + :: CipherName -- ^ __name__ + -> CipherInitFlags -- ^ __flags__ + -> IO Cipher -- ^ __cipher__ +cipherInit = mkCreateObjectCString1 createCipher botan_cipher_init + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withCipherInit :: CipherName -> CipherInitFlags -> (Cipher -> IO a) -> IO a +withCipherInit = mkWithTemp2 cipherInit cipherDestroy + +-- |Return the name of the cipher object +cipherName + :: Cipher -- ^ __cipher__ + -> IO CipherName -- ^ __name__ +cipherName = mkGetCString withCipher botan_cipher_name + +-- |Return the output length of this cipher, for a particular input length. +-- +-- WARNING: This function is of limited use. From the C++ docs: +-- /** +-- * Returns the size of the output if this transform is used to process a +-- * message with input_length bytes. In most cases the answer is precise. +-- * If it is not possible to precise (namely for CBC decryption) instead an +-- * upper bound is returned. +-- */ +-- We need to explicitly calculate padding + tag length +cipherOutputLength + :: Cipher -- ^ __cipher__ + -> Int -- ^ __in_len__ + -> IO Int -- ^ __out_len__ +cipherOutputLength = mkGetSize_csize withCipher botan_cipher_output_length + +-- NOTE: Unique function form? +-- |Return if the specified nonce length is valid for this cipher +-- NOTE: This just always seems to return 'True', even for -1 and maxBound +cipherValidNonceLength + :: Cipher -- ^ __cipher__ + -> Int -- ^ __nl__ + -> IO Bool +cipherValidNonceLength = mkGetBoolCode_csize withCipher botan_cipher_valid_nonce_length + +-- |Get the tag length of the cipher (0 for non-AEAD modes) +cipherGetTagLength + :: Cipher -- ^ __cipher__ + -> IO Int -- ^ __tag_size__ +cipherGetTagLength = mkGetSize withCipher botan_cipher_get_tag_length + +-- |Get the default nonce length of this cipher +cipherGetDefaultNonceLength + :: Cipher -- ^ __cipher__ + -> IO Int -- ^ __nl__ +cipherGetDefaultNonceLength = mkGetSize withCipher botan_cipher_get_default_nonce_length + +-- |Return the update granularity of the cipher; botan_cipher_update must be +-- called with blocks of this size, except for the final. +cipherGetUpdateGranularity + :: Cipher -- ^ __cipher__ + -> IO Int -- ^ __ug__ +cipherGetUpdateGranularity = mkGetSize withCipher botan_cipher_get_update_granularity + +-- |Return the ideal update granularity of the cipher. This is some multiple of the +-- update granularity, reflecting possibilities for optimization. +-- +-- Some ciphers (ChaChaPoly, EAX) may consume less input than the reported ideal granularity +cipherGetIdealUpdateGranularity + :: Cipher -- ^ __cipher__ + -> IO Int -- ^ __ug__ +cipherGetIdealUpdateGranularity = mkGetSize withCipher botan_cipher_get_ideal_update_granularity + +-- |Get information about the key lengths. +cipherQueryKeylen + :: Cipher -- ^ __cipher__ + -> IO (Int,Int) -- ^ __(min,max)__ +cipherQueryKeylen = mkGetSizes2 withCipher botan_cipher_query_keylen +{-# DEPRECATED cipherQueryKeylen "Prefer cipherGetKeyspec." #-} + +-- |Get information about the supported key lengths. +cipherGetKeyspec + :: Cipher -- ^ __cipher__ + -> IO (Int,Int,Int) -- ^ __(min,max,mod)__ +cipherGetKeyspec = mkGetSizes3 withCipher botan_cipher_get_keyspec + +-- |Set the key for this cipher object +cipherSetKey + :: Cipher -- ^ __cipher__ + -> ByteString -- ^ __key__ + -> IO () +cipherSetKey = mkWithObjectSetterCBytesLen withCipher botan_cipher_set_key + +-- |Reset the message specific state for this cipher. +-- Without resetting the keys, this resets the nonce, and any state +-- associated with any message bits that have been processed so far. +-- +-- It is conceptually equivalent to calling botan_cipher_clear followed +-- by botan_cipher_set_key with the original key. +cipherReset + :: Cipher -- ^ __cipher__ + -> IO () +cipherReset = mkAction withCipher botan_cipher_reset + +-- |Set the associated data. Will fail if cipher is not an AEAD +cipherSetAssociatedData + :: Cipher -- ^ __cipher__ + -> ByteString -- ^ __ad__ + -> IO () +cipherSetAssociatedData = mkWithObjectSetterCBytesLen withCipher botan_cipher_set_associated_data + +-- |Begin processing a new message using the provided nonce +cipherStart + :: Cipher -- ^ __cipher__ + -> ByteString -- ^ __nonce__ + -> IO () +cipherStart = mkWithObjectSetterCBytesLen withCipher botan_cipher_start + +-- |"Encrypt some data" +-- +-- This function is ill-documented. +-- +-- See the source for authoritative details: +-- https://github.com/randombit/botan/blob/72dc18bbf598f2c3bef81a4fb2915e9c3c524ac4/src/lib/ffi/ffi_cipher.cpp#L133 +-- +-- Some ciphers (ChaChaPoly, EAX) may consume less input than the reported ideal granularity +cipherUpdate + :: Cipher -- ^ __cipher__ + -> CipherUpdateFlags -- ^ __flags__ + -> Int -- ^ __output_size__ + -> ByteString -- ^ __input_bytes[]__ + -> IO (Int,ByteString) -- ^ __(input_consumed,output[])__ +cipherUpdate ctx flags outputSz input = withCipher ctx $ \ ctxPtr -> do + unsafeAsBytesLen input $ \ inputPtr inputSz -> do + alloca $ \ consumedPtr -> do + alloca $ \ writtenPtr -> do + output <- allocBytes outputSz $ \ outputPtr -> do + throwBotanIfNegative_ $ botan_cipher_update + ctxPtr + (fromIntegral flags) + outputPtr + (fromIntegral outputSz) + writtenPtr + (ConstPtr inputPtr) + inputSz + consumedPtr + consumed <- fromIntegral <$> peek consumedPtr + written <- fromIntegral <$> peek writtenPtr + -- NOTE: The safety of this function is suspect - may require deepseq + let processed = ByteString.take written output + in processed `seq` return (consumed,processed) + +{- | +Encrypt and finalize a complete piece of data. + +This is not a canonical Botan C/C++ function. +-} +cipherEncrypt :: Cipher -> ByteString -> IO ByteString +cipherEncrypt = cipherEncryptOffline + +{- | +Encrypt and finalize a complete piece of data. + +This is not a canonical Botan C/C++ function. +-} +cipherDecrypt :: Cipher -> ByteString -> IO ByteString +cipherDecrypt = cipherDecryptOffline + +-- |Reset the key, nonce, AD and all other state on this cipher object +cipherClear :: Cipher -> IO () +cipherClear = mkAction withCipher botan_cipher_clear + +{- +Non-standard functions +-} + +-- NOTE: out + ug + tag is safe overestimate for encryption +-- NOTE: out + ug - tag may not be a safe overestimate for decryption +{-# DEPRECATED cipherEstimateOutputLength "This will be moved from botan-low to botan" #-} +cipherEstimateOutputLength :: Cipher -> CipherInitFlags -> Int -> IO Int +cipherEstimateOutputLength ctx flags input = do + o <- cipherOutputLength ctx input -- NOTE: Flawed but usable + u <- cipherGetUpdateGranularity ctx -- TODO: When u == 1, it should be just input + t, right? + t <- cipherGetTagLength ctx + if flags == BOTAN_CIPHER_INIT_FLAG_ENCRYPT + then return (o + u + t) + else return (o + u - t) -- TODO: Maybe just 'o'... + +-- NOTE: Offset must be a valid length of the input so far processed +-- NOTE: If (estimated) outputLength input + offset == outputLength (input + offset) then +-- we can just use cipherEstimateOutputLength instead of this +-- However, this may not be completely true due to block alignment requirements +-- For the moment this function exists for clarity. +{-# DEPRECATED cipherEstimateFinalOutputLength "Moving from botan-low to botan" #-} +cipherEstimateFinalOutputLength :: Cipher -> CipherInitFlags -> Int -> Int -> IO Int +cipherEstimateFinalOutputLength ctx flags offset input = do + len <- cipherEstimateOutputLength ctx flags (offset + input) + return $ len - offset + +-- A better version of cipherUpdate +-- NOTE: It returns (processed,remaining) compared to (consumed,processed) +-- so the processed ciphertext has moved from snd to fst +-- TODO: Use Builder to do this +-- https://hackage.haskell.org/package/bytestring-0.12.0.2/docs/Data-ByteString-Builder.html +-- NOTE: There still is (an efficiency) use for a version that reports only consumed length +-- and defers the computation of the 'remaining' bytestring +{-# DEPRECATED cipherProcess "Moving from botan-low to botan" #-} +cipherProcess :: Cipher -> CipherUpdateFlags -> Int -> ByteString -> IO (ByteString,ByteString) +cipherProcess ctx flags outputSz input = do + (consumed,processed) <- cipherUpdate ctx flags outputSz input + -- NOTE: The safety of this function is suspect - may require deepseq + let remaining = ByteString.drop consumed input + in processed `seq` remaining `seq` return (processed,remaining) + +{-# DEPRECATED cipherProcessOffline "Moving from botan-low to botan" #-} +cipherProcessOffline :: Cipher -> CipherInitFlags -> ByteString -> IO ByteString +cipherProcessOffline ctx flags msg = do + o <- cipherEstimateOutputLength ctx flags (ByteString.length msg) + -- snd <$> cipherUpdate ctx BOTAN_CIPHER_UPDATE_FLAG_FINAL o msg + fst <$> cipherProcess ctx BOTAN_CIPHER_UPDATE_FLAG_FINAL o msg + +{-# WARNING cipherEncryptOffline "May be renamed to cipherEncrypt, may be moved to botan" #-} +cipherEncryptOffline :: Cipher -> ByteString -> IO ByteString +cipherEncryptOffline ctx = cipherProcessOffline ctx BOTAN_CIPHER_INIT_FLAG_ENCRYPT + +{-# WARNING cipherDecryptOffline "May be renamed to cipherDecrypt, may be moved to botan" #-} +cipherDecryptOffline :: Cipher -> ByteString -> IO ByteString +cipherDecryptOffline ctx = cipherProcessOffline ctx BOTAN_CIPHER_INIT_FLAG_DECRYPT + +{- +Experiments with online processing +-} + +-- cipherEncryptOnline :: Cipher -> ByteString -> IO ByteString +-- cipherEncryptOnline ctx msg = do +-- u <- cipherGetUpdateGranularity ctx +-- t <- cipherGetTagLength ctx +-- g <- cipherGetIdealUpdateGranularity ctx +-- ByteString.concat <$> go 0 u t g msg +-- where +-- go i u t g bs = case ByteString.splitAt g bs of +-- (block,"") -> do +-- o <- cipherOutputLength ctx (i + ByteString.length block) -- NOTE: Flawed but usable +-- (_,encblock) <- cipherUpdate ctx BOTAN_CIPHER_UPDATE_FLAG_FINAL (o + u + t - i) block +-- return [encblock] +-- (block,rest) -> do +-- (_,encblock) <- cipherUpdate ctx BOTAN_CIPHER_UPDATE_FLAG_NONE g block +-- encrest <- go (i + g) u t g rest +-- return $! encblock : encrest + +-- NOTE: Some ciphers (SIV, CCM) are not online-capable algorithms, but Botan does not throw +-- an error even though it should. +{-# DEPRECATED cipherProcessOnline "Moving from botan-low to botan" #-} +cipherProcessOnline :: Cipher -> CipherInitFlags -> ByteString -> IO ByteString +cipherProcessOnline ctx flags = if flags == BOTAN_CIPHER_INIT_FLAG_ENCRYPT + then cipherEncryptOnline ctx + else cipherDecryptOnline ctx + +-- TODO: Consolidate online encipher / decipher +-- TODO: Use Builder to do this +-- https://hackage.haskell.org/package/bytestring-0.12.0.2/docs/Data-ByteString-Builder.html +{-# DEPRECATED cipherEncryptOnline "Moving from botan-low to botan" #-} +cipherEncryptOnline :: Cipher -> ByteString -> IO ByteString +cipherEncryptOnline ctx msg = do + g <- cipherGetIdealUpdateGranularity ctx + ByteString.concat <$> go 0 g msg + where + go i g bs = case ByteString.splitAt g bs of + (block,"") -> do + o <- cipherEstimateFinalOutputLength ctx BOTAN_CIPHER_INIT_FLAG_ENCRYPT i (ByteString.length block) + (processed,_) <- cipherProcess ctx BOTAN_CIPHER_UPDATE_FLAG_FINAL o block + return [processed] + (block,rest) -> do + (processed,remaining) <- cipherProcess ctx BOTAN_CIPHER_UPDATE_FLAG_NONE g block + (processed :) <$> go (i + g) g (remaining <> rest) + -- Though this following version may be more efficient especially with lazy bytestrings + -- or builder, though note *which* update function it uses - the original + -- (consumed,processed) <- cipherUpdate ctx BOTAN_CIPHER_UPDATE_FLAG_NONE g block + -- (processed :) <$> go (i + g) g (ByteString.drop consumed bs) + +-- TODO: Consolidate online encipher / decipher +{-# DEPRECATED cipherDecryptOnline "Moving from botan-low to botan" #-} +cipherDecryptOnline :: Cipher -> ByteString -> IO ByteString +cipherDecryptOnline ctx msg = do + g <- cipherGetIdealUpdateGranularity ctx + t <- cipherGetTagLength ctx + ByteString.concat <$> go 0 g t msg + where + go i g t bs = case ByteString.splitAt g bs of + (block,"") -> do + o <- cipherEstimateFinalOutputLength ctx BOTAN_CIPHER_INIT_FLAG_DECRYPT i (ByteString.length block) + (processed,_) <- cipherProcess ctx BOTAN_CIPHER_UPDATE_FLAG_FINAL o block + return [processed] + (block,rest) -> do + (processed,remaining) <- cipherProcess ctx BOTAN_CIPHER_UPDATE_FLAG_NONE g block + (processed :) <$> go (i + g) g t (remaining <> rest) diff --git a/src/Botan/Low/Error.hs b/src/Botan/Low/Error.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/Error.hs @@ -0,0 +1,406 @@ +{-| +Module : Botan.Low.Error +Description : Error codes and exception handling +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.Error +( BotanErrorCode(..) +, pattern Success +, pattern InvalidIdentifier +, pattern InvalidInput +, pattern BadMAC +, pattern InsufficientBufferSpace +, pattern StringConversionError +, pattern ExceptionThrown +, pattern OutOfMemory +, pattern SystemError +, pattern InternalError +, pattern BadFlag +, pattern NullPointer +, pattern BadParameter +, pattern KeyNotSet +, pattern InvalidKeyLength +, pattern InvalidObjectState +, pattern NotImplemented +, pattern InvalidObject +, pattern TLSError +, pattern HttpError +, pattern RoughtimeError +, pattern UnknownError +, botanErrorDescription +, botanErrorLastExceptionMessage +, SomeBotanException(..) +, toBotanException +, fromBotanException +, InvalidInputException(..) +, BadMACException(..) +, InsufficientBufferSpaceException(..) +, StringConversionException(..) +, ExceptionThrownException(..) +, OutOfMemoryException(..) +, SystemErrorException(..) +, InternalErrorException(..) +, BadFlagException(..) +, NullPointerException(..) +, BadParameterException(..) +, KeyNotSetException(..) +, InvalidKeyLengthException(..) +, InvalidObjectStateException(..) +, NotImplementedException(..) +, InvalidObjectException(..) +, UnknownException(..) +, throwBotanError +, throwBotanIfNegative +, throwBotanIfNegative_ +, throwBotanCatchingSuccess +, throwBotanCatchingBool +, throwBotanCatchingInt +, throwBotanErrorWithCallstack +, tryBotan +, catchBotan +, handleBotan +) where + +import Data.Typeable + +import Botan.Bindings.Error + +import Botan.Low.Prelude + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.Text as Text + +-- | Botan error code data type +type BotanErrorCode = CInt + +{- +Botan error code patterns +-} + +pattern Success + , InvalidIdentifier + , InvalidInput + , BadMAC + , InsufficientBufferSpace + , StringConversionError + , ExceptionThrown + , OutOfMemory + , SystemError + , InternalError + , BadFlag + , NullPointer + , BadParameter + , KeyNotSet + , InvalidKeyLength + , InvalidObjectState + , NotImplemented + , InvalidObject + , TLSError + , HttpError + , RoughtimeError + , UnknownError + :: BotanErrorCode + +pattern Success = BOTAN_FFI_SUCCESS +pattern InvalidIdentifier = BOTAN_FFI_INVALID_VERIFIER +pattern InvalidInput = BOTAN_FFI_ERROR_INVALID_INPUT +pattern BadMAC = BOTAN_FFI_ERROR_BAD_MAC +pattern InsufficientBufferSpace = BOTAN_FFI_ERROR_INSUFFICIENT_BUFFER_SPACE +pattern StringConversionError = BOTAN_FFI_ERROR_STRING_CONVERSION_ERROR +pattern ExceptionThrown = BOTAN_FFI_ERROR_EXCEPTION_THROWN +pattern OutOfMemory = BOTAN_FFI_ERROR_OUT_OF_MEMORY +pattern SystemError = BOTAN_FFI_ERROR_SYSTEM_ERROR +pattern InternalError = BOTAN_FFI_ERROR_INTERNAL_ERROR +pattern BadFlag = BOTAN_FFI_ERROR_BAD_FLAG +pattern NullPointer = BOTAN_FFI_ERROR_NULL_POINTER +pattern BadParameter = BOTAN_FFI_ERROR_BAD_PARAMETER +pattern KeyNotSet = BOTAN_FFI_ERROR_KEY_NOT_SET +pattern InvalidKeyLength = BOTAN_FFI_ERROR_INVALID_KEY_LENGTH +pattern InvalidObjectState = BOTAN_FFI_ERROR_INVALID_OBJECT_STATE +pattern NotImplemented = BOTAN_FFI_ERROR_NOT_IMPLEMENTED +pattern InvalidObject = BOTAN_FFI_ERROR_INVALID_OBJECT +pattern TLSError = BOTAN_FFI_ERROR_TLS_ERROR +pattern HttpError = BOTAN_FFI_ERROR_HTTP_ERROR +pattern RoughtimeError = BOTAN_FFI_ERROR_ROUGHTIME_ERROR +pattern UnknownError = BOTAN_FFI_ERROR_UNKNOWN_ERROR + +{- +Botan error code functions +-} + +-- | Convert an error code into a string. Returns "Unknown error" if the error code is not a known one. +botanErrorDescription :: BotanErrorCode -> IO ByteString +botanErrorDescription e = do + descPtr <- botan_error_description e + peekCString (unConstPtr descPtr) + +-- | Returns a static string stored in a thread local variable which contains the last exception message thrown. +-- WARNING: This string buffer is overwritten on the next call to the FFI layer +botanErrorLastExceptionMessage :: IO ErrorMessage +botanErrorLastExceptionMessage = do + msgPtr <- botan_error_last_exception_message + peekCString (unConstPtr msgPtr) + +type ErrorMessage = ByteString + +{- +Exceptions +-} + +-- | The SomeBotanException type is the root of the botan exception type hierarchy. +data SomeBotanException = forall e . Exception e => SomeBotanException e + +instance Show SomeBotanException where + show (SomeBotanException e) = show e + +instance Exception SomeBotanException + +toBotanException :: Exception e => e -> SomeException +toBotanException = toException . SomeBotanException + +fromBotanException :: Exception e => SomeException -> Maybe e +fromBotanException x = do + SomeBotanException a <- fromException x + cast a + +data InvalidVerifierException + = InvalidVerifierException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception InvalidVerifierException where + toException = toBotanException + fromException = fromBotanException + +data InvalidInputException + = InvalidInputException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception InvalidInputException where + toException = toBotanException + fromException = fromBotanException + +data BadMACException + = BadMACException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception BadMACException where + toException = toBotanException + fromException = fromBotanException + +data InsufficientBufferSpaceException + = InsufficientBufferSpaceException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception InsufficientBufferSpaceException where + toException = toBotanException + fromException = fromBotanException + +data StringConversionException + = StringConversionException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception StringConversionException where + toException = toBotanException + fromException = fromBotanException + +data ExceptionThrownException + = ExceptionThrownException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception ExceptionThrownException where + toException = toBotanException + fromException = fromBotanException + +data OutOfMemoryException + = OutOfMemoryException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception OutOfMemoryException where + toException = toBotanException + fromException = fromBotanException + +data SystemErrorException + = SystemErrorException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception SystemErrorException where + toException = toBotanException + fromException = fromBotanException + +data InternalErrorException + = InternalErrorException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception InternalErrorException where + toException = toBotanException + fromException = fromBotanException + +data BadFlagException + = BadFlagException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception BadFlagException where + toException = toBotanException + fromException = fromBotanException + +data NullPointerException + = NullPointerException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception NullPointerException where + toException = toBotanException + fromException = fromBotanException + +data BadParameterException + = BadParameterException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception BadParameterException where + toException = toBotanException + fromException = fromBotanException + +data KeyNotSetException + = KeyNotSetException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception KeyNotSetException where + toException = toBotanException + fromException = fromBotanException + +data InvalidKeyLengthException + = InvalidKeyLengthException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception InvalidKeyLengthException where + toException = toBotanException + fromException = fromBotanException + +data InvalidObjectStateException + = InvalidObjectStateException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception InvalidObjectStateException where + toException = toBotanException + fromException = fromBotanException + +data NotImplementedException + = NotImplementedException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception NotImplementedException where + toException = toBotanException + fromException = fromBotanException + +data InvalidObjectException + = InvalidObjectException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception InvalidObjectException where + toException = toBotanException + fromException = fromBotanException + +data UnknownException + = UnknownException BotanErrorCode ErrorMessage CallStack + deriving (Show) + +instance Exception UnknownException where + toException = toBotanException + fromException = fromBotanException + +{- +Throwing exceptions +-} + +throwBotanError :: HasCallStack => BotanErrorCode -> IO a +throwBotanError r = throwBotanErrorWithCallstack r callStack + +throwBotanIfNegative :: HasCallStack => IO BotanErrorCode -> IO BotanErrorCode +throwBotanIfNegative act = do + e <- act + when (e < 0) $ throwBotanErrorWithCallstack (fromIntegral e) callStack + return e + +throwBotanIfNegative_ :: HasCallStack => IO BotanErrorCode -> IO () +throwBotanIfNegative_ act = do + e <- act + when (e < 0) $ throwBotanErrorWithCallstack (fromIntegral e) callStack + +-- TODO: Rename to throwBotanCatchingInvalidIdentifier, make: +-- throwBotanCatchingSuccess :: HasCallStack => IO BotanErrorCode -> IO Bool +-- throwBotanCatchingSuccess act = do +-- result <- act +-- case result of +-- BOTAN_FFI_SUCCESS -> return True +-- _ -> throwBotanErrorWithCallstack (fromIntegral result) callStack +-- NOTE: Catches 0 / Success as True and 1 / InvalidIdentifier as False, throws all other values +throwBotanCatchingSuccess :: HasCallStack => IO BotanErrorCode -> IO Bool +throwBotanCatchingSuccess act = do + result <- act + case result of + BOTAN_FFI_SUCCESS -> return True + BOTAN_FFI_INVALID_VERIFIER -> return False + _ -> throwBotanErrorWithCallstack (fromIntegral result) callStack + +-- NOTE: Catches 1 as True and 0 as False, throws all other values +throwBotanCatchingBool :: HasCallStack => IO BotanErrorCode -> IO Bool +throwBotanCatchingBool act = do + result <- act + case result of + 0 -> return False + 1 -> return True + _ -> throwBotanErrorWithCallstack result callStack + + +-- NOTE: Catches positive numbers including zero, throws all other values +-- Equivalent to fromIntegral . throwBotanIfNegative +throwBotanCatchingInt :: HasCallStack => IO BotanErrorCode -> IO Int +throwBotanCatchingInt act = do + result <- act + when (result < 0) $ throwBotanErrorWithCallstack (fromIntegral result) callStack + return (fromIntegral result) + +throwBotanErrorWithCallstack :: BotanErrorCode -> CallStack -> IO a +throwBotanErrorWithCallstack e cs = do + emsg <- botanErrorLastExceptionMessage + case e of + -- BOTAN_FFI_SUCCESS -> throwIO $ SUCCESS e cs + BOTAN_FFI_INVALID_VERIFIER -> throwIO $ InvalidVerifierException e emsg cs + BOTAN_FFI_ERROR_INVALID_INPUT -> throwIO $ InvalidInputException e emsg cs + BOTAN_FFI_ERROR_BAD_MAC -> throwIO $ BadMACException e emsg cs + BOTAN_FFI_ERROR_INSUFFICIENT_BUFFER_SPACE -> throwIO $ InsufficientBufferSpaceException e emsg cs + BOTAN_FFI_ERROR_STRING_CONVERSION_ERROR -> throwIO $ StringConversionException e emsg cs + BOTAN_FFI_ERROR_EXCEPTION_THROWN -> throwIO $ ExceptionThrownException e emsg cs + BOTAN_FFI_ERROR_OUT_OF_MEMORY -> throwIO $ OutOfMemoryException e emsg cs + BOTAN_FFI_ERROR_SYSTEM_ERROR -> throwIO $ SystemErrorException e emsg cs + BOTAN_FFI_ERROR_INTERNAL_ERROR -> throwIO $ InternalErrorException e emsg cs + BOTAN_FFI_ERROR_BAD_FLAG -> throwIO $ BadFlagException e emsg cs + BOTAN_FFI_ERROR_NULL_POINTER -> throwIO $ NullPointerException e emsg cs + BOTAN_FFI_ERROR_BAD_PARAMETER -> throwIO $ BadParameterException e emsg cs + BOTAN_FFI_ERROR_KEY_NOT_SET -> throwIO $ KeyNotSetException e emsg cs + BOTAN_FFI_ERROR_INVALID_KEY_LENGTH -> throwIO $ InvalidKeyLengthException e emsg cs + BOTAN_FFI_ERROR_INVALID_OBJECT_STATE -> throwIO $ InvalidObjectStateException e emsg cs + BOTAN_FFI_ERROR_NOT_IMPLEMENTED -> throwIO $ NotImplementedException e emsg cs + BOTAN_FFI_ERROR_INVALID_OBJECT -> throwIO $ InvalidObjectException e emsg cs + _ -> throwIO $ UnknownException e emsg cs + +-- TODO: catchingBotan +-- r0 <- botan_foo +-- if r0 < 0 +-- then pure r0 +-- else do +-- r1 <- botan_bar + +tryBotan :: IO a -> IO (Either SomeBotanException a) +tryBotan = try + +catchBotan :: IO a -> (SomeBotanException -> IO a) -> IO a +catchBotan = catch + +handleBotan :: (SomeBotanException -> IO a) -> IO a -> IO a +handleBotan = flip catch diff --git a/src/Botan/Low/FPE.hs b/src/Botan/Low/FPE.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/FPE.hs @@ -0,0 +1,160 @@ +{-| +Module : Botan.Low.FPE +Description : Format Preserving Encryption +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +Format preserving encryption (FPE) refers to a set of techniques +for encrypting data such that the ciphertext has the same format +as the plaintext. For instance, you can use FPE to encrypt credit +card numbers with valid checksums such that the ciphertext is also +an credit card number with a valid checksum, or similarly for bank +account numbers, US Social Security numbers, or even more general +mappings like English words onto other English words. + +The scheme currently implemented in botan is called FE1, and described +in the paper Format Preserving Encryption by Mihir Bellare, Thomas +Ristenpart, Phillip Rogaway, and Till Stegers. FPE is an area of +ongoing standardization and it is likely that other schemes will be +included in the future. + +To encrypt an arbitrary value using FE1, you need to use a ranking +method. Basically, the idea is to assign an integer to every value +you might encrypt. For instance, a 16 digit credit card number consists +of a 15 digit code plus a 1 digit checksum. So to encrypt a credit card +number, you first remove the checksum, encrypt the 15 digit value modulo +1015, and then calculate what the checksum is for the new (ciphertext) +number. Or, if you were encrypting words in a dictionary, you could rank +the words by their lexicographical order, and choose the modulus to be +the number of words in the dictionary. +-} + +module Botan.Low.FPE +( + + FPE(..) +, FPEFlags(..) +, pattern FPENone +, pattern FPEFE1CompatMode +, withFPE +, fpeInitFE1 +, fpeDestroy +, fpeEncrypt +, fpeDecrypt + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.FPE + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.Remake + +-- NOTE: This module lacks documentation, and is not mentioned in the FFI bindings. +-- It is mentioned in the C++ docs, but the construction significantly differs. +-- I did find these functions in the actual header, and have implemented them as to my best guess +-- It is untested, pending an understanding of what the expected parameters are. +-- I think the FPE FFI is using the "original interface to FE1, first added in 1.9.17", +-- because they do not take a mac algo parameter, and may be hardcoded to "HMAC(SHA-256)" +-- SEE: https://botan.randombit.net/handbook/api_ref/fpe.html + +-- NOTE: Source indicates that the FPE1 mac_algo is using the default "HMAC(SHA-256)", and +-- that the option is not exposed to FFI. + +-- /** +-- * Format Preserving Encryption +-- */ + +newtype FPE = MkFPE { getFPEForeignPtr :: ForeignPtr BotanFPEStruct } + +newFPE :: BotanFPE -> IO FPE +withFPE :: FPE -> (BotanFPE -> IO a) -> IO a +fpeDestroy :: FPE -> IO () +createFPE :: (Ptr BotanFPE -> IO CInt) -> IO FPE +(newFPE, withFPE, fpeDestroy, createFPE, _) + = mkBindings + MkBotanFPE runBotanFPE + MkFPE getFPEForeignPtr + botan_fpe_destroy + +type FPEFlags = Word32 + +pattern FPENone + , FPEFE1CompatMode + :: FPEFlags +pattern FPENone = BOTAN_FPE_FLAG_NONE +pattern FPEFE1CompatMode = BOTAN_FPE_FLAG_FE1_COMPAT_MODE + +-- | Initialize a FE1 FPE context +fpeInitFE1 + :: MP -- ^ __n__ + -> ByteString -- ^ __key[]__ + -> Int -- ^ __rounds__ + -> FPEFlags -- ^ __flags__ + -> IO FPE -- ^ __fpe__ +fpeInitFE1 n key rounds flags = withMP n $ \ nPtr -> do + asBytesLen key $ \ keyPtr keyLen -> do + createFPE $ \ out -> botan_fpe_fe1_init + out + nPtr + (ConstPtr keyPtr) + keyLen + (fromIntegral rounds) + flags + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withFPEInitFE1 :: MP -> ByteString -> Int -> FPEFlags -> (FPE -> IO a) -> IO a +withFPEInitFE1 = mkWithTemp4 fpeInitFE1 fpeDestroy + +-- -- NOTE: Referentially transparent, move to botan +-- fpeEncrypt :: FPE -> MP -> ByteString -> IO MP +-- fpeEncrypt fpe mp tweak = do +-- mp' <- mpCopy mp +-- fpeEncrypt fpe mp' tweak +-- return mp + +-- | Encrypt the 'x' value in-place +-- +-- NOTE: Mutates the MP +fpeEncrypt + :: FPE -- ^ __fpe__ + -> MP -- ^ __x__ + -> ByteString -- ^ __tweak[]__ + -> IO () +fpeEncrypt fpe mp tweak = do + withFPE fpe $ \ fpePtr -> do + withMP mp $ \ mpPtr -> do + asBytesLen tweak $ \ tweakPtr tweakLen -> do + throwBotanIfNegative_ $ botan_fpe_encrypt fpePtr mpPtr (ConstPtr tweakPtr) tweakLen + +-- -- NOTE: Referentially transparent, move to botan +-- fpeDecrypt :: FPE -> MP -> ByteString -> IO MP +-- fpeDecrypt fpe mp tweak = do +-- mp' <- mpCopy mp +-- fpeDecrypt fpe mp' tweak +-- return mp + +-- | Decrypt the 'x' value in-place +-- +-- NOTE: Mutates the MP +fpeDecrypt + :: FPE -- ^ __fpe__ + -> MP -- ^ __x__ + -> ByteString -- ^ __tweak[]__ + -> IO () +fpeDecrypt fpe mp tweak = do + withFPE fpe $ \ fpePtr -> do + withMP mp $ \ mpPtr -> do + asBytesLen tweak $ \ tweakPtr tweakLen -> do + throwBotanIfNegative_ $ botan_fpe_decrypt fpePtr mpPtr (ConstPtr tweakPtr) tweakLen + +data FE1InitFlags + = FE1None -- BOTAN_FPE_FLAG_NONE + | FE1CompatMode -- BOTAN_FPE_FLAG_FE1_COMPAT_MODE diff --git a/src/Botan/Low/HOTP.hs b/src/Botan/Low/HOTP.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/HOTP.hs @@ -0,0 +1,241 @@ +{-| +Module : Botan.Low.HOTP +Description : Hash-based one-time passwords +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +One time password schemes are a user authentication method that +relies on a fixed secret key which is used to derive a sequence +of short passwords, each of which is accepted only once. Commonly +this is used to implement two-factor authentication (2FA), where +the user authenticates using both a conventional password (or a +public key signature) and an OTP generated by a small device such +as a mobile phone. +-} + +module Botan.Low.HOTP +( + +-- * Hash-based One Time Password +-- $introduction +-- * Usage +-- $usage + +-- * HOTP + + HOTP(..) +, HOTPHashName(..) +, HOTPCounter(..) +, HOTPCode(..) +, withHOTP +, hotpInit +, hotpDestroy +, hotpGenerate +, hotpCheck + +-- * HOTP Hashes + +, pattern HOTP_SHA1 +, pattern HOTP_SHA256 +, pattern HOTP_SHA512 + +-- * Convenience + +, hotpHashes + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.HOTP +import Botan.Low.Hash + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.Remake + +-- NOTE: RFC 4226 +-- NOTE: I think this *only* takes SHA-2, specificaly "SHA-256" and "SHA-512", +-- and probably because the RFC specifically uses it? + +{- $introduction + +Botan implements the HOTP and TOTP schemes from RFC 4226 and 6238. + +Since the range of possible OTPs is quite small, applications must +rate limit OTP authentication attempts to some small number per +second. Otherwise an attacker could quickly try all 1000000 6-digit +OTPs in a brief amount of time. + +HOTP generates OTPs that are a short numeric sequence, between 6 +and 8 digits (most applications use 6 digits), created using the +HMAC of a 64-bit counter value. If the counter ever repeats the +OTP will also repeat, thus both parties must assure the counter +only increments and is never repeated or decremented. Thus both +client and server must keep track of the next counter expected. + +Anyone with access to the client-specific secret key can authenticate +as that client, so it should be treated with the same security +consideration as would be given to any other symmetric key or +plaintext password. + +-} + +{- $usage + +> WARNING: Guarding against concurrent access to the stored counter is +> beyond the scope of this tutorial. + +To use HOTP for MFA / 2FA, the client authenticator must generate a +client-specific shared secret and counter value, and securely communicate +them to the server authenticator. + +The secret key may be any bytestring value with more than 160 bits, such as +a Bcrypt digest or SRP6 shared key. The counter value is not required to be +a secret; it may start at 0 for simplicity, or it may start at a value that +was selected at random. + +> import Botan.Low.HOTP +> import Botan.Low.RNG +> import Botan.Low.MPI +> import Data.Bits +> sharedSecret <- systemRNGGet 16 +> -- TODO: Use random:System.Random.Stateful.Uniform instead of MPI in `botan` +> (hi :: Word32) <- mpInit >>= \ w -> mpRandBits w rng 32 >> mpToWord32 w +> (lo :: Word32) <- mpInit >>= \ w -> mpRandBits w rng 32 >> mpToWord32 w +> (counter :: Word64) = shiftL (fromIntegral hi) 32 `xor` fromIntegral lo + +The client and server authenticators are now in a shared state, and any login +attempts from a new device may be authenticated using HOTP as MFA. + +A client has requested a new connection, and HOTP is being used as MFA/2FA to +authenticate their request. The server authenticator receives the client connection +request and initializes a HOTP session using the stored client-specific shared +secret, and then sends an authentication request to the client authenticator: + +> -- (serverSharedSecret, serverCounter) <- lookupServerSharedSecretAndCounter +> serverSession <- hotpInit serverSharedSecret HOTP_SHA512 8 +> -- sendMFAAuthenticationRequest + +The client authenticator receives the authentication request, generates a +client-side code, increments their counter, and displays the HOTP code to +the user: + +> -- (clientSharedSecret, clientCounter) <- lookupClientSharedSecretAndCounter +> clientSession <- hotpInit clientSharedSecret HOTP_SHA512 8 +> clientCode <- hotpGenerate clientSession clientCounter +> -- incrementAndPersistClientCounter +> -- displayClientCode clientCode + +> NOTE: The client authenticator is responsible for incrementing and persisting +> their own counter manually. + +The client then sends the client code to the server authenticator using the +unauthenticated / requested connection: + +> -- clientCode <- readClientCode +> -- sendMFAAuthenticationResponse clientCode + +The server authenticator receives the authentication response, and performs +a check of the key, with a resync range of R in case the client has generated +a few codes without logging in successfully: + +> -- serverClientCode <- didreceiveMFAAuthenticationResponse +> (isValid,nextCounter) <- hotpCheck serverSession serverClientCode serverCounter 10 +> persistClientCounter nextCounter + +> NOTE: The server authentication check returns an incremented and resynced +> counter which must be persisted manually. If the authentication check fails, +> the counter value is return unchanged. + +If the code is valid, then the signin may be completed on the new connection +as normal. + +The server should discontinue the session and refuse any new connections +to the account after T unsuccessful authentication attempts, where T < R. +The user should then be notified. + +-} + +newtype HOTP = MkHOTP { getHOTPForeignPtr :: ForeignPtr BotanHOTPStruct } + +newHOTP :: BotanHOTP -> IO HOTP +withHOTP :: HOTP -> (BotanHOTP -> IO a) -> IO a +hotpDestroy :: HOTP -> IO () +createHOTP :: (Ptr BotanHOTP -> IO CInt) -> IO HOTP +(newHOTP, withHOTP, hotpDestroy, createHOTP, _) + = mkBindings + MkBotanHOTP runBotanHOTP + MkHOTP getHOTPForeignPtr + botan_hotp_destroy + +type HOTPHashName = HashName + +pattern HOTP_SHA1 + , HOTP_SHA256 + , HOTP_SHA512 + :: HOTPHashName + +pattern HOTP_SHA1 = SHA1 +pattern HOTP_SHA256 = SHA256 +pattern HOTP_SHA512 = SHA512 + +-- TODO: Do any other hashes work? +hotpHashes = + [ HOTP_SHA1 + , HOTP_SHA256 + , HOTP_SHA512 + ] + +type HOTPCounter = Word64 +type HOTPCode = Word32 + +-- NOTE: Digits should be 6-8 +hotpInit + :: ByteString -- ^ __key[]__ + -> HashName -- ^ __hash_algo__ + -> Int -- ^ __digits__ + -> IO HOTP -- ^ __hotp__ +hotpInit key algo digits = asBytesLen key $ \ keyPtr keyLen -> do + asCString algo $ \ algoPtr -> do + createHOTP $ \ out -> botan_hotp_init + out + (ConstPtr keyPtr) + keyLen + (ConstPtr algoPtr) + (fromIntegral digits) + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withHOTPInit :: ByteString -> ByteString -> Int -> (HOTP -> IO a) -> IO a +withHOTPInit = mkWithTemp3 hotpInit hotpDestroy + +-- NOTE: User is responsible for incrementing counter at this level +hotpGenerate + :: HOTP -- ^ __hotp__ + -> HOTPCounter -- ^ __hotp_counter__ + -> IO HOTPCode -- ^ __hotp_code__ +hotpGenerate hotp counter = withHOTP hotp $ \ hotpPtr -> do + alloca $ \ outPtr -> do + throwBotanIfNegative $ botan_hotp_generate hotpPtr outPtr counter + peek outPtr + +-- NOTE: +-- "Returns a pair of (is_valid,next_counter_to_use). If the OTP is +-- invalid then always returns (false,starting_counter), since the +-- last successful authentication counter has not changed. "" +-- NOTE: "Depending on the environment a resync_range of 3 to 10 might be appropriate." +hotpCheck + :: HOTP -- ^ __hotp__ + -> HOTPCode -- ^ __hotp_code__ + -> HOTPCounter -- ^ __hotp_counter__ + -> Int -- ^ __resync_range__ + -> IO (Bool, HOTPCounter) -- ^ __(valid,next_counter)__ +hotpCheck hotp code counter resync = withHOTP hotp $ \ hotpPtr -> do + alloca $ \ outPtr -> do + valid <- throwBotanCatchingSuccess $ botan_hotp_check hotpPtr outPtr code counter (fromIntegral resync) + nextCounter <- peek outPtr + return (valid, nextCounter) diff --git a/src/Botan/Low/Hash.hs b/src/Botan/Low/Hash.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/Hash.hs @@ -0,0 +1,375 @@ +{-| +Module : Botan.Low.Hash +Description : Hash Functions and Checksums +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +Hash functions are one-way functions, which map data of arbitrary size +to a fixed output length. Most of the hash functions in Botan are designed +to be cryptographically secure, which means that it is computationally +infeasible to create a collision (finding two inputs with the same hash) +or preimages (given a hash output, generating an arbitrary input with the +same hash). But note that not all such hash functions meet their goals, +in particular MD4 and MD5 are trivially broken. However they are still +included due to their wide adoption in various protocols. + +Using a hash function is typically split into three stages: initialization, +update, and finalization (often referred to as a IUF interface). The +initialization stage is implicit: after creating a hash function object, +it is ready to process data. Then update is called one or more times. +Calling update several times is equivalent to calling it once with all of +the arguments concatenated. After completing a hash computation (eg using +hashFinal), the internal state is reset to begin hashing a new message. +-} + +module Botan.Low.Hash +( + +-- * Hashing +-- $introduction + +-- * Usage +-- $usage + + Hash(..) +, HashName(..) +, HashDigest(..) +, withHash +, hashInit +, hashDestroy +, hashName +, hashBlockSize +, hashOutputLength +, hashCopyState +, hashUpdate +, hashFinal +, hashUpdateFinalize +, hashUpdateFinalizeClear +, hashClear + +-- * Hash algorithms + +, pattern BLAKE2b +, blake2b +, pattern Keccak1600 +, keccak1600 +, pattern GOST_34_11 +, pattern MD4 +, pattern MD5 +, pattern RIPEMD160 +, pattern SHA1 +, pattern SHA224 +, pattern SHA256 +, pattern SHA384 +, pattern SHA512 +, pattern SHA512_256 +, pattern SHA3 +, sha3 +, pattern SHAKE128 +, shake128 +, pattern SHAKE256 +, shake256 +, pattern SM3 +, pattern Skein512 +, skein512 +, pattern Streebog256 +, pattern Streebog512 +, pattern Whirlpool +, pattern Parallel +, pattern Comb4P +, pattern Adler32 +, pattern CRC24 +, pattern CRC32 + +-- * Convenience + +, cryptohashes +, checksums +, allHashes + +) where + +import qualified Data.ByteString as ByteString + +import System.IO.Unsafe + +import Botan.Bindings.Hash + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.Remake + +{- $introduction + +A `hash` is deterministic, one-way function suitable for producing a +deterministic, fixed-size digest from an arbitrarily-sized message, which is +used to verify the integrity of the data. + +-} + +{- $usage + +Unless you need a specific `hash`, it is strongly recommended that you use the `SHA3` algorithm. + +> import Botan.Low.Hash +> hash <- hashInit SHA3 +> message = "Fee fi fo fum!" +> hashUpdate hash message +> digest <- hashFinal hash + +You can verify a digest by hashing the message a second time, and comparing the two: + +> rehash <- hashInit SHA3 +> hashUpdate rehash message +> redigest <- hashFinal rehash +> digest == redigest -- True + +You can clear a hash's state, leaving it ready for reuse: + +> hashClear hash +> -- Process another message +> hashUpdate hash anotherMessage +> anotherDigest <- hashFinal hash + +-} + +newtype Hash = MkHash { getHashForeignPtr :: ForeignPtr BotanHashStruct } + +newHash :: BotanHash -> IO Hash +withHash :: Hash -> (BotanHash -> IO a) -> IO a +hashDestroy :: Hash -> IO () +createHash :: (Ptr BotanHash -> IO CInt) -> IO Hash +(newHash, withHash, hashDestroy, createHash, _) + = mkBindings + MkBotanHash runBotanHash + MkHash getHashForeignPtr + botan_hash_destroy + +type HashName = ByteString + +pattern BLAKE2b + , Keccak1600 + , GOST_34_11 + , MD4 + , MD5 + , RIPEMD160 + , SHA1 + , SHA224 + , SHA256 + , SHA384 + , SHA512 + , SHA512_256 + , SHA3 + , SHAKE128 + , SHAKE256 + , SM3 + , Skein512 + , Streebog256 + , Streebog512 + , Whirlpool + , Parallel + , Comb4P + , Adler32 + , CRC24 + , CRC32 + :: HashName + +pattern BLAKE2b = BOTAN_HASH_BLAKE2B +-- TODO: function +-- sz is digest size in bits, must be 1-64 bytes, eg: 8-512 in multiples of 8 +blake2b sz | sz <= 512 = BLAKE2b /$ showBytes sz +blake2b _ = error "Invalid BLAKE2b variant" +pattern Keccak1600 = BOTAN_HASH_KECCAK_1600 +-- TODO: function or pattern +keccak1600 n | n `elem` [224, 256, 384, 512] = Keccak1600 /$ showBytes n +keccak1600 _ = error "Invalid Keccak-1600 variant" +-- pattern Keccak1600_224 = "Keccak-1600(224)" +-- pattern Keccak1600_256 = "Keccak-1600(256)" +-- pattern Keccak1600_384 = "Keccak-1600(384)" +-- pattern Keccak1600_512 = "Keccak-1600(512)" +pattern GOST_34_11 = BOTAN_HASH_GOST_34_11 +pattern MD4 = BOTAN_HASH_MD4 +pattern MD5 = BOTAN_HASH_MD5 +pattern RIPEMD160 = BOTAN_HASH_RIPEMD_160 +pattern SHA1 = BOTAN_HASH_SHA1 +pattern SHA224 = BOTAN_HASH_SHA_224 +pattern SHA256 = BOTAN_HASH_SHA_256 +pattern SHA384 = BOTAN_HASH_SHA_384 +pattern SHA512 = BOTAN_HASH_SHA_512 +pattern SHA512_256 = BOTAN_HASH_SHA_512_256 +pattern SHA3 = BOTAN_HASH_SHA_3 +-- TODO: function or pattern +sha3 n | n `elem` [224, 256, 384, 512] = SHA3 /$ showBytes n +sha3 _ = error "Invalid SHA-3 variant" +-- pattern SHA3_224 = "SHA-3(224)" +-- pattern SHA3_256 = "SHA-3(256)" +-- pattern SHA3_384 = "SHA-3(384)" +-- pattern SHA3_512 = "SHA-3(512)" +pattern SHAKE128 = BOTAN_HASH_SHAKE_128 +-- TODO: function +shake128 sz = SHAKE128 /$ showBytes sz +pattern SHAKE256 = BOTAN_HASH_SHAKE_256 +-- TODO: function +shake256 sz = SHAKE256 /$ showBytes sz +pattern SM3 = BOTAN_HASH_SM3 +pattern Skein512 = BOTAN_HASH_SKEIN_512 +-- TODO: function +skein512 sz salt = Skein512 /$ showBytes sz <> "," <> salt +pattern Streebog256 = BOTAN_HASH_STREEBOG_256 +pattern Streebog512 = BOTAN_HASH_STREEBOG_512 +pattern Whirlpool = BOTAN_HASH_WHIRLPOOL +pattern Parallel = BOTAN_HASH_STRAT_PARALLEL +-- TODO: function +-- parallel a b = Parallel /$ a <> "," <> b +-- TODO: function +-- comb4P a b = Comb4P /$ a <> "," <> b +pattern Comb4P = BOTAN_HASH_STRAT_COMB4P +pattern Adler32 = BOTAN_CHECKSUM_ADLER32 +pattern CRC24 = BOTAN_CHECKSUM_CRC24 +pattern CRC32 = BOTAN_CHECKSUM_CRC32 + +cryptohashes :: [HashName] +cryptohashes = + [ BLAKE2b + -- , "BLAKE2b(128)" + -- , "BLAKE2b(256)" + -- , "BLAKE2b(512)" + , GOST_34_11 + , Keccak1600 + -- , "Keccak-1600(224)" + -- , "Keccak-1600(256)" + -- , "Keccak-1600(384)" + -- , "Keccak-1600(512)" + , MD4 + , MD5 + , RIPEMD160 + , SHA1 + , SHA224 + , SHA256 + , SHA384 + , SHA512 + , SHA512_256 + , SHA3 + -- , "SHA-3(224)" + -- , "SHA-3(256)" + -- , "SHA-3(384)" + -- , "SHA-3(512)" + -- NOTE: SHAKE-128 has no default value, a parameter *MUST* be supplied + , shake128 128 + -- , "SHAKE-128(128)" + -- , "SHAKE-128(256)" + -- , "SHAKE-128(512)" + -- NOTE: SHAKE-256 has no default value, a parameter *MUST* be supplied + , shake256 128 + -- , "SHAKE-256(128)" + -- , "SHAKE-256(256)" + -- , "SHAKE-256(512)" + , SM3 + , Skein512 + -- , "Skein-512(128)" + -- , "Skein-512(256)" + -- , "Skein-512(512)" + , Streebog256 + , Streebog512 + , Whirlpool + ] + +-- TODO: +-- hashStrategies :: [HashName] +-- hashStrategies = undefined + +checksums = + [ Adler32 + , CRC24 + , CRC32 + ] + +allHashes = cryptohashes ++ checksums + +type HashDigest = ByteString + +hashInit + :: HashName -- ^ __hash_name__: name of the hash function, e.g., "SHA-384" + -> IO Hash -- ^ __hash__: hash object +hashInit = mkCreateObjectCString createHash (\ out name -> botan_hash_init out name 0) + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withHashInit :: HashName -> (Hash -> IO a) -> IO a +withHashInit = mkWithTemp1 hashInit hashDestroy + +hashName + :: Hash -- ^ __hash__: the object to read + -> IO HashDigest -- ^ __name__: output buffer +hashName = mkGetCString withHash botan_hash_name + +-- NOTE: This does the correct thing - see C++ docs: +-- Return a newly allocated HashFunction object of the same type as this one, +-- whose internal state matches the current state of this. + +hashCopyState + :: Hash -- ^ __source__: source hash object + -> IO Hash -- ^ __dest__: destination hash object +hashCopyState source = withHash source $ \ sourcePtr -> do + createHash $ \ dest -> botan_hash_copy_state dest sourcePtr + +hashClear + :: Hash -- ^ __hash__: hash object + -> IO () +hashClear = mkAction withHash botan_hash_clear + +hashBlockSize + :: Hash -- ^ __hash__: hash object + -> IO Int -- ^ __block_size__: output buffer to hold the hash function block size +hashBlockSize = mkGetSize withHash botan_hash_block_size + +hashOutputLength + :: Hash -- ^ __hash__: hash object + -> IO Int -- ^ __block_size__: output buffer to hold the hash function output length +hashOutputLength = mkGetSize withHash botan_hash_output_length + +hashUpdate + :: Hash -- ^ __hash__: hash object + -> ByteString -- ^ __in__: input buffer + -> IO () +hashUpdate = mkWithObjectSetterCBytesLen withHash botan_hash_update + +hashFinal + :: Hash -- ^ __hash__: hash object + -> IO HashDigest -- ^ __out[]__: output buffer +hashFinal hash = withHash hash $ \ hashPtr -> do + sz <- hashOutputLength hash + allocBytes sz $ \ digestPtr -> do + throwBotanIfNegative_ $ botan_hash_final hashPtr digestPtr + +-- TODO: +-- pkcsHashId +-- :: ByteString -- ^ __hash_name__ +-- -> IO ByteString -- ^ __pkcs_id[]__ +-- pkcsHashId = undefined + + +-- Convenience + +hashUpdateFinalize :: Hash -> ByteString -> IO HashDigest +hashUpdateFinalize ctx bytes = do + hashUpdate ctx bytes + hashFinal ctx + +hashUpdateFinalizeClear :: Hash -> ByteString -> IO HashDigest +hashUpdateFinalizeClear ctx bytes = do + dg <- hashUpdateFinalize ctx bytes + hashClear ctx + return dg +-- Or: hashUpdateFinalize ctx bytes <* hashClear ctx + +hashWithHash :: Hash -> ByteString -> IO HashDigest +hashWithHash = hashUpdateFinalizeClear + +hashWithName :: HashName -> ByteString -> IO HashDigest +hashWithName name bytes = do + ctx <- hashInit name + hashWithHash ctx bytes diff --git a/src/Botan/Low/KDF.hs b/src/Botan/Low/KDF.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/KDF.hs @@ -0,0 +1,166 @@ +{-| +Module : Botan.Low.KDF +Description : Key Derivation Functions (KDF) +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +Key derivation functions are used to turn some amount of shared +secret material into uniform random keys suitable for use with +symmetric algorithms. An example of an input which is useful for +a KDF is a shared secret created using Diffie-Hellman key agreement. + +Typically a KDF is also used with a salt and a label. The salt should +be some random information which is available to all of the parties +that would need to use the KDF; this could be performed by setting +the salt to some kind of session identifier, or by having one of the +parties generate a random salt and including it in a message. + +The label is used to bind the KDF output to some specific context. For +instance if you were using the KDF to derive a specific key referred to +as the “message key” in the protocol description, you might use a label +of “FooProtocol v2 MessageKey”. This labeling ensures that if you +accidentally use the same input key and salt in some other context, you +still use different keys in the two contexts. +-} + +module Botan.Low.KDF +( + +-- * Key derivation function + + KDFName(..) +, kdf + +-- * KDF algorithms + +, pattern HKDF +, hkdf +, pattern HKDF_Extract +, hkdf_extract +, pattern HKDF_Expand +, hkdf_expand +, pattern KDF2 +, kdf2 +, pattern KDF1_18033 +, kdf1_18033 +, pattern KDF1 +, kdf1 +, pattern TLS_12_PRF +, tls_12_prf +, pattern X9_42_PRF +, x9_42_prf +, pattern SP800_108_Counter +, sp800_108_counter +, pattern SP800_108_Feedback +, sp800_108_feedback +, pattern SP800_108_Pipeline +, sp800_108_pipeline +, pattern SP800_56A +, sp800_56A +, pattern SP800_56C +, sp800_56C + +-- * Convenience + +, kdfs + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.KDF + +import Botan.Low.Hash +import Botan.Low.MAC +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude + +type KDFName = ByteString + +pattern HKDF + , HKDF_Extract + , HKDF_Expand + , KDF2 + , KDF1_18033 + , KDF1 + , TLS_12_PRF + , X9_42_PRF + , SP800_108_Counter + , SP800_108_Feedback + , SP800_108_Pipeline + , SP800_56A + , SP800_56C + :: KDFName + +pattern HKDF = BOTAN_KDF_HKDF +pattern HKDF_Extract = BOTAN_KDF_HKDF_EXTRACT +pattern HKDF_Expand = BOTAN_KDF_HKDF_EXPAND +pattern KDF2 = BOTAN_KDF_KDF2 +pattern KDF1_18033 = BOTAN_KDF_KDF1_18033 +pattern KDF1 = BOTAN_KDF_KDF1 +pattern TLS_12_PRF = BOTAN_KDF_TLS_12_PRF +pattern X9_42_PRF = BOTAN_KDF_X9_42_PRF +pattern SP800_108_Counter = BOTAN_KDF_SP800_108_COUNTER +pattern SP800_108_Feedback = BOTAN_KDF_SP800_108_FEEDBACK +pattern SP800_108_Pipeline = BOTAN_KDF_SP800_108_PIPELINE +pattern SP800_56A = BOTAN_KDF_SP800_56A +pattern SP800_56C = BOTAN_KDF_SP800_56C + +hkdf :: HashName -> KDFName +hkdf h = HKDF /$ h +hkdf_extract h = HKDF_Extract /$ h +hkdf_expand h = HKDF_Expand /$ h +kdf2 h = KDF2 /$ h +kdf1_18033 h = KDF1_18033 /$ h +kdf1 h = KDF1 /$ h +tls_12_prf h = TLS_12_PRF /$ h +x9_42_prf h = X9_42_PRF /$ h +sp800_108_counter h = SP800_108_Counter /$ HMAC /$ h +sp800_108_feedback h = SP800_108_Feedback /$ HMAC /$ h +sp800_108_pipeline h = SP800_108_Pipeline /$ HMAC /$ h +sp800_56A h = SP800_56A /$ HMAC /$ h +sp800_56C h = SP800_56C /$ HMAC /$ h + +kdfs = concat + [ [ hkdf h | h <- cryptohashes ] + , [ hkdf_extract h | h <- cryptohashes ] + , [ hkdf_expand h | h <- cryptohashes ] + , [ kdf2 h | h <- allHashes ] + , [ kdf1_18033 h | h <- allHashes ] + , [ kdf1 h | h <- allHashes ] + , [ tls_12_prf h | h <- cryptohashes ] + , [ x9_42_prf SHA1 ] + , [ sp800_108_counter h | h <- cryptohashes ] + , [ sp800_108_feedback h | h <- cryptohashes ] + , [ sp800_108_pipeline h | h <- cryptohashes ] + , [ sp800_56A h | h <- cryptohashes ] + , [ sp800_56C h | h <- cryptohashes ] + ] + +-- SEE: Algos here: https://botan.randombit.net/doxygen/classBotan_1_1KDF.html +kdf + :: KDFName -- ^ __kdf_algo__: KDF algorithm, e.g., "SP800-56C" + -> Int -- ^ __out_len__: the desired output length in bytes + -> ByteString -- ^ __secret[]__: the secret input + -> ByteString -- ^ __salt[]__: a diversifier + -> ByteString -- ^ __label[]__: purpose for the derived keying material + -> IO ByteString -- ^ __out[]__: buffer holding the derived key +kdf algo outLen secret salt label = allocBytes outLen $ \ outPtr -> do + asCString algo $ \ algoPtr -> do + asBytesLen secret $ \ secretPtr secretLen -> do + asBytesLen salt $ \ saltPtr saltLen -> do + asBytesLen label $ \ labelPtr labelLen -> do + throwBotanIfNegative_ $ botan_kdf + (ConstPtr algoPtr) + outPtr + (fromIntegral outLen) + (ConstPtr secretPtr) + secretLen + (ConstPtr saltPtr) + saltLen + (ConstPtr labelPtr) + labelLen diff --git a/src/Botan/Low/KeyWrap.hs b/src/Botan/Low/KeyWrap.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/KeyWrap.hs @@ -0,0 +1,77 @@ +{-| +Module : Botan.Low.KeyWrap +Description : Bcrypt password hashing +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +NIST specifies two mechanisms for wrapping (encrypting) symmetric keys +using another key. The first (and older, more widely supported) method +requires the input be a multiple of 8 bytes long. The other allows any +length input, though only up to 2**32 bytes. + +These algorithms are described in NIST SP 800-38F, and RFCs 3394 and 5649. + +These functions take an arbitrary 128-bit block cipher. NIST only allows +these functions with AES, but any 128-bit cipher will do and some other +implementations (such as in OpenSSL) do also allow other ciphers. + +Use AES for best interop. +-} + +module Botan.Low.KeyWrap +( + + nistKeyWrapEncode +, nistKeyWrapDecode + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.KeyWrap + +import Botan.Low.BlockCipher +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude + +nistKeyWrapEncode + :: BlockCipherName -- ^ __cipher_algo__ + -> Int -- ^ __padded__ + -> ByteString -- ^ __key[]__ + -> ByteString -- ^ __kek[]__ + -> IO ByteString -- ^ __wrapped_key[]__ +nistKeyWrapEncode algo padded key kek = asCString algo $ \ algoPtr -> do + asBytesLen key $ \ keyPtr keyLen -> do + asBytesLen kek $ \ kekPtr kekLen -> do + allocBytesQuerying $ \ wrappedKeyPtr wrappedKeyLen -> botan_nist_kw_enc + (ConstPtr algoPtr) + (fromIntegral padded) + (ConstPtr keyPtr) + keyLen + (ConstPtr kekPtr) + kekLen + wrappedKeyPtr + wrappedKeyLen + +nistKeyWrapDecode + :: BlockCipherName -- ^ __cipher_algo__ + -> Int -- ^ __padded__ + -> ByteString -- ^ __wrapped_key[]__ + -> ByteString -- ^ __kek[]__ + -> IO ByteString -- ^ __key[]__ +nistKeyWrapDecode algo padded wrappedKey kek = asCString algo $ \ algoPtr -> do + asBytesLen wrappedKey $ \ wrappedKeyPtr wrappedKeyLen -> do + asBytesLen kek $ \ kekPtr kekLen -> do + allocBytesQuerying $ \ keyPtr keyLen -> botan_nist_kw_dec + (ConstPtr algoPtr) + (fromIntegral padded) + (ConstPtr wrappedKeyPtr) + wrappedKeyLen + (ConstPtr kekPtr) + kekLen + keyPtr + keyLen diff --git a/src/Botan/Low/MAC.hs b/src/Botan/Low/MAC.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/MAC.hs @@ -0,0 +1,307 @@ +{-| +Module : Botan.Low.MAC +Description : Message Authentication Codes (MAC) +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +A Message Authentication Code algorithm computes a tag over a +message utilizing a shared secret key. Thus a valid tag confirms +the authenticity and integrity of the message. Only entities in +possession of the shared secret key are able to verify the tag. + +Note + +When combining a MAC with unauthenticated encryption mode, prefer +to first encrypt the message and then MAC the ciphertext. The +alternative is to MAC the plaintext, which depending on exact usage +can suffer serious security issues. For a detailed discussion of +this issue see the paper “The Order of Encryption and Authentication +for Protecting Communications” by Hugo Krawczyk + +The Botan MAC computation is split into five stages. + +- Instantiate the MAC algorithm. + +- Set the secret key. + +- Process IV. + +- Process data. + +- Finalize the MAC computation. +-} + +module Botan.Low.MAC +( + +-- * Message authentication codes +-- $introduction + +-- * Usage +-- $usage + + MAC(..) +, MACName(..) +, MACKey(..) +, MACNonce(..) +, MACDigest(..) +, withMAC +, macInit +, macDestroy +, macName +, macOutputLength +, macGetKeyspec +, macSetKey +, macSetNonce +, macUpdate +, macFinal +, macClear + +-- * MAC algorithms + +, pattern CMAC +, cmac +, pattern GMAC +, gmac +, pattern HMAC +, hmac +, pattern Poly1305 +, pattern SipHash +, sipHash +, pattern X9_19_MAC + +-- * Convenience + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.MAC + +import Botan.Low.BlockCipher +import Botan.Low.Error +import Botan.Low.Hash +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.Remake + +{- $introduction + +A `mac` (or message authentication code) is a cryptographic algorithm that uses +a secret key to produce a fixed-size digest from an arbitrarily-sized message, +which is then used to verify the integrity and authenticity of the data. + +-} + +{- $usage + +Unless you need a specific `mac`, it is strongly recommended that you use the +`hmac SHA3` algorithm. + +> import Botan.Low.MAC +> import Botan.Low.Hash +> mac <- macInit (hmac SHA3) + +To use a MAC, we first need to generate (if we haven't already) a secret key. + +> import Botan.Low.RNG +> rng <- rngInit "user" +> -- HMAC allows for an arbitrary key size, but we can check the key spec. +> (keyMin,keyMax,keyMod) <- macGetKeyspec mac +> -- MAC are randomly generated; 32 bytes is acceptable +> key <- rngGet rng 32 + +After the key is generated, we must set it as the mac key: + +> macSetKey mac key + +Then, we may produce an authentication code from a message using the secret key: + +> macUpdate mac "Fee fi fo fum!" +> auth <- macFinal mac + +To verify an message authentication code, we can reproduce it using the secret +key and message, and then check for equality: + +> verify <- macInit (hmac SHA3) +> macSetKey verify key +> macUpdate verify "Fee fi fo fum!" +> verifyAuth <- macFinal verify +> auth == verifyAuth -- True + +You can completely clear a mac's state, leaving it ready for reuse: + +> macClear mac +> -- You'll have to set the key again +> macSetKey mac anotherKey +> -- Process another message +> macUpdate mac anotherMessage +> anotherAuth <- macFinal mac + +Some algorithms (GMAC, Poly1305) have additional requirements for use. Avoid if +possible, and consult algorithm-specific documentation for GMAC and Poly1305. +If you must use GMAC, a nonce needs to be set: + +> mac <- macInit (gmac AES256) +> k <- systemRNGGet 32 +> n <- systemRNGGet 32 -- Here +> macSetKey mac k +> macSetNonce mac n -- Here +> macUpdate mac "Fee fi fo fum!" +> auth <- macFinal mac + +-} + +-- /* +-- * Message Authentication type +-- */ + +newtype MAC = MkMAC { getMACForeignPtr :: ForeignPtr BotanMACStruct } + +newMAC :: BotanMAC -> IO MAC +withMAC :: MAC -> (BotanMAC -> IO a) -> IO a +macDestroy :: MAC -> IO () +createMAC :: (Ptr BotanMAC -> IO CInt) -> IO MAC +(newMAC, withMAC, macDestroy, createMAC, _) + = mkBindings + MkBotanMAC runBotanMAC + MkMAC getMACForeignPtr + botan_mac_destroy + +type MACName = ByteString + +pattern CMAC + , GMAC + -- , CBC_MAC + , HMAC + -- , KMAC_128 + -- , KMAC_256 + , Poly1305 + , SipHash + , X9_19_MAC + :: MACName + +pattern CMAC = BOTAN_MAC_CMAC +pattern GMAC = BOTAN_MAC_GMAC +-- pattern CBC_MAC = BOTAN_MAC_CBC_MAC +pattern HMAC = BOTAN_MAC_HMAC +-- pattern KMAC_128 = BOTAN_MAC_KMAC_128 +-- pattern KMAC_256 = BOTAN_MAC_KMAC_256 +pattern Poly1305 = BOTAN_MAC_Poly1305 +pattern SipHash = BOTAN_MAC_SipHash +pattern X9_19_MAC = BOTAN_MAC_X9_19_MAC + +cmac :: BlockCipherName -> MACName +cmac bc = CMAC /$ bc + +gmac :: BlockCipherName -> MACName +gmac bc = GMAC /$ bc + +-- cbc_mac :: BlockCipherName -> MACName +-- cbc_mac bc = CBC_MAC /$ bc + +hmac :: BlockCipherName -> MACName +hmac h = HMAC /$ h + +-- kmac_128 :: BlockCipherName -> MACName +-- kmac_128 = ... + +-- kmac_256 :: BlockCipherName -> MACName +-- kmac_256 = ... + +sipHash :: Int -> Int -> MACName +sipHash ir fr = SipHash /$ showBytes ir <> "," <> showBytes fr + + +type MACKey = ByteString +type MACNonce = ByteString + +-- TODO: Rename MACTag? +type MACDigest = ByteString + +-- | Initialize a message authentication code object +macInit + :: MACName -- ^ __mac_name__: name of the hash function, e.g., "HMAC(SHA-384)" + -> IO MAC -- ^ __mac__: mac object +macInit = mkCreateObjectCString createMAC (\ out name -> botan_mac_init out name 0) + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withMACInit :: MACName -> (MAC -> IO a) -> IO a +withMACInit = mkWithTemp1 macInit macDestroy + +-- | Writes the output length of the message authentication code to *output_length +macOutputLength + :: MAC -- ^ __mac__: mac object + -> IO Int -- ^ __output_length__: output buffer to hold the MAC output length +macOutputLength = mkGetSize withMAC botan_mac_output_length + +-- | Sets the key on the MAC +macSetKey + :: MAC -- ^ __mac__: mac object + -> ByteString -- ^ __key__: buffer holding the key + -> IO () +macSetKey = mkWithObjectSetterCBytesLen withMAC botan_mac_set_key + +-- NOTE: Not all MACs require a nonce +-- Eg, GMAC requires a nonce +-- Other MACs do not require a nonce, and will cause a BadParameterException (-32) +-- | Sets the nonce on the MAC +macSetNonce + :: MAC -- ^ __mac__: mac object + -> ByteString -- ^ __nonce__: buffer holding the nonce + -> IO () +macSetNonce = mkWithObjectSetterCBytesLen withMAC botan_mac_set_nonce + +-- | Send more input to the message authentication code +macUpdate + :: MAC -- ^ __mac__: mac object + -> ByteString -- ^ __buf__: input buffer + -> IO () +macUpdate = mkWithObjectSetterCBytesLen withMAC botan_mac_update + +-- TODO: Digest type +{- | +Finalizes the MAC computation and writes the output to +out[0:botan_mac_output_length()] then reinitializes for computing +another MAC as if botan_mac_clear had been called. +-} +macFinal + :: MAC -- ^ __mac__: mac object + -> IO MACDigest -- ^ __out[]__: output buffer +macFinal mac = withMAC mac $ \ macPtr -> do + -- sz <- alloca $ \ szPtr -> do + -- throwBotanIfNegative_ $ botan_mac_output_length macPtr szPtr + -- fromIntegral <$> peek szPtr + sz <- macOutputLength mac + allocBytes sz $ \ bytesPtr -> do + throwBotanIfNegative_ $ botan_mac_final macPtr bytesPtr + +{- | +Reinitializes the state of the MAC computation. A MAC can +be computed (with update/final) immediately. +-} +macClear + :: MAC -- @mac@: mac object + -> IO () +macClear = mkAction withMAC botan_mac_clear + +-- | Get the name of this MAC +macName + :: MAC -- ^ __mac__: the object to read + -> IO ByteString -- ^ __name__: output buffer +macName = mkGetCString withMAC botan_mac_name + +-- | Get the key length limits of this auth code +macGetKeyspec + :: MAC -- ^ __mac__: the object to read + -> IO (Int,Int,Int) -- ^ __(min,max,mod)__: minimum maximum and modulo keylength of MAC +macGetKeyspec = mkGetSizes3 withMAC botan_mac_get_keyspec + +-- TODO: MAC does not have a nonce size query, and it relies on per-algorithm knowledgre +-- Luckily only 1 MAC actually requires a nonce (GMAC), so this isn't really an issue +-- macGetNoncespec :: MAC -> IO (Int,Int,Int) +-- Or +-- macGetDefaultNonceLength :: MAC -> IO Int diff --git a/src/Botan/Low/MPI.hs b/src/Botan/Low/MPI.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/MPI.hs @@ -0,0 +1,307 @@ +{-| +Module : Botan.Low.MPI +Description : Multiple Precision Integers +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.MPI +( + + MP(..) +, withMP +, mpInit +, mpDestroy +, mpToHex +, mpToStr +, mpClear +, mpSetFromInt +, mpSetFromMP +, mpCopy +, mpSetFromStr +, mpSetFromRadixStr +, mpNumBits +, mpNumBytes +, mpToBin +, mpFromBin +, mpToWord32 +, mpIsPositive +, mpIsNegative +, mpFlipSign +, mpIsZero +, mpAddWord32 +, mpSubWord32 +, mpAdd +, mpSub +, mpMul +, mpDiv +, mpModMul +, mpEqual +, mpCmp +, mpSwap +, mpPowMod +, mpLeftShift +, mpRightShift +, mpModInverse +, mpRandBits +, mpRandRange +, mpGCD +, mpIsPrime +, mpGetBit +, mpSetBit +, mpClearBit + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.MPI + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.Remake +import Botan.Low.RNG + +-- Yes, the module is named MPI, but the type is MP. +-- I'm probably renaming the module / type to `Botan.Integer` for ergonomics, +-- like I did with `Botan.RNG`. + +-- NOTE: Operations have a different format here, compared to other botan objects. +-- Botan.Make does not apply very well. +-- MPI are rarely mutated, and usually take a destination argument instead. +-- As such, there are some mk- functions specific to MPI, and this module +-- will be greatly improved by idiomatic bindings wrappers + +-- NOTE: This whole module is not idiomatic - some methods mutate, some have a destination argument +-- It will need furter wrapping. + +newtype MP = MkMP { getMPForeignPtr :: ForeignPtr BotanMPStruct } + +newMP :: BotanMP -> IO MP +withMP :: MP -> (BotanMP -> IO a) -> IO a +mpDestroy :: MP -> IO () +createMP :: (Ptr BotanMP -> IO CInt) -> IO MP +(newMP, withMP, mpDestroy, createMP, _) + = mkBindings + MkBotanMP runBotanMP + MkMP getMPForeignPtr + botan_mp_destroy + +mpInit :: IO MP +-- mpInit = mkInit MkMP botan_mp_init botan_mp_destroy +mpInit = createMP botan_mp_init + +-- NOTE: The actual botan_mp_to_hex is misleading +-- The actual buffer size is 2 + (num_bytes * 2) + 1 bytes in length +-- The leading 2 is `0x` prefix, the trailing 1 is `\0` suffix +mpToHex :: MP -> IO ByteString +mpToHex mp = withMP mp $ \ mpPtr -> do + numBytes <- mpNumBytes mp + allocaBytes (2 + (numBytes * 2) + 1) $ \ bytesPtr -> do + throwBotanIfNegative_ $ botan_mp_to_hex mpPtr bytesPtr + ByteString.packCString bytesPtr + +mpToStr :: MP -> Int -> IO ByteString +mpToStr mp base = withMP mp $ \ mpPtr -> do + allocBytesQueryingCString $ \ bytesPtr szPtr -> + botan_mp_to_str mpPtr (fromIntegral base) bytesPtr szPtr + +mpClear :: MP -> IO () +mpClear = mkAction withMP botan_mp_clear + +mpSetFromInt :: MP -> Int -> IO () +mpSetFromInt = mkSetCInt withMP botan_mp_set_from_int + +mpSetFromMP :: MP -> MP -> IO () +mpSetFromMP = mkUnaryOp withMP botan_mp_set_from_mp + +-- NOTE: Convenience function +mpCopy :: MP -> IO MP +mpCopy mp = do + copy <- mpInit + mpSetFromMP copy mp + return copy + +mpSetFromStr :: MP -> ByteString -> IO () +mpSetFromStr = mkSetCString withMP (\ mp cstr -> botan_mp_set_from_str mp (ConstPtr cstr)) + +-- NOTE: According to unit tests, this function *does not* prepend "0x" to the value +mpSetFromRadixStr :: MP -> ByteString -> Int -> IO () +mpSetFromRadixStr = mkSetCString_csize withMP (\ mp cstr radix -> botan_mp_set_from_radix_str mp (ConstPtr cstr) radix) + +mpNumBits :: MP -> IO Int +mpNumBits = mkGetSize withMP botan_mp_num_bits + +mpNumBytes :: MP -> IO Int +mpNumBytes = mkGetSize withMP botan_mp_num_bytes + +mpToBin :: MP -> IO ByteString +mpToBin mp = withMP mp $ \ mpPtr -> do + numBytes <- mpNumBytes mp + allocBytes numBytes $ \ bytesPtr -> do + throwBotanIfNegative_ $ botan_mp_to_bin mpPtr bytesPtr + +-- NOTE: Awkward, more like mpSetFromBin +-- When we wrap it in higher level, fromBin should be :: ByteString -> IO Integer +mpFromBin :: MP -> ByteString -> IO () +mpFromBin = mkSetBytesLen withMP (\ mp cbytes len -> botan_mp_from_bin mp (ConstPtr cbytes) len) + +mpToWord32 :: MP -> IO Word32 +mpToWord32 mp = withMP mp $ \ mpPtr -> do + alloca $ \ valPtr -> do + throwBotanIfNegative_ $ botan_mp_to_uint32 mpPtr valPtr + peek valPtr + +mpIsPositive :: MP -> IO Bool +mpIsPositive = mkGetBoolCode withMP botan_mp_is_positive + +mpIsNegative :: MP -> IO Bool +mpIsNegative = mkGetBoolCode withMP botan_mp_is_negative + +mpFlipSign :: MP -> IO () +mpFlipSign = mkAction withMP botan_mp_flip_sign + +mpIsZero :: MP -> IO Bool +mpIsZero = mkGetBoolCode withMP botan_mp_is_zero + +mpAddWord32 :: MP -> MP -> Word32 -> IO () +mpAddWord32 result x y = withMP result $ \ resultPtr -> do + withMP x $ \ xPtr -> do + throwBotanIfNegative_ $ botan_mp_add_u32 resultPtr xPtr y + +mpSubWord32 :: MP -> MP -> Word32 -> IO () +mpSubWord32 result x y = withMP result $ \ resultPtr -> do + withMP x $ \ xPtr -> do + throwBotanIfNegative_ $ botan_mp_sub_u32 resultPtr xPtr y + +mpAdd :: MP -> MP -> MP -> IO () +mpAdd = mkBinaryOp withMP botan_mp_add + +mpSub :: MP -> MP -> MP -> IO () +mpSub = mkBinaryOp withMP botan_mp_sub + +mpMul :: MP -> MP -> MP -> IO () +mpMul = mkBinaryOp withMP botan_mp_mul + +mpDiv :: MP -> MP -> MP -> MP -> IO () +mpDiv = mkBinaryDuplexOp withMP botan_mp_div + +mpModMul :: MP -> MP -> MP -> MP -> IO () +mpModMul = mkTrinaryOp withMP botan_mp_mod_mul + +-- NOTE: Cannot use mkGetBoolCode unless +mpEqual :: MP -> MP -> IO Bool +mpEqual a b = withMP a $ \ aPtr -> do + withMP b $ \ bPtr -> do + throwBotanCatchingBool $ botan_mp_equal aPtr bPtr + +-- TODO: Convert Int to Ordering in >1:1 low-level bindings +mpCmp :: MP -> MP -> IO Int +mpCmp a b = withMP a $ \ aPtr -> do + withMP b $ \ bPtr -> do + alloca $ \ resultPtr -> do + throwBotanIfNegative_ $ botan_mp_cmp resultPtr aPtr bPtr + fromIntegral <$> peek resultPtr + +mpSwap :: MP -> MP -> IO () +mpSwap a b = withMP a $ \ aPtr -> do + withMP b $ \ bPtr -> do + throwBotanIfNegative_ $ botan_mp_swap aPtr bPtr + +mpPowMod :: MP -> MP -> MP -> MP -> IO () +mpPowMod = mkTrinaryOp withMP botan_mp_powmod + +mpLeftShift :: MP -> MP -> Int -> IO () +mpLeftShift = mkUnaryOp_csize withMP botan_mp_lshift + +mpRightShift :: MP -> MP -> Int -> IO () +mpRightShift = mkUnaryOp_csize withMP botan_mp_rshift + +mpModInverse :: MP -> MP -> MP -> IO () +mpModInverse = mkBinaryOp withMP botan_mp_mod_inverse + +mpRandBits :: MP -> RNG -> Int -> IO () +mpRandBits mp rng sz = withMP mp $ \ mpPtr -> do + withRNG rng $ \ botanRNG -> do + throwBotanIfNegative_ $ botan_mp_rand_bits mpPtr botanRNG (fromIntegral sz) + +-- NOTE: Never includes upper bound +mpRandRange :: MP -> RNG -> MP -> MP -> IO () +mpRandRange mp rng lower upper = withMP mp $ \ mpPtr -> do + withRNG rng $ \ botanRNG -> do + withMP lower $ \ lowerPtr -> do + withMP upper $ \ upperPtr -> do + throwBotanIfNegative_ $ botan_mp_rand_range mpPtr botanRNG lowerPtr upperPtr + +mpGCD :: MP -> MP -> MP -> IO () +mpGCD = mkBinaryOp withMP botan_mp_gcd + +-- NOTE: Miller–Rabin primality test +mpIsPrime :: MP -> RNG -> Int -> IO Bool +mpIsPrime mp rng probability = withMP mp $ \ mpPtr -> do + withRNG rng $ \ botanRNG -> do + throwBotanCatchingBool $ botan_mp_is_prime mpPtr botanRNG (fromIntegral probability) + +mpGetBit :: MP -> Int -> IO Bool +mpGetBit = mkGetBoolCode_csize withMP botan_mp_get_bit + +mpSetBit :: MP -> Int -> IO () +mpSetBit = mkSetCSize withMP botan_mp_set_bit + +mpClearBit :: MP -> Int -> IO () +mpClearBit = mkSetCSize withMP botan_mp_clear_bit + +-- +-- Helpers +-- + +-- int botan_...(botan_mp_t dest, const botan_mp_t source); +type UnaryOp ptr = ptr -> ptr -> IO BotanErrorCode + +mkUnaryOp :: WithPtr typ ptr -> UnaryOp ptr -> typ -> typ -> IO () +mkUnaryOp withPtr unary dest source = withPtr dest $ \ destPtr -> do + withPtr source $ \ sourcePtr -> do + throwBotanIfNegative_ $ unary destPtr sourcePtr + +-- int botan_...(botan_mp_t dest, const botan_mp_t source, size_t factor); +type UnaryOp_csize ptr = ptr -> ptr -> CSize -> IO BotanErrorCode + +mkUnaryOp_csize :: WithPtr typ ptr -> UnaryOp_csize ptr -> typ -> typ -> Int -> IO () +mkUnaryOp_csize withPtr unary dest source factor = withPtr dest $ \ destPtr -> do + withPtr source $ \ sourcePtr -> do + throwBotanIfNegative_ $ unary destPtr sourcePtr (fromIntegral factor) + +-- int botan_...(botan_mp_t dest, const botan_mp_t a, const botan_mp_t b); +type BinaryOp ptr = ptr -> ptr -> ptr -> IO BotanErrorCode + +mkBinaryOp :: WithPtr typ ptr -> BinaryOp ptr -> typ -> typ -> typ -> IO () +mkBinaryOp withPtr binary dest a b = withPtr dest $ \ destPtr -> do + withPtr a $ \ aPtr -> do + withPtr b $ \ bPtr -> do + throwBotanIfNegative_ $ binary destPtr aPtr bPtr + +-- int botan_...(botan_mp_t a, botan_mp_t b, const botan_mp_t x, const botan_mp_t y); +type BinaryDuplexOp ptr = ptr -> ptr -> ptr -> ptr -> IO BotanErrorCode + +-- NOTE: Do not confuse for mkTrinaryOp +mkBinaryDuplexOp :: WithPtr typ ptr -> BinaryDuplexOp ptr -> typ -> typ -> typ -> typ -> IO () +mkBinaryDuplexOp withPtr binary a b x y = withPtr a $ \ aPtr -> do + withPtr b $ \ bPtr -> do + withPtr x $ \ xPtr -> do + withPtr y $ \ yPtr -> do + throwBotanIfNegative_ $ binary aPtr bPtr xPtr yPtr + +-- int botan_...(botan_mp_t a, botan_mp_t b, const botan_mp_t x, const botan_mp_t y); +type TrinaryOp ptr = ptr -> ptr -> ptr -> ptr -> IO BotanErrorCode + +-- NOTE: Do not confuse for mkBinaryDuplexOp +mkTrinaryOp :: WithPtr typ ptr -> TrinaryOp ptr -> typ -> typ -> typ -> typ -> IO () +mkTrinaryOp withPtr binary a x y z = withPtr a $ \ aPtr -> do + withPtr x $ \ xPtr -> do + withPtr y $ \ yPtr -> do + withPtr z $ \ zPtr -> do + throwBotanIfNegative_ $ binary aPtr xPtr yPtr zPtr diff --git a/src/Botan/Low/Make.hs b/src/Botan/Low/Make.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/Make.hs @@ -0,0 +1,471 @@ +module Botan.Low.Make where + +import qualified Data.ByteString as ByteString + +import Botan.Low.Error +import Botan.Low.Prelude + +{- +Basic botan type template +-} + +{- +-- Raw bindings +data TypStruct +type TypPtr = Ptr TypStruct + +-- Low-level bindings +newtype Typ = MkTyp { getTypForeignPtr :: ForeignPtr TypStruct } + +withTypPtr :: Typ -> (TypPtr -> IO a) -> IO a +withTypPtr = withForeignPtr . getTypForeignPtr + +-- Common / optional associated types +type TypName = ByteString +type TypFlags = Word32 +-} + +{- +Helper types +-} + +type WithPtr typ ptr = (forall a . typ -> (ptr -> IO a) -> IO a) +-- NOTE: WithPtr typ ptr ~ typ -> Codensity IO ptr +-- where: type Codensity m a = forall b . (a -> m b) -> m b +-- TODO: Refine further per: +-- https://discourse.haskell.org/t/questions-about-ffi-foreignptr-and-opaque-types/6914/21?u=apothecalabs + +{- +Initializers and destroyers +-} + +-- TODO: Generalize all this away to simplify +-- Note the change in position of the destructor argument within the mk function itself, +-- as well as the position of the argument within the initializer +{- +type Construct struct typ = ForeignPtr struct -> typ +type Destruct struct = FinalizerPtr struct +type Initialize0 struct = Ptr (Ptr struct) -> IO BotanErrorCode + +mkInit0 + :: Construct struct typ + -> Destruct struct + -> Initialize0 struct + -> IO typ +mkInit0 construct destruct init0 = do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ init0 outPtr + out <- peek outPtr + foreignPtr <- newForeignPtr destruct out + return $ construct foreignPtr +-} +-- More complex constructors can build on this with more arguments, but there is a choice +-- This choice is left vs right, return arguments before or after. +-- The effectiveness of this choice depends on the structure of the FFI +-- If we changed the FFI to always have trailing return arguments (instead of leading), +-- then we could type +-- Initializer1 withArg0 ... struct +-- instead of +-- Initializer1 struct withArg0 ... +-- Note that even Construct follows trailing return arguments as does Haskell, +-- so there is justifcation for converting the FFI to that format wholesale; +-- such effort (rewriting the Botan FFI to be 100% consistent) is far beyond +-- the scope of this project at this time. +-- SEE: mkInit_with +-- EXAMPLE: +{- +mkFoo :: A -> B -> C -> IO Foo +mkFoo a b c = withA a $ \ a' -> do + withB b $ \ b' -> do + withC c $ \ c' -> do + -- Trailing-return style + mkInit0 MkFoo botan_foo_destroy $ botan_foo_create a' b' c' + -- Vs current leading-return style + mkInit MkFoo (\ ptr -> botan_foo_create ptr a' b' c') botan_x509_cert_store_destroy + -- Note the explicit ptr argument and the necessary parenthesis +-} +-- SEE: x509CertStoreSqlite3Create for how the current style makes ad-hoc constructors +-- more difficult than necessary unless we initialize the return pointer first +-- Also note that initializing the return value pointer last is probably a good practice in general +-- and trailing-return style makes that easy +-- ON THE OTHER HAND trailing-return style makes querying for sizes difficult +-- END TODO + +type Constr struct typ = ForeignPtr struct -> typ + +type Initializer struct = Ptr (Ptr struct) -> IO BotanErrorCode +type Initializer_name struct = Ptr (Ptr struct) -> CString -> IO BotanErrorCode +type Initializer_name_flags struct = Ptr (Ptr struct) -> CString -> Word32 -> IO BotanErrorCode +type Initializer_bytes struct = Ptr (Ptr struct) -> Ptr Word8 -> IO BotanErrorCode +type Initializer_bytes_len struct = Ptr (Ptr struct) -> Ptr Word8 -> CSize -> IO BotanErrorCode + +type Destructor struct = FinalizerPtr struct + +mkInit + :: Constr struct typ + -> Initializer struct + -> Destructor struct + -> IO typ +mkInit constr init destroy = do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ init outPtr + out <- peek outPtr + foreignPtr <- newForeignPtr destroy out + return $ constr foreignPtr + +mkInit_name + :: Constr struct typ + -> Initializer_name struct + -> Destructor struct + -> ByteString -> IO typ +mkInit_name constr init destroy name = do + alloca $ \ outPtr -> do + asCString name $ \ namePtr -> do + throwBotanIfNegative_ $ init outPtr namePtr + out <- peek outPtr + foreignPtr <- newForeignPtr destroy out + return $ constr foreignPtr + +mkInit_name_flags + :: Constr struct typ + -> Initializer_name_flags struct + -> Destructor struct + -> ByteString -> Word32 -> IO typ +mkInit_name_flags constr init destroy name flags = do + alloca $ \ outPtr -> do + asCString name $ \ namePtr -> do + throwBotanIfNegative_ $ init outPtr namePtr flags + out <- peek outPtr + foreignPtr <- newForeignPtr destroy out + return $ constr foreignPtr + +-- NOTE: Assumes that length is known +mkInit_bytes + :: Constr struct typ + -> Initializer_bytes struct + -> Destructor struct + -> ByteString -> IO typ +mkInit_bytes constr init destroy bytes = do + asBytes bytes $ \ bytesPtr -> do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ init outPtr bytesPtr + out <- peek outPtr + foreignPtr <- newForeignPtr destroy out + return $ constr foreignPtr + +mkInit_bytes_len + :: Constr struct typ + -> Initializer_bytes_len struct + -> Destructor struct + -> ByteString -> IO typ +mkInit_bytes_len constr init destroy bytes = do + asBytesLen bytes $ \ bytesPtr bytesLen -> do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ init outPtr bytesPtr bytesLen + out <- peek outPtr + foreignPtr <- newForeignPtr destroy out + return $ constr foreignPtr + +-- Initializing with another botan object +-- TODO: Use this in already-implemented functions as appropriate + +type Initializer_with struct withptr = Ptr (Ptr struct) -> withptr -> IO BotanErrorCode + +mkInit_with + :: Constr struct typ + -> Initializer_with struct withptr + -> Destructor struct + -> (withtyp -> (withptr -> IO typ) -> IO typ) + -> withtyp -> IO typ +mkInit_with constr init destroy withTypPtr typ = alloca $ \ outPtr -> do + withTypPtr typ $ \ typPtr -> do + throwBotanIfNegative_ $ init outPtr typPtr + out <- peek outPtr + foreignPtr <- newForeignPtr destroy out + return $ constr foreignPtr + +{- +Non-effectful queries +-} + +-- type GetName ptr = ptr -> Ptr CChar -> Ptr CSize -> IO BotanErrorCode + +-- Replaced by the new mkGetCString +-- -- TODO: Prefer mkGetBytes / mkGetCString to mkGetName +-- mkGetName +-- :: WithPtr typ ptr +-- -> GetName ptr +-- -> typ -> IO ByteString +-- mkGetName withPtr get typ = withPtr typ $ \ typPtr -> do +-- -- TODO: Take advantage of allocBytesQuerying +-- -- TODO: use ByteString.Internal.createAndTrim? +-- -- NOTE: This uses copy to mimic ByteArray.take (which copies!) so we can drop the rest of the bytestring +-- -- alloca $ \ szPtr -> do +-- -- bytes <- allocBytes 64 $ \ bytesPtr -> do +-- -- throwBotanIfNegative_ $ get typPtr bytesPtr szPtr +-- -- sz <- peek szPtr +-- -- return $! ByteString.copy $! ByteString.take (fromIntegral sz) bytes +-- allocBytesQueryingCString $ \ bytesPtr szPtr -> get typPtr bytesPtr szPtr + +-- NOTE: This now handles both Ptr Word8 and Ptr CChar +-- This reads the entire byte buffer, including any \NUL bytes +type GetBytes ptr byte = ptr -> Ptr byte -> Ptr CSize -> IO BotanErrorCode + +mkGetBytes + :: WithPtr typ ptr + -> GetBytes ptr byte + -> typ -> IO ByteString +mkGetBytes withPtr get typ = withPtr typ $ \ typPtr -> do + allocBytesQuerying $ \ outPtr outLen -> get typPtr outPtr outLen + +-- NOTE This reads a CString, up to the first \NUL +type GetCString ptr byte = ptr -> Ptr byte -> Ptr CSize -> IO BotanErrorCode + +mkGetCString + :: WithPtr typ ptr + -> GetCString ptr byte + -> typ -> IO ByteString +mkGetCString withPtr get typ = withPtr typ $ \ typPtr -> do + allocBytesQueryingCString $ \ outPtr outLen -> get typPtr outPtr outLen + +type GetInt ptr = ptr -> Ptr CInt -> IO BotanErrorCode + +mkGetInt + :: WithPtr typ ptr + -> GetInt ptr + -> typ -> IO Int +mkGetInt withPtr get typ = withPtr typ $ \ typPtr -> do + alloca $ \ szPtr -> do + throwBotanIfNegative_ $ get typPtr szPtr + fromIntegral <$> peek szPtr + +type GetSize ptr = ptr -> Ptr CSize -> IO BotanErrorCode +type GetSize_csize ptr = ptr -> CSize -> Ptr CSize -> IO BotanErrorCode +type GetSizes2 ptr = ptr -> Ptr CSize -> Ptr CSize -> IO BotanErrorCode +type GetSizes3 ptr = ptr -> Ptr CSize -> Ptr CSize -> Ptr CSize -> IO BotanErrorCode + +mkGetSize + :: WithPtr typ ptr + -> GetSize ptr + -> typ -> IO Int +mkGetSize withPtr get typ = withPtr typ $ \ typPtr -> do + alloca $ \ szPtr -> do + throwBotanIfNegative_ $ get typPtr szPtr + fromIntegral <$> peek szPtr + +mkGetSize_csize + :: WithPtr typ ptr + -> GetSize_csize ptr + -> typ -> Int -> IO Int +mkGetSize_csize withPtr get typ forSz = withPtr typ $ \ typPtr -> do + alloca $ \ szPtr -> do + throwBotanIfNegative_ $ get typPtr (fromIntegral forSz) szPtr + fromIntegral <$> peek szPtr + +mkGetSizes2 + :: WithPtr typ ptr + -> GetSizes2 ptr + -> typ -> IO (Int,Int) +mkGetSizes2 withPtr get typ = withPtr typ $ \ typPtr -> do + alloca $ \ szPtrA -> alloca $ \ szPtrB -> do + throwBotanIfNegative_ $ get typPtr szPtrA szPtrB + szA <- fromIntegral <$> peek szPtrA + szB <- fromIntegral <$> peek szPtrB + return (szA,szB) + +mkGetSizes3 + :: WithPtr typ ptr + -> GetSizes3 ptr + -> typ -> IO (Int,Int,Int) +mkGetSizes3 withPtr get typ = withPtr typ $ \ typPtr -> do + alloca $ \ szPtrA -> alloca $ \ szPtrB -> alloca $ \ szPtrC -> do + throwBotanIfNegative_ $ get typPtr szPtrA szPtrB szPtrC + szA <- fromIntegral <$> peek szPtrA + szB <- fromIntegral <$> peek szPtrB + szC <- fromIntegral <$> peek szPtrC + return (szA,szB,szC) + +-- type GetBytes ptr = ptr -> Ptr Word8 -> CSize -> IO BotanErrorCode + +-- NOTE: Get...Code nomenclature signifies that we get the desired return value +-- from the error code error code, eg they use something other than throwBotanIfNegative_ +-- + + +type GetSuccessCode ptr = ptr -> IO BotanErrorCode +type GetSuccessCode_csize ptr = ptr -> CSize -> IO BotanErrorCode + +mkGetSuccessCode + :: WithPtr typ ptr + -> GetSuccessCode ptr + -> typ -> IO Bool +mkGetSuccessCode withPtr get typ = withPtr typ $ \ typPtr -> do + throwBotanCatchingSuccess $ get typPtr + +mkGetSuccessCode_csize + :: WithPtr typ ptr + -> GetSuccessCode_csize ptr + -> typ -> Int -> IO Bool +mkGetSuccessCode_csize withPtr get typ sz = withPtr typ $ \ typPtr -> do + throwBotanCatchingSuccess $ get typPtr (fromIntegral sz) + + +type GetBoolCode ptr = ptr -> IO BotanErrorCode +type GetBoolCode_csize ptr = ptr -> CSize -> IO BotanErrorCode + +mkGetBoolCode + :: WithPtr typ ptr + -> GetBoolCode ptr + -> typ -> IO Bool +mkGetBoolCode withPtr get typ = withPtr typ $ \ typPtr -> do + throwBotanCatchingBool $ get typPtr + +mkGetBoolCode_csize + :: WithPtr typ ptr + -> GetBoolCode_csize ptr + -> typ -> Int -> IO Bool +mkGetBoolCode_csize withPtr get typ sz = withPtr typ $ \ typPtr -> do + throwBotanCatchingBool $ get typPtr (fromIntegral sz) + +type GetIntCode ptr = ptr -> IO BotanErrorCode +type GetIntCode_csize ptr = ptr -> CSize -> IO BotanErrorCode + +mkGetIntCode + :: WithPtr typ ptr + -> GetIntCode ptr + -> typ -> IO Int +mkGetIntCode withPtr get typ = withPtr typ $ \ typPtr -> do + throwBotanCatchingInt $ get typPtr + +mkGetIntCode_csize + :: WithPtr typ ptr + -> GetIntCode_csize ptr + -> typ -> CSize -> IO Int +mkGetIntCode_csize withPtr get typ sz = withPtr typ $ \ typPtr -> do + throwBotanCatchingInt $ get typPtr sz + +{- +Effectful actions +-} + +type Action ptr = ptr -> IO BotanErrorCode +mkAction + :: WithPtr typ ptr + -> Action ptr + -> typ -> IO () +mkAction withPtr action typ = withPtr typ $ \ typPtr -> do + throwBotanIfNegative_ $ action typPtr + +mkSet + :: WithPtr typ ptr + -> (ptr -> a -> IO BotanErrorCode) + -> typ -> a -> IO () +mkSet withPtr set typ a = withPtr typ $ \ typPtr -> do + throwBotanIfNegative_ $ set typPtr a + +mkSetOn + :: WithPtr typ ptr + -> (a -> b) + -> (ptr -> b -> IO BotanErrorCode) + -> typ -> a -> IO () +mkSetOn withPtr fn set typ sz = withPtr typ $ \ typPtr -> do + throwBotanIfNegative_ $ set typPtr (fn sz) + +type SetCSize ptr = ptr -> CSize -> IO BotanErrorCode +type SetCInt ptr = ptr -> CInt -> IO BotanErrorCode + +mkSetCSize + :: WithPtr typ ptr + -> SetCSize ptr + -> typ -> Int -> IO () +mkSetCSize withPtr set typ sz = withPtr typ $ \ typPtr -> do + throwBotanIfNegative_ $ set typPtr (fromIntegral sz) + +mkSetCInt + :: WithPtr typ ptr + -> SetCInt ptr + -> typ -> Int -> IO () +mkSetCInt withPtr set typ sz = withPtr typ $ \ typPtr -> do + throwBotanIfNegative_ $ set typPtr (fromIntegral sz) + +type SetCString ptr = ptr -> CString -> IO BotanErrorCode +type SetCString_csize ptr = ptr -> CString -> CSize -> IO BotanErrorCode + +mkSetCString + :: WithPtr typ ptr + -> SetCString ptr + -> typ -> ByteString -> IO () +mkSetCString withPtr set typ cstring = withPtr typ $ \ typPtr -> do + asCString cstring $ \ cstringPtr -> do + throwBotanIfNegative_ $ set typPtr cstringPtr + +mkSetCString_csize + :: WithPtr typ ptr + -> SetCString_csize ptr + -> typ -> ByteString -> Int -> IO () +mkSetCString_csize withPtr set typ cstring sz = withPtr typ $ \ typPtr -> do + asCString cstring $ \ cstringPtr -> do + throwBotanIfNegative_ $ set typPtr cstringPtr (fromIntegral sz) + +type SetBytesLen ptr = ptr -> Ptr Word8 -> CSize -> IO BotanErrorCode + +mkSetBytesLen + :: WithPtr typ ptr + -> SetBytesLen ptr + -> typ -> ByteString -> IO () +mkSetBytesLen withPtr set typ bytes = withPtr typ $ \ typPtr -> do + asBytesLen bytes $ \ bytesPtr bytesLen -> do + throwBotanIfNegative_ $ set typPtr bytesPtr bytesLen + +-- EXPERIMENTAL + +-- TODO: allocBytesEstimating + +-- NOTE: This properly takes advantage of szPtr, queries the buffer size - use this elsewhere +-- NOTE: This throws any botan codes other than BOTAN_FFI_ERROR_INSUFFICIENT_BUFFER_SPACE +allocBytesQuerying :: (Ptr byte -> Ptr CSize -> IO BotanErrorCode) -> IO ByteString +allocBytesQuerying fn = do + alloca $ \ szPtr -> do + -- TODO: Maybe poke szPtr 0 for extra safety in cas its not initially zero + code <- fn nullPtr szPtr + case code of + InsufficientBufferSpace -> do + sz <- fromIntegral <$> peek szPtr + allocBytes sz $ \ outPtr -> throwBotanIfNegative_ $ fn outPtr szPtr + _ -> do + throwBotanError code + +-- NOTE: Does not check length of taken string, vulnerable to null byte injection +allocBytesQueryingCString :: (Ptr byte -> Ptr CSize -> IO BotanErrorCode) -> IO ByteString +allocBytesQueryingCString action = do + cstring <- allocBytesQuerying action + return $!! ByteString.takeWhile (/= 0) cstring + +-- ALSO EXPERIMENTAL + +-- LAZY BUT EFFECTIVE + +mkWithTemp :: IO t -> (t -> IO ()) -> (t -> IO a) -> IO a +mkWithTemp = bracket + +mkWithTemp1 :: (x -> IO t) -> (t -> IO ()) -> x -> (t -> IO a) -> IO a +mkWithTemp1 init destroy x = bracket (init x) destroy + +mkWithTemp2 :: (x -> y -> IO t) -> (t -> IO ()) -> x -> y -> (t -> IO a) -> IO a +mkWithTemp2 init destroy x y = bracket (init x y) destroy + +mkWithTemp3 :: (x -> y -> z -> IO t) -> (t -> IO ()) -> x -> y -> z -> (t -> IO a) -> IO a +mkWithTemp3 init destroy x y z = bracket (init x y z) destroy + +mkWithTemp4 :: (x -> y -> z -> w -> IO t) -> (t -> IO ()) -> x -> y -> z -> w -> (t -> IO a) -> IO a +mkWithTemp4 init destroy x y z w = bracket (init x y z w) destroy + +-- + +withPtrs :: (forall a . typ -> (ptr -> IO a) -> IO a) -> [typ] -> ([ptr] -> IO b) -> IO b +withPtrs withPtr [] act = act [] +withPtrs withPtr (typ:typs) act = withPtr typ $ \ typPtr -> withPtrs withPtr typs (act . (typPtr:)) + +-- withNullablePtr + +-- withNullablePtrList diff --git a/src/Botan/Low/Prelude.hs b/src/Botan/Low/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/Prelude.hs @@ -0,0 +1,247 @@ +module Botan.Low.Prelude +( module Prelude +, module Control.Monad +, module Control.Exception +, module Control.DeepSeq +, module Data.ByteString +, module Data.String +, module Data.Text +, module Data.Word +, module System.IO +, module Foreign.C.String +, module Foreign.C.Types +, module Foreign.ForeignPtr +, module Foreign.Marshal.Alloc +, module Foreign.Marshal.Array +, module Foreign.Ptr +, module Foreign.Storable +, module GHC.Stack +, ConstPtr(..) +, peekCString +, withCString +, withCBytes +, withCBytesLen +, withConstCString +, withMany +-- Old +, peekCStringText +, allocBytes +, allocBytesWith +, asCString +, asCStringLen +, asBytes +, unsafeAsBytes +, asBytesLen +, unsafeAsBytesLen +-- Helpers +, (//) +, (/$) +, showBytes +) where + +-- Re-exported modules + +import Prelude + +import Control.Monad +import Control.Exception +import Control.DeepSeq + +import Data.ByteString (ByteString) +import Data.String (IsString(..)) +import Data.Text (Text) + +import Data.Word + +import System.IO + +import Foreign.C.String hiding (peekCString, peekCStringLen, withCString, withCStringLen) +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable + +import GHC.Stack + +-- Other Imports + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Internal as ByteString +import qualified Data.ByteString.Unsafe as ByteString + +import qualified Data.ByteString.Char8 as Char8 + +import qualified Data.Text.Encoding as Text + +import Botan.Bindings.Prelude (ConstPtr(..)) + +{- +Small rant: CString is a bit of a mess + +- CString doesn't work with const +- There is no CBytes +- Doesn't work with ConstPtr +- Different names for different types (peek vs pack, useAs vs with) + - Data.ByteString + - packCString :: CString -> IO ByteString + - useAsCString :: ByteString -> (CString -> IO a) -> IO a + - Text + - Foreign.C.String + - peekCString :: CString -> IO String + - withCString :: String -> (CString -> IO a) -> IO a +-} + +{- +BETTER VERSIONS +-} + +-- Types + +-- Safe functions that make a temporary copy +-- Only care about ByteString, leave Text for higher-level botan + +-- type CString = Ptr CChar + +peekCString :: CString -> IO ByteString +peekCString = ByteString.packCString + +-- Replaces 'asCString' +withCString :: ByteString -> (CString -> IO a) -> IO a +withCString = ByteString.useAsCString + +-- type CStringLen = (Ptr CChar, Int) + +peekCStringLen :: CStringLen -> IO ByteString +peekCStringLen = ByteString.packCStringLen + +-- Replaces 'asCStringLen' +withCStringLen :: ByteString -> (CStringLen -> IO a) -> IO a +withCStringLen = ByteString.useAsCStringLen + +type CBytes = Ptr Word8 + +-- peekCBytes :: CBytes -> Int -> IO ByteString +-- peekCBytes = undefined + +withCBytes :: ByteString -> (CBytes -> IO a) -> IO a +withCBytes bs act = ByteString.useAsCStringLen bs (\ (ptr,_) -> act (castPtr ptr)) + +type CBytesLen = (Ptr Word8, Int) + +peekCBytesLen :: CBytesLen -> IO ByteString +peekCBytesLen (ptr, len) = ByteString.packCStringLen (castPtr ptr, len) + +-- Replaces 'asBytesLen' +withCBytesLen :: ByteString -> (CBytesLen -> IO a) -> IO a +withCBytesLen bs act = ByteString.useAsCStringLen bs (\ (ptr,len) -> act (castPtr ptr, len)) + +-- QUESTION: Is it worth it to have extra types for ConstPtr versions? + +{- +type ConstCString = ConstPtr CChar +type ConstCStringLen = (ConstPtr CChar, Int) + +type ConstCBytes = ConstPtr Word8 +type ConstCBytesLen = (ConstPtr Word8, Int) +-} + +-- TODO: Replace +-- withCString str $ \ cstr -> ... (ConstPtr cstr) ... +-- with +-- withConstCString str $ \ cstr -> ... cstr ... +withConstCString :: ByteString -> (ConstPtr CChar -> IO a) -> IO a +withConstCString bs act = ByteString.useAsCString bs (act . ConstPtr) + +{- +Misc +-} + +withMany + :: (forall a . object -> (cobject -> IO a) -> IO a) + -> [object] + -> ([cobject] -> IO b) + -> IO b +withMany withObject [] act = act [] +withMany withObject (obj:objs) act = withObject obj $ \ cobj -> withMany withObject objs (act . (cobj:)) + +{- +OLD +-} + + +-- Because: +-- https://github.com/haskell/text/issues/239 +-- Is still an issue +peekCStringText :: CString -> IO Text +peekCStringText cs = do + bs <- ByteString.unsafePackCString cs + return $! Text.decodeUtf8 bs + +-- A cheap knockoff of ByteArray.alloc / allocRet +-- We'll make this safer in the future +-- NOTE: THIS IS NOT LIKE Foriegn.Marshal.Alloc.allocaBytes, though it is close +-- Instead of returning the thing, we always return a bytestring. +-- Also, allocaBytes frees the memory after, but this is a malloc freed on garbage collect. +-- I basically ripped the relevant bits from ByteArray for ease of continuity +allocBytes :: Int -> (Ptr byte -> IO ()) -> IO ByteString +-- allocBytes sz f = snd <$> allocBytesWith sz f +-- NOTE: This is probably better than mallocByteString withForeignPtr +-- Use of mallocByteString without mkDeferredByteString / deferForeignPtrAvailability +-- is possibly a factor in our InsufficientBufferSpaceException issues +-- NOTE: Most of the comments are rendered moot now :) this needs cleanup +allocBytes sz f = ByteString.create sz (f . castPtr) + +allocBytesWith :: Int -> (Ptr byte -> IO a) -> IO (a, ByteString) +allocBytesWith sz f + | sz < 0 = allocBytesWith 0 f + | otherwise = do + fptr <- ByteString.mallocByteString sz + a <- withForeignPtr fptr (f . castPtr) + -- return (a, ByteString.PS fptr 0 sz) + -- NOTE: The safety of this function is suspect, may require deepseq + let bs = ByteString.PS fptr 0 sz + in bs `deepseq` return (a,bs) + +-- ByteString.create' doesn't exist +-- TODO: Replace allocBytesWith with this +createByteString' :: Int -> (Ptr byte -> IO a) -> IO (ByteString,a) +createByteString' sz action = ByteString.createUptoN' sz $ \ ptr -> do + a <- action (castPtr ptr) + return (sz,a) +{-# INLINE createByteString' #-} + +-- + +asCString :: ByteString -> (Ptr CChar -> IO a) -> IO a +asCString = ByteString.useAsCString + +asCStringLen :: ByteString -> (Ptr CChar -> CSize -> IO a) -> IO a +asCStringLen bs f = ByteString.useAsCStringLen bs (\ (ptr,len) -> f ptr (fromIntegral len)) + +asBytes :: ByteString -> (Ptr byte -> IO a) -> IO a +asBytes bs f = asBytesLen bs (\ ptr _ -> f ptr) + +unsafeAsBytes :: ByteString -> (Ptr byte -> IO a) -> IO a +unsafeAsBytes bs f = unsafeAsBytesLen bs (\ ptr _ -> f ptr) + +-- WARNING: This should not be using `useAsCStringLen` +asBytesLen :: ByteString -> (Ptr byte -> CSize -> IO a) -> IO a +asBytesLen bs f = ByteString.useAsCStringLen bs (\ (ptr,len) -> f (castPtr ptr) (fromIntegral len)) + +unsafeAsBytesLen :: ByteString -> (Ptr byte -> CSize -> IO a) -> IO a +unsafeAsBytesLen bs f = ByteString.unsafeUseAsCStringLen bs (\ (ptr,len) -> f (castPtr ptr) (fromIntegral len)) + +-- Helpers used in a few name constructors + +infixr 6 // +(//) :: (IsString a, Semigroup a) => a -> a -> a +a // b = a <> "/" <> b + +infixr 0 /$ +(/$) :: (IsString a, Semigroup a) => a -> a -> a +a /$ b = a <> "(" <> b <> ")" + +showBytes :: (Show a) => a -> ByteString +showBytes = Char8.pack . show diff --git a/src/Botan/Low/PubKey.hs b/src/Botan/Low/PubKey.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey.hs @@ -0,0 +1,847 @@ +{-| +Module : Botan.Low.PubKey +Description : Public key cryptography +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +Public key cryptography is a collection of techniques allowing +for encryption, signatures, and key agreement. +-} + +module Botan.Low.PubKey +( + +-- * Private keys + PrivKey(..) +, CheckKeyFlags(..) +, pattern CheckKeyNormalTests +, pattern CheckKeyExpensiveTests +, PrivKeyExportFlags(..) +, pattern PrivKeyExportDER +, pattern PrivKeyExportPEM +, withPrivKey +, privKeyCreate +, privKeyLoad +, privKeyDestroy +, privKeyAlgoName +, privKeyCheckKey +, privKeyGetField +, privKeyExport +, privKeyExportPubKey + +-- * Public Keys + +, PubKey(..) +, withPubKey +, pubKeyLoad +, pubKeyDestroy +, pubKeyAlgoName +, pubKeyCheckKey +, pubKeyEstimatedStrength +, pubKeyFingerprint +, pubKeyGetField +, pubKeyExport + +-- * PK Algorithms + +, PKName(..) +, pattern RSA +, pattern SM2 +, pattern ElGamal +, pattern DSA +, pattern ECDSA +, pattern ECKCDSA +, pattern ECGDSA +, pattern GOST_34_10 +, pattern Ed25519 +, pattern XMSS +, pattern DH +, pattern ECDH +, pattern Curve25519 +, pattern Dilithium +, pattern Kyber +, pattern McEliece + +-- ** DLGroup + +, DLGroupName(..) +, pattern FFDHE_IETF_2048 +, pattern FFDHE_IETF_3072 +, pattern FFDHE_IETF_4096 +, pattern FFDHE_IETF_6144 +, pattern FFDHE_IETF_8192 +, pattern MODP_IETF_1024 +, pattern MODP_IETF_1536 +, pattern MODP_IETF_2048 +, pattern MODP_IETF_3072 +, pattern MODP_IETF_4096 +, pattern MODP_IETF_6144 +, pattern MODP_IETF_8192 +, pattern MODP_SRP_1024 +, pattern MODP_SRP_1536 +, pattern MODP_SRP_2048 +, pattern MODP_SRP_3072 +, pattern MODP_SRP_4096 +, pattern MODP_SRP_6144 +, pattern MODP_SRP_8192 +, pattern DSA_JCE_1024 +, pattern DSA_BOTAN_2048 +, pattern DSA_BOTAN_3072 + +-- ** ECGroup + +, ECGroupName(..) +, pattern Secp160k1 +, pattern Secp160r1 +, pattern Secp160r2 +, pattern Secp192k1 +, pattern Secp192r1 +, pattern Secp224k1 +, pattern Secp224r1 +, pattern Secp256k1 +, pattern Secp256r1 +, pattern Secp384r1 +, pattern Secp521r1 +, pattern Brainpool160r1 +, pattern Brainpool192r1 +, pattern Brainpool224r1 +, pattern Brainpool256r1 +, pattern Brainpool320r1 +, pattern Brainpool384r1 +, pattern Brainpool512r1 +, pattern X962_p192v2 +, pattern X962_p192v3 +, pattern X962_p239v1 +, pattern X962_p239v2 +, pattern X962_p239v3 +, pattern Gost_256A +, pattern Gost_512A +, pattern Frp256v1 +, pattern Sm2p256v1 + +-- ** XMSS + +, XMSSName(..) +, pattern XMSS_SHA2_10_256 +, pattern XMSS_SHA2_16_256 +, pattern XMSS_SHA2_20_256 +, pattern XMSS_SHA2_10_512 +, pattern XMSS_SHA2_16_512 +, pattern XMSS_SHA2_20_512 +, pattern XMSS_SHAKE_10_256 +, pattern XMSS_SHAKE_16_256 +, pattern XMSS_SHAKE_20_256 +, pattern XMSS_SHAKE_10_512 +, pattern XMSS_SHAKE_16_512 +, pattern XMSS_SHAKE_20_512 + +-- * EME + +, EMEName(..) +, pattern EME_RAW +, pattern EME_PKCS1_v1_5 +, pattern EME_OAEP +, eme_raw +, eme_pkcs1_v1_5 +, eme_oaep +-- , eme_oaep_mgf +, eme_hash +, eme_sm2EncParam + +-- * EMSA + +, EMSAName(..) +, emsa_none +, emsa_emsa4 +, emsa_hash +, emsa_ed25519Pure +, emsa_ed25519Prehashed +, emsa_ed25519GnuPG +, emsa_sm2SignParam + +-- * Convenience + +-- , PKPaddingName(..) +, createPrivKey +, createPubKey +, mkPrivKeyLoad1_name +, mkPrivKeyLoad3 +, mkPrivKeyLoad4 +, mkPubKeyLoad2 +, mkPubKeyLoad2_name +, mkPubKeyLoad3 +, mkPubKeyLoad4 + +) where + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Unsafe as ByteString + +import Botan.Bindings.MPI +import Botan.Bindings.PubKey +import Botan.Bindings.RNG + +import Botan.Low.Error +import Botan.Low.Hash +import Botan.Low.Make +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.Remake +import Botan.Low.RNG +import Botan.Low.View + +{- $introduction + +-} + +{- $usage + +Unless you need a specific `public key cryptosystem`, it is strongly +recommended that you use the `RSA`, `Ed25519`, or `Curve25519` algorithms, +depending on your desired operation. + +Create an RSA keypair: + +> import Botan.Low.RNG +> import Botan.Low.PubKey +> rng <- rngInit "user" +> -- Alice generates her keys +> alicePrivKey <- privKeyCreate RSA "4096" rng +> alicePubKey <- privKeyExportPubKey alicePrivKey + +> NOTE: For algorithm-specific parameters, consult the Botan documentation and +source + +Encrypt a message: + +> import Botan.Low.PubKey.Encrypt +> message = "Fee fi fo fum!" +> -- Bob encrypts a message for Alice using her public key +> -- Unlike `Crypto.Saltine.Core.Box`, the message is only encrypted, not signed. +> encrypter <- encryptCreate alicePubKey EME_PKCS1_v1_5 +> ciphertext <- encrypt encrypter rng message + +> NOTE: For algorithm-specific padding parameters, consult the Botan +documentation and source + +Decrypt a message: + +> import Botan.Low.PubKey.Decrypt +> -- Alice decrypts the message from Bob using her private key +> decrypter <- decryptCreate alicePrivKey EME_PKCS1_v1_5 +> plaintext <- decrypt decrypter ciphertext +> message == plaintext -- True + +> NOTE: The same padding must be used for both encryption and decryption + +Sign a message: + +> import Botan.Low.PubKey.Sign +> import Botan.Low.Hash +> message = "Fee fi fo fum!" +> -- Alice signs the message using her private key +> signer <- signCreate alicePrivKey (emsa_emsa4 SHA3) StandardFormatSignature +> signUpdate signer message +> sig <- signFinish signer rng + +> NOTE: Signing uses a different set of padding algorithms `EMSA` from +encryption `EME`, and different signing / encryption algorithms support +different specific padding algorithms + +> NOTE: Signing does not yet have proper constants for selecting a padding +mechanism. For more information, refer to the `Botan.PubKey`, +`Botan.PubKey.Sign`, or the Botan C++ documentation. This area will be improved +in the near future. + +Verify a message: + +> import Botan.Low.PubKey.Verify +> -- Bob verifies the message using Alice's public key +> verifier <- verifyCreate alicePubKey (emsa_emsa4 SHA3) StandardFormatSignature +> verifyUpdate verifier message +> verified <- verifyFinish verifier sig +> verified -- True + +> NOTE: The same padding must be used for both encryption and decryption + +-} + +-- Associated types + +type PKPaddingName = ByteString + +-- /* +-- * Public/private key creation, import, ... +-- */ + +newtype PrivKey = MkPrivKey { getPrivKeyForeignPtr :: ForeignPtr BotanPrivKeyStruct } + +newPrivKey :: BotanPrivKey -> IO PrivKey +withPrivKey :: PrivKey -> (BotanPrivKey -> IO a) -> IO a +privKeyDestroy :: PrivKey -> IO () +createPrivKey :: (Ptr BotanPrivKey -> IO CInt) -> IO PrivKey +(newPrivKey, withPrivKey, privKeyDestroy, createPrivKey, _) + = mkBindings + MkBotanPrivKey runBotanPrivKey + MkPrivKey getPrivKeyForeignPtr + botan_privkey_destroy + +type PrivKeyName = ByteString + +type PKName = ByteString + +pattern RSA + , SM2 + , ElGamal + , DSA + , ECDSA + , ECKCDSA + , ECGDSA + , GOST_34_10 + , Ed25519 + , XMSS + , DH + , ECDH + , Curve25519 + , Dilithium + , Kyber + -- , SPHINCSPlus + , McEliece + :: PKName + +pattern RSA = BOTAN_PK_RSA +pattern SM2 = BOTAN_PK_SM2 +pattern ElGamal = BOTAN_PK_ELGAMAL +pattern DSA = BOTAN_PK_DSA +pattern ECDSA = BOTAN_PK_ECDSA +pattern ECKCDSA = BOTAN_PK_ECKCDSA +pattern ECGDSA = BOTAN_PK_ECGDSA +pattern GOST_34_10 = BOTAN_PK_GOST_34_10 +pattern Ed25519 = BOTAN_PK_ED25519 +pattern XMSS = BOTAN_PK_XMSS +pattern DH = BOTAN_PK_DH +pattern ECDH = BOTAN_PK_ECDH +pattern Curve25519 = BOTAN_PK_CURVE25519 +pattern Dilithium = BOTAN_PK_DILITHIUM +pattern Kyber = BOTAN_PK_KYBER +-- pattern SPHINCSPlus = BOTAN_PK_SPHINCSPLUS +pattern McEliece = BOTAN_PK_MCELIECE + +type XMSSName = ByteString + +pattern XMSS_SHA2_10_256 + , XMSS_SHA2_16_256 + , XMSS_SHA2_20_256 + , XMSS_SHA2_10_512 + , XMSS_SHA2_16_512 + , XMSS_SHA2_20_512 + , XMSS_SHAKE_10_256 + , XMSS_SHAKE_16_256 + , XMSS_SHAKE_20_256 + , XMSS_SHAKE_10_512 + , XMSS_SHAKE_16_512 + , XMSS_SHAKE_20_512 + :: XMSSName + +pattern XMSS_SHA2_10_256 = BOTAN_XMSS_SHA2_10_256 +pattern XMSS_SHA2_16_256 = BOTAN_XMSS_SHA2_16_256 +pattern XMSS_SHA2_20_256 = BOTAN_XMSS_SHA2_20_256 +pattern XMSS_SHA2_10_512 = BOTAN_XMSS_SHA2_10_512 +pattern XMSS_SHA2_16_512 = BOTAN_XMSS_SHA2_16_512 +pattern XMSS_SHA2_20_512 = BOTAN_XMSS_SHA2_20_512 +pattern XMSS_SHAKE_10_256 = BOTAN_XMSS_SHAKE_10_256 +pattern XMSS_SHAKE_16_256 = BOTAN_XMSS_SHAKE_16_256 +pattern XMSS_SHAKE_20_256 = BOTAN_XMSS_SHAKE_20_256 +pattern XMSS_SHAKE_10_512 = BOTAN_XMSS_SHAKE_10_512 +pattern XMSS_SHAKE_16_512 = BOTAN_XMSS_SHAKE_16_512 +pattern XMSS_SHAKE_20_512 = BOTAN_XMSS_SHAKE_20_512 + +type ECGroupName = ByteString + +pattern Secp160k1 + , Secp160r1 + , Secp160r2 + , Secp192k1 + , Secp192r1 + , Secp224k1 + , Secp224r1 + , Secp256k1 + , Secp256r1 + , Secp384r1 + , Secp521r1 + , Brainpool160r1 + , Brainpool192r1 + , Brainpool224r1 + , Brainpool256r1 + , Brainpool320r1 + , Brainpool384r1 + , Brainpool512r1 + , X962_p192v2 + , X962_p192v3 + , X962_p239v1 + , X962_p239v2 + , X962_p239v3 + , Gost_256A + , Gost_512A + , Frp256v1 + , Sm2p256v1 + :: ECGroupName + +pattern Secp160k1 = BOTAN_ECGROUP_SECP_160_K1 +pattern Secp160r1 = BOTAN_ECGROUP_SECP_160_R1 +pattern Secp160r2 = BOTAN_ECGROUP_SECP_160_R2 +pattern Secp192k1 = BOTAN_ECGROUP_SECP_192_K1 +pattern Secp192r1 = BOTAN_ECGROUP_SECP_192_R1 +pattern Secp224k1 = BOTAN_ECGROUP_SECP_224_K1 +pattern Secp224r1 = BOTAN_ECGROUP_SECP_224_R1 +pattern Secp256k1 = BOTAN_ECGROUP_SECP_256_K1 +pattern Secp256r1 = BOTAN_ECGROUP_SECP_256_R1 +pattern Secp384r1 = BOTAN_ECGROUP_SECP_384_R1 +pattern Secp521r1 = BOTAN_ECGROUP_SECP_521_R1 +pattern Brainpool160r1 = BOTAN_ECGROUP_BRAINPOOL_160_R1 +pattern Brainpool192r1 = BOTAN_ECGROUP_BRAINPOOL_192_R1 +pattern Brainpool224r1 = BOTAN_ECGROUP_BRAINPOOL_224_R1 +pattern Brainpool256r1 = BOTAN_ECGROUP_BRAINPOOL_256_R1 +pattern Brainpool320r1 = BOTAN_ECGROUP_BRAINPOOL_320_R1 +pattern Brainpool384r1 = BOTAN_ECGROUP_BRAINPOOL_384_R1 +pattern Brainpool512r1 = BOTAN_ECGROUP_BRAINPOOL_512_R1 +pattern X962_p192v2 = BOTAN_ECGROUP_X962_P192_V2 +pattern X962_p192v3 = BOTAN_ECGROUP_X962_P192_V3 +pattern X962_p239v1 = BOTAN_ECGROUP_X962_P239_V1 +pattern X962_p239v2 = BOTAN_ECGROUP_X962_P239_V2 +pattern X962_p239v3 = BOTAN_ECGROUP_X962_P239_V3 +pattern Gost_256A = BOTAN_ECGROUP_GOST_256A +pattern Gost_512A = BOTAN_ECGROUP_GOST_512A +pattern Frp256v1 = BOTAN_ECGROUP_FRP_256_V1 +pattern Sm2p256v1 = BOTAN_ECGROUP_SM2_P256_V1 + +type DLGroupName = ByteString + +pattern FFDHE_IETF_2048 + , FFDHE_IETF_3072 + , FFDHE_IETF_4096 + , FFDHE_IETF_6144 + , FFDHE_IETF_8192 + , MODP_IETF_1024 + , MODP_IETF_1536 + , MODP_IETF_2048 + , MODP_IETF_3072 + , MODP_IETF_4096 + , MODP_IETF_6144 + , MODP_IETF_8192 + , MODP_SRP_1024 + , MODP_SRP_1536 + , MODP_SRP_2048 + , MODP_SRP_3072 + , MODP_SRP_4096 + , MODP_SRP_6144 + , MODP_SRP_8192 + , DSA_JCE_1024 + , DSA_BOTAN_2048 + , DSA_BOTAN_3072 + :: DLGroupName + +pattern FFDHE_IETF_2048 = BOTAN_DLGROUP_FFDHE_IETF_2048 +pattern FFDHE_IETF_3072 = BOTAN_DLGROUP_FFDHE_IETF_3072 +pattern FFDHE_IETF_4096 = BOTAN_DLGROUP_FFDHE_IETF_4096 +pattern FFDHE_IETF_6144 = BOTAN_DLGROUP_FFDHE_IETF_6144 +pattern FFDHE_IETF_8192 = BOTAN_DLGROUP_FFDHE_IETF_8192 +pattern MODP_IETF_1024 = BOTAN_DLGROUP_MODP_IETF_1024 +pattern MODP_IETF_1536 = BOTAN_DLGROUP_MODP_IETF_1536 +pattern MODP_IETF_2048 = BOTAN_DLGROUP_MODP_IETF_2048 +pattern MODP_IETF_3072 = BOTAN_DLGROUP_MODP_IETF_3072 +pattern MODP_IETF_4096 = BOTAN_DLGROUP_MODP_IETF_4096 +pattern MODP_IETF_6144 = BOTAN_DLGROUP_MODP_IETF_6144 +pattern MODP_IETF_8192 = BOTAN_DLGROUP_MODP_IETF_8192 +pattern MODP_SRP_1024 = BOTAN_DLGROUP_MODP_SRP_1024 +pattern MODP_SRP_1536 = BOTAN_DLGROUP_MODP_SRP_1536 +pattern MODP_SRP_2048 = BOTAN_DLGROUP_MODP_SRP_2048 +pattern MODP_SRP_3072 = BOTAN_DLGROUP_MODP_SRP_3072 +pattern MODP_SRP_4096 = BOTAN_DLGROUP_MODP_SRP_4096 +pattern MODP_SRP_6144 = BOTAN_DLGROUP_MODP_SRP_6144 +pattern MODP_SRP_8192 = BOTAN_DLGROUP_MODP_SRP_8192 +pattern DSA_JCE_1024 = BOTAN_DLGROUP_DSA_JCE_1024 +pattern DSA_BOTAN_2048 = BOTAN_DLGROUP_DSA_BOTAN_2048 +pattern DSA_BOTAN_3072 = BOTAN_DLGROUP_DSA_BOTAN_3072 + +{- | +Encoding Method for Encryption + +WARNING: Name is not completely accurate, may be changed to PKEncryptParams +-} +type EMEName = ByteString + +pattern EME_RAW + , EME_PKCS1_v1_5 + , EME_OAEP + :: EMEName + +pattern EME_RAW = BOTAN_EME_RAW +pattern EME_PKCS1_v1_5 = BOTAN_EME_PKCS1_v1_5 +pattern EME_OAEP = BOTAN_EME_OAEP + +eme_raw :: EMEName +eme_raw = EME_RAW + +eme_pkcs1_v1_5 :: EMEName +eme_pkcs1_v1_5 = EME_PKCS1_v1_5 + +eme_oaep :: HashName -> EMEName +eme_oaep h = EME_OAEP /$ h + +-- TODO: OAEP with MGF, L +-- eme_oaep_mgf :: HashName -> MGFName -> EMEName +-- eme_oaep_mgf h m = EME_OAEP /$ h <> "," <> m + +eme_hash :: HashName -> EMEName +eme_hash = id + +eme_sm2EncParam :: HashName -> EMEName +eme_sm2EncParam h = h + +type MGFName = ByteString + +pattern MGF1 + :: MGFName + +pattern MGF1 = BOTAN_MGF_MGF1 + +mgf1 :: HashName -> MGFName +mgf1 h = MGF1 /$ h + +{- | +Encoding Method for Signature with Appendix + +WARNING: Name is not completely accurate, may be changed to PKSignParams +-} +type EMSAName = ByteString + +-- emsa_rsa :: + +emsa_emsa4 :: HashName -> EMSAName +emsa_emsa4 h = "EMSA4(" <> h <> ")" + +emsa_ed25519Pure :: EMSAName +emsa_ed25519Pure = "Pure" + +emsa_ed25519Prehashed :: EMSAName +emsa_ed25519Prehashed = "Ed25519ph" + +emsa_ed25519GnuPG :: HashName -> EMSAName +emsa_ed25519GnuPG = emsa_hash + +emsa_hash :: HashName -> EMSAName +emsa_hash = id + +emsa_sm2SignParam :: ByteString -> HashName -> EMSAName +emsa_sm2SignParam uid h = uid <> "," <> h + +-- emsa_xmss +-- emsa_dilithium + +emsa_none :: EMSAName +emsa_none = "" + +-- | Create a new private key +privKeyCreate + :: ByteString -- ^ __algo_name__: something like "RSA" or "ECDSA" + -> ByteString -- ^ __algo_params__: is specific to the algorithm. For RSA, specifies + -- the modulus bit length. For ECC is the name of the curve. + -> RNG -- ^ __rng__: a random number generator + -> IO PrivKey -- ^ __key__: the new object will be placed here +privKeyCreate name params rng = asCString name $ \ namePtr -> do + asCString params $ \ paramsPtr -> do + withRNG rng $ \ botanRNG -> do + createPrivKey $ \ out -> botan_privkey_create + out + (ConstPtr namePtr) + (ConstPtr paramsPtr) + botanRNG + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withPrivKeyCreate :: ByteString -> ByteString -> RNG -> (PrivKey -> IO a) -> IO a +withPrivKeyCreate = mkWithTemp3 privKeyCreate privKeyDestroy + +type CheckKeyFlags = Word32 + +pattern CheckKeyNormalTests + , CheckKeyExpensiveTests + :: CheckKeyFlags +pattern CheckKeyNormalTests = BOTAN_CHECK_KEY_NORMAL_TESTS +pattern CheckKeyExpensiveTests = BOTAN_CHECK_KEY_EXPENSIVE_TESTS + +-- TODO: Probably catch -1 (INVALID_INPUT), return Bool +-- | Check the validity of a private key +privKeyCheckKey + :: PrivKey -- ^ __key__ + -> RNG -- ^ __rng__ + -> CheckKeyFlags -- ^ __flags__ + -> IO () +privKeyCheckKey sk rng flags = withPrivKey sk $ \ skPtr -> do + withRNG rng $ \ botanRNG -> do + throwBotanIfNegative_ $ botan_privkey_check_key skPtr botanRNG flags + +-- NOTE: Expectes PKCS #8 / PEM structure +-- botan_privkey_export -> null password? and botan_privkey_export_encrypted_... -> use a password? +-- NOTE: This is probably a bad implementation; null pointer and empty string are different +-- and unencrypted is not the same as encrypted with "" as a pasword +-- We'll fix this by having privKeyLoad and privKeyLoadEncrypted be separate functions +{- | +Input currently assumed to be PKCS #8 structure; +Set password to NULL to indicate no encryption expected +Starting in 2.8.0, the rng parameter is unused and may be set to null +-} +privKeyLoad + :: ByteString -- ^ __bits[]__ + -> ByteString -- ^ __password__ + -> IO PrivKey -- ^ __key__ +privKeyLoad bits password = asBytesLen bits $ \ bitsPtr bitsLen -> do + let asCStringNullable str act = if ByteString.null str + then act nullPtr + else asCString str act + asCStringNullable password $ \ passwordPtr -> do + createPrivKey $ \ out -> botan_privkey_load + out + (MkBotanRNG nullPtr) + (ConstPtr bitsPtr) + bitsLen + (ConstPtr passwordPtr) + +type PrivKeyExportFlags = Word32 + +pattern PrivKeyExportDER + , PrivKeyExportPEM + :: PrivKeyExportFlags + +pattern PrivKeyExportDER = BOTAN_PRIVKEY_EXPORT_FLAG_DER +pattern PrivKeyExportPEM = BOTAN_PRIVKEY_EXPORT_FLAG_PEM + +-- NOTE: Different from allocBytesQuerying / INSUFFICIENT_BUFFER_SPACE +{- | +On input *out_len is number of bytes in out[] +On output *out_len is number of bytes written (or required) +If out is not big enough no output is written, *out_len is set and 1 is returned +Returns 0 on success and sets +If some other error occurs a negative integer is returned. +-} +privKeyExport + :: PrivKey -- ^ __key__ + -> PrivKeyExportFlags -- ^ __flags__ + -> IO ByteString -- ^ __out[]__ +privKeyExport sk flags = withPrivKey sk $ \ skPtr -> do + alloca $ \szPtr -> do + poke szPtr 0 + -- NOTE: Presumed be -1 + _ <- botan_privkey_export skPtr nullPtr szPtr flags + sz <- peek szPtr + allocBytes (fromIntegral sz) $ \ bytesPtr -> do + throwBotanIfNegative_ $ botan_privkey_export skPtr bytesPtr szPtr flags + +-- TODO: +-- | View the private key's DER encoding +-- privKeyViewDER +-- :: BotanPrivKey -- ^ __key__ +-- -> BotanViewContext ctx -- ^ __ctx__ +-- -> FunPtr (BotanViewBinCallback ctx) -- ^ __view__ +-- -> IO CInt + +-- TODO: +-- | View the private key's PEM encoding +-- privKeyViewPEM +-- :: BotanPrivKey -- ^ __key__ +-- -> BotanViewContext ctx -- ^ __ctx__ +-- -> FunPtr (BotanViewStrCallback ctx) -- ^ __view__ +-- -> IO CInt + +privKeyAlgoName + :: PrivKey -- ^ __key__ + -> IO ByteString -- ^ __out[]__ +privKeyAlgoName = mkGetCString withPrivKey botan_privkey_algo_name + +-- TODO: +-- privKeyExportEncryptedPBKDFMsec +-- :: PrivKey +-- -> RNG +-- -> ByteString -- Passphrase +-- -> Word32 -- Msec runtime +-- -> ByteString -- Cipher algo +-- -> ByteString -- PBKDF algo +-- -> Word32 -- Flags +-- -> IO ByteString +-- privKeyExportEncryptedPBKDFMsec = undefined + +-- TODO: +-- privKeyExportEncryptedPBKDFIter +-- :: PrivKey +-- -> RNG +-- -> ByteString -- Passphrase +-- -> CSize -- Iterations +-- -> ByteString -- Cipher algo +-- -> ByteString -- PBKDF algo +-- -> Word32 -- Flags +-- -> IO ByteString +-- privKeyExportEncryptedPBKDFIter = undefined + +newtype PubKey = MkPubKey { getPubKeyForeignPtr :: ForeignPtr BotanPubKeyStruct } + +newPubKey :: BotanPubKey -> IO PubKey +withPubKey :: PubKey -> (BotanPubKey -> IO a) -> IO a +pubKeyDestroy :: PubKey -> IO () +createPubKey :: (Ptr BotanPubKey -> IO CInt) -> IO PubKey +(newPubKey, withPubKey, pubKeyDestroy, createPubKey, _) + = mkBindings + MkBotanPubKey runBotanPubKey + MkPubKey getPubKeyForeignPtr + botan_pubkey_destroy + +type PubKeyName = ByteString + +pubKeyLoad + :: ByteString -- ^ __bits[]__ + -> IO PubKey -- ^ __key__ +pubKeyLoad = mkCreateObjectCBytesLen createPubKey botan_pubkey_load + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withPubKeyLoad :: ByteString -> (PubKey -> IO a) -> IO a +withPubKeyLoad = mkWithTemp1 pubKeyLoad pubKeyDestroy + +privKeyExportPubKey + :: PrivKey -- ^ __in__ + -> IO PubKey -- ^ __out__ +privKeyExportPubKey = mkCreateObjectWith createPubKey withPrivKey botan_privkey_export_pubkey + +type PubKeyExportFlags = PrivKeyExportFlags + +pattern PubKeyExportDER + , PubKeyExportPEM + :: PubKeyExportFlags + +pattern PubKeyExportDER = PrivKeyExportDER +pattern PubKeyExportPEM = PrivKeyExportPEM + +-- NOTE: Different from allocBytesQuerying / INSUFFICIENT_BUFFER_SPACE +pubKeyExport + :: PubKey -- ^ __key__ + -> PubKeyExportFlags -- ^ __flags__ + -> IO ByteString -- ^ __out[]__ +pubKeyExport pk flags = withPubKey pk $ \ pkPtr -> do + alloca $ \szPtr -> do + poke szPtr 0 + -- NOTE: Presumed be -1 + _ <- botan_pubkey_export pkPtr nullPtr szPtr flags + sz <- peek szPtr + allocBytes (fromIntegral sz) $ \ bytesPtr -> do + throwBotanIfNegative_ $ botan_pubkey_export pkPtr bytesPtr szPtr flags + + +pubKeyAlgoName + :: PubKey -- ^ __key__ + -> IO ByteString -- ^ __out[]__ +pubKeyAlgoName = mkGetCString withPubKey botan_pubkey_algo_name + +pubKeyCheckKey + :: PubKey -- ^ __key__ + -> RNG -- ^ __rng__ + -> CheckKeyFlags -- ^ __flags__ + -> IO Bool +pubKeyCheckKey pk rng flags = withPubKey pk $ \ pkPtr -> do + withRNG rng $ \ botanRNG -> do + throwBotanCatchingSuccess $ botan_pubkey_check_key pkPtr botanRNG flags + +-- Annoying - this mixes cint and csize +-- I need to consolidate getsize / getint +pubKeyEstimatedStrength + :: PubKey -- ^ __key__ + -> IO Int -- ^ __estimate__ +pubKeyEstimatedStrength pk = fromIntegral <$> mkGetSize withPubKey botan_pubkey_estimated_strength pk + +pubKeyFingerprint + :: PubKey -- ^ __key__ + -> HashName -- ^ __hash__ + -> IO ByteString -- ^ __out[]__ +pubKeyFingerprint pk algo = withPubKey pk $ \ pkPtr -> do + asCString algo $ \ algoPtr -> do + allocBytesQuerying $ \ outPtr outLen -> botan_pubkey_fingerprint + pkPtr + (ConstPtr algoPtr) + outPtr + outLen + +-- | Get arbitrary named fields from public or private keys +pubKeyGetField + :: MP -- ^ __output__ + -> PubKey -- ^ __key__ + -> ByteString -- ^ __field_name__ + -> IO () +pubKeyGetField mp pk field = withMP mp $ \ mpPtr -> do + withPubKey pk $ \ pkPtr -> do + asCString field $ \ fieldPtr -> do + throwBotanIfNegative_ $ botan_pubkey_get_field + mpPtr + pkPtr + (ConstPtr fieldPtr) + +-- | Get arbitrary named fields from public or private keys +privKeyGetField + :: MP -- ^ __output__ + -> PrivKey -- ^ __key__ + -> ByteString -- ^ __field_name__ + -> IO () +privKeyGetField mp sk field = withMP mp $ \ mpPtr -> do + withPrivKey sk $ \ skPtr -> do + asCString field $ \ fieldPtr -> do + throwBotanIfNegative_ $ botan_privkey_get_field + mpPtr + skPtr + (ConstPtr fieldPtr) + +-- Helpers + +mkPrivKeyLoad1_name + :: (Ptr BotanPrivKey -> BotanMP -> ConstPtr CChar -> IO BotanErrorCode) + -> MP -> ByteString -> IO PrivKey +mkPrivKeyLoad1_name load a name = withMP a $ \ aPtr -> do + asCString name $ \ namePtr -> do + createPrivKey $ \ out -> load out aPtr (ConstPtr namePtr) + +mkPrivKeyLoad3 + :: (Ptr BotanPrivKey -> BotanMP -> BotanMP -> BotanMP -> IO BotanErrorCode) + -> MP -> MP -> MP -> IO PrivKey +mkPrivKeyLoad3 load a b c = withMany withMP [a,b,c] $ \ [aPtr,bPtr,cPtr] -> do + createPrivKey $ \ out -> load out aPtr bPtr cPtr + +mkPrivKeyLoad4 + :: (Ptr BotanPrivKey -> BotanMP -> BotanMP -> BotanMP -> BotanMP -> IO BotanErrorCode) + -> MP -> MP -> MP -> MP -> IO PrivKey +mkPrivKeyLoad4 load a b c d = withMany withMP [a,b,c,d] $ \ [aPtr,bPtr,cPtr,dPtr] -> do + createPrivKey $ \ out -> load out aPtr bPtr cPtr dPtr + +-- + +mkPubKeyLoad2 + :: (Ptr BotanPubKey -> BotanMP -> BotanMP -> IO BotanErrorCode) + -> MP -> MP -> IO PubKey +mkPubKeyLoad2 load a b = withMany withMP [a,b] $ \ [aPtr,bPtr] -> do + createPubKey $ \ out -> load out aPtr bPtr + +mkPubKeyLoad2_name + :: (Ptr BotanPubKey -> BotanMP -> BotanMP -> ConstPtr CChar -> IO BotanErrorCode) + -> MP -> MP -> ByteString -> IO PubKey +mkPubKeyLoad2_name load x y name = withMany withMP [x,y] $ \ [xPtr,yPtr] -> do + asCString name $ \ namePtr -> do + createPubKey $ \ out -> load out xPtr yPtr (ConstPtr namePtr) + +mkPubKeyLoad3 + :: (Ptr BotanPubKey -> BotanMP -> BotanMP -> BotanMP -> IO BotanErrorCode) + -> MP -> MP -> MP -> IO PubKey +mkPubKeyLoad3 load a b c = withMany withMP [a,b,c] $ \ [aPtr,bPtr,cPtr] -> do + createPubKey $ \ out -> load out aPtr bPtr cPtr + +mkPubKeyLoad4 + :: (Ptr BotanPubKey -> BotanMP -> BotanMP -> BotanMP -> BotanMP -> IO BotanErrorCode) + -> MP -> MP -> MP -> MP -> IO PubKey +mkPubKeyLoad4 load a b c d = withMany withMP [a,b,c,d] $ \ [aPtr,bPtr,cPtr,dPtr] -> do + createPubKey $ \ out -> load out aPtr bPtr cPtr dPtr diff --git a/src/Botan/Low/PubKey/DH.hs b/src/Botan/Low/PubKey/DH.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/DH.hs @@ -0,0 +1,35 @@ +{-| +Module : Botan.Low.DSA +Description : Algorithm specific key operations: Diffie Hellman +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.DH where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey.DH + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.PubKey + +privKeyLoadDH + :: MP -- ^ __p__: prime order of a Z_p group + -> MP -- ^ __g__: group generator + -> MP -- ^ __x__: private key + -> IO PrivKey -- ^ __key__: variable populated with key material +privKeyLoadDH = mkPrivKeyLoad3 botan_privkey_load_dh + +pubKeyLoadDH + :: MP -- ^ __p__: prime order of a Z_p group + -> MP -- ^ __g__: group generator + -> MP -- ^ __y__: public key + -> IO PubKey -- ^ __key__: variable populated with key material +pubKeyLoadDH = mkPubKeyLoad3 botan_pubkey_load_dh diff --git a/src/Botan/Low/PubKey/DSA.hs b/src/Botan/Low/PubKey/DSA.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/DSA.hs @@ -0,0 +1,53 @@ +{-| +Module : Botan.Low.DSA +Description : Algorithm specific key operations: DSA +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.DSA where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey +import Botan.Bindings.PubKey.DSA + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.PubKey +import Botan.Low.RNG + +privKeyCreateDSA + :: RNG -- ^ __rng__: initialized PRNG + -> Int -- ^ __pbits__: length of the key in bits. Must be between in range (1024, 3072) + -- and multiple of 64. Bit size of the prime 'p' + -> Int -- ^ __qbits__: qbits order of the subgroup. Must be in range (160, 256) and multiple + -- of 8 + -> IO PrivKey -- ^ __key__: handler to the resulting key +privKeyCreateDSA rng pbits qbits = withRNG rng $ \ botanRNG -> do + createPrivKey $ \ out -> botan_privkey_create_dsa + out + botanRNG + (fromIntegral pbits) + (fromIntegral qbits) + +privKeyLoadDSA + :: MP -- ^ __p__ + -> MP -- ^ __q__ + -> MP -- ^ __g__ + -> MP -- ^ __x__ + -> IO PrivKey -- ^ __key__ +privKeyLoadDSA = mkPrivKeyLoad4 botan_privkey_load_dsa + +pubKeyLoadDSA + :: MP -- ^ __p__ + -> MP -- ^ __q__ + -> MP -- ^ __g__ + -> MP -- ^ __y__ + -> IO PubKey -- ^ __key__ +pubKeyLoadDSA = mkPubKeyLoad4 botan_pubkey_load_dsa diff --git a/src/Botan/Low/PubKey/Decrypt.hs b/src/Botan/Low/PubKey/Decrypt.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/Decrypt.hs @@ -0,0 +1,84 @@ +{-| +Module : Botan.Low.PubKey.Decrypt +Description : Public Key Decryption +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.Decrypt +( + +-- * Public key decryption + Decrypt(..) +, withDecrypt +, decryptCreate +, decryptDestroy +, decryptOutputLength +, decrypt + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey.Decrypt + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.Remake + +-- /* +-- * Public Key Decryption +-- */ + +newtype Decrypt = MkDecrypt { getDecryptForeignPtr :: ForeignPtr BotanPKOpDecryptStruct } + +newDecrypt :: BotanPKOpDecrypt -> IO Decrypt +withDecrypt :: Decrypt -> (BotanPKOpDecrypt -> IO a) -> IO a +decryptDestroy :: Decrypt -> IO () +createDecrypt :: (Ptr BotanPKOpDecrypt -> IO CInt) -> IO Decrypt +(newDecrypt, withDecrypt, decryptDestroy, createDecrypt, _) + = mkBindings + MkBotanPKOpDecrypt runBotanPKOpDecrypt + MkDecrypt getDecryptForeignPtr + botan_pk_op_decrypt_destroy + +decryptCreate + :: PrivKey -- ^ __key__ + -> EMEName -- ^ __padding__ + -> IO Decrypt +decryptCreate sk padding = withPrivKey sk $ \ skPtr -> do + asCString padding $ \ paddingPtr -> do + createDecrypt $ \ out -> botan_pk_op_decrypt_create + out + skPtr + paddingPtr + BOTAN_PUBKEY_DECRYPT_FLAGS_NONE + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withDecryptCreate :: PrivKey -> EMEName -> (Decrypt -> IO a) -> IO a +withDecryptCreate = mkWithTemp2 decryptCreate decryptDestroy + +decryptOutputLength + :: Decrypt -- ^ __op__ + -> Int -- ^ __ctext_len__ + -> IO Int -- ^ __ptext_len__ +decryptOutputLength = mkGetSize_csize withDecrypt botan_pk_op_decrypt_output_length + +decrypt + :: Decrypt -- ^ __op__ + -> ByteString -- ^ __ciphertext__ + -> IO ByteString -- ^ __plaintext__ +decrypt dec ctext = withDecrypt dec $ \ decPtr -> do + asBytesLen ctext $ \ ctextPtr ctextLen -> do + allocBytesQuerying $ \ outPtr szPtr -> botan_pk_op_decrypt + decPtr + outPtr + szPtr + (ConstPtr ctextPtr) + ctextLen diff --git a/src/Botan/Low/PubKey/ECDH.hs b/src/Botan/Low/PubKey/ECDH.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/ECDH.hs @@ -0,0 +1,21 @@ +module Botan.Low.PubKey.ECDH where + +import Botan.Bindings.PubKey +import Botan.Bindings.PubKey.ECDH + +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.PubKey + +privKeyLoadECDH + :: MP -- ^ __scalar__ + -> ByteString -- ^ __curve_name__ + -> IO PrivKey -- ^ __key__ +privKeyLoadECDH = mkPrivKeyLoad1_name botan_privkey_load_ecdh + +pubKeyLoadECDH + :: MP -- ^ __public_x__ + -> MP -- ^ __public_y__ + -> ByteString -- ^ __curve_name__ + -> IO PubKey -- ^ __key__ +pubKeyLoadECDH = mkPubKeyLoad2_name botan_pubkey_load_ecdh diff --git a/src/Botan/Low/PubKey/ECDSA.hs b/src/Botan/Low/PubKey/ECDSA.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/ECDSA.hs @@ -0,0 +1,21 @@ +module Botan.Low.PubKey.ECDSA where + +import Botan.Bindings.PubKey +import Botan.Bindings.PubKey.ECDSA + +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.PubKey + +privKeyLoadECDSA + :: MP -- ^ __scalar__ + -> ByteString -- ^ __curve_name__ + -> IO PrivKey -- ^ __key__ +privKeyLoadECDSA = mkPrivKeyLoad1_name botan_privkey_load_ecdsa + +pubKeyLoadECDSA + :: MP -- ^ __public_x__ + -> MP -- ^ __public_y__ + -> ByteString -- ^ __curve_name__ + -> IO PubKey -- ^ __key__ +pubKeyLoadECDSA = mkPubKeyLoad2_name botan_pubkey_load_ecdsa diff --git a/src/Botan/Low/PubKey/Ed25519.hs b/src/Botan/Low/PubKey/Ed25519.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/Ed25519.hs @@ -0,0 +1,52 @@ +{-| +Module : Botan.Low.Ed25519 +Description : Algorithm specific key operations: Ed25519 +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.Ed25519 where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey +import Botan.Bindings.PubKey.Ed25519 + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.PubKey +import Botan.Low.Remake + +-- /* +-- * Algorithm specific key operations: Ed25519 +-- */ + +-- NOTE: Input must be exactly 32 bytes long +privKeyLoadEd25519 + :: ByteString -- ^ __privkey[32]__ + -> IO PrivKey -- ^ __key__ +privKeyLoadEd25519 = mkCreateObjectCBytes createPrivKey botan_privkey_load_ed25519 + +-- NOTE: Input must be exactly 32 bytes long +pubKeyLoadEd25519 + :: ByteString -- ^ __pubkey[32]__ + -> IO PubKey -- ^ __key__ +pubKeyLoadEd25519 = mkCreateObjectCBytes createPubKey botan_pubkey_load_ed25519 + +privKeyEd25519GetPrivKey + :: PrivKey -- ^ __output[64]__ + -> IO ByteString -- ^ __key__ +privKeyEd25519GetPrivKey sk = withPrivKey sk $ \ skPtr -> do + allocBytes 64 $ \ outPtr -> do + throwBotanIfNegative_ $ botan_privkey_ed25519_get_privkey skPtr outPtr + +pubKeyEd25519GetPubKey + :: PubKey -- ^ __pubkey[32]__ + -> IO ByteString -- ^ __key__ +pubKeyEd25519GetPubKey pk = withPubKey pk $ \ pkPtr -> do + allocBytes 32 $ \ outPtr -> do + throwBotanIfNegative_ $ botan_pubkey_ed25519_get_pubkey pkPtr outPtr diff --git a/src/Botan/Low/PubKey/ElGamal.hs b/src/Botan/Low/PubKey/ElGamal.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/ElGamal.hs @@ -0,0 +1,53 @@ +{-| +Module : Botan.Low.ElGamal +Description : Algorithm specific key operations: ElGamal +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.ElGamal where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey +import Botan.Bindings.PubKey.ElGamal + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.PubKey +import Botan.Low.RNG + +-- /* +-- * Algorithm specific key operations: ElGamal +-- */ + +privKeyCreateElGamal + :: RNG -- ^ __rng__: initialized PRNG + -> Int -- ^ __pbits__: length of the key in bits. Must be at least 1024 + -> Int -- ^ __qbits__: order of the subgroup. Must be at least 160 + -> IO PrivKey -- ^ __key__: handler to the resulting key +privKeyCreateElGamal rng pbits qbits = withRNG rng $ \ botanRNG -> do + createPrivKey $ \ out -> botan_privkey_create_elgamal + out + botanRNG + (fromIntegral pbits) + (fromIntegral qbits) + +privKeyLoadElGamal + :: MP -- ^ __p__: prime order of a Z_p group + -> MP -- ^ __g__: group generator + -> MP -- ^ __x__: public key + -> IO PrivKey -- ^ __key__: variable populated with key material +privKeyLoadElGamal = mkPrivKeyLoad3 botan_privkey_load_elgamal + +pubKeyLoadElGamal + :: MP -- ^ __p__: prime order of a Z_p group + -> MP -- ^ __g__: group generator + -> MP -- ^ __y__: private key + -> IO PubKey -- ^ __key__: variable populated with key material +pubKeyLoadElGamal = mkPubKeyLoad3 botan_pubkey_load_elgamal diff --git a/src/Botan/Low/PubKey/Encrypt.hs b/src/Botan/Low/PubKey/Encrypt.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/Encrypt.hs @@ -0,0 +1,93 @@ +{-| +Module : Botan.Low.Encrypt +Description : Public Key Encryption +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.Encrypt +( + +-- * Public key encryption + Encrypt(..) +, withEncrypt +, encryptCreate +, encryptDestroy +, encryptOutputLength +, encrypt + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey.Encrypt + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.Remake + +-- /* +-- * Public Key Encryption +-- */ + +newtype Encrypt = MkEncrypt { getEncryptForeignPtr :: ForeignPtr BotanPKOpEncryptStruct } + +newEncrypt :: BotanPKOpEncrypt -> IO Encrypt +withEncrypt :: Encrypt -> (BotanPKOpEncrypt -> IO a) -> IO a +encryptDestroy :: Encrypt -> IO () +createEncrypt :: (Ptr BotanPKOpEncrypt -> IO CInt) -> IO Encrypt +(newEncrypt, withEncrypt, encryptDestroy, createEncrypt, _) + = mkBindings + MkBotanPKOpEncrypt runBotanPKOpEncrypt + MkEncrypt getEncryptForeignPtr + botan_pk_op_encrypt_destroy + +encryptCreate + :: PubKey -- ^ __key__ + -> EMEName -- ^ __padding__ + -> IO Encrypt -- ^ __op__ +encryptCreate pk padding = withPubKey pk $ \ pkPtr -> do + asCString padding $ \ paddingPtr -> do + createEncrypt $ \ out -> botan_pk_op_encrypt_create + out + pkPtr + (ConstPtr paddingPtr) + 0 + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withEncryptCreate :: PubKey -> EMEName -> (Encrypt -> IO a) -> IO a +withEncryptCreate = mkWithTemp2 encryptCreate encryptDestroy + +encryptOutputLength + :: Encrypt -- ^ __op__ + -> Int -- ^ __ptext_len__ + -> IO Int -- ^ __ctext_len__ +encryptOutputLength = mkGetSize_csize withEncrypt botan_pk_op_encrypt_output_length + +-- NOTE: This properly takes advantage of szPtr, queries the buffer size - do this elsewhere +-- NOTE: SM2 take a hash instead of a padding, and encrypt fails with InsufficientBufferSpace +-- if sm2p256v1 is not used as the curve when creating the key (but creating the key and +-- the encryption context do not fail) +-- This implies that encryptOutputLength may be wrong or hardcoded for SM2 or that we +-- are not supposed to use curves other than sm2p256v1 - this needs investigating +encrypt + :: Encrypt -- ^ __op__ + -> RNG -- ^ __rng__ + -> ByteString -- ^ __plaintext[]__ + -> IO ByteString -- ^ __ciphertext[]__ +encrypt enc rng ptext = withEncrypt enc $ \ encPtr -> do + withRNG rng $ \ botanRNG -> do + asBytesLen ptext $ \ ptextPtr ptextLen -> do + allocBytesQuerying $ \ outPtr szPtr -> botan_pk_op_encrypt + encPtr + botanRNG + outPtr + szPtr + ptextPtr + ptextLen diff --git a/src/Botan/Low/PubKey/KeyAgreement.hs b/src/Botan/Low/PubKey/KeyAgreement.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/KeyAgreement.hs @@ -0,0 +1,199 @@ +{-| +Module : Botan.Low.KeyAgreement +Description : Key Agreement +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.KeyAgreement +( + +-- * PK Key Agreement +-- $introduction +-- * Usage +-- $usage + +-- * Key agreement + KeyAgreement(..) +, withKeyAgreement +, keyAgreementCreate +, keyAgreementDestroy +, keyAgreementExportPublic +, keyAgreementSize +, keyAgreement + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey.KeyAgreement + +import Botan.Low.Error +import Botan.Low.KDF +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.PubKey +import Botan.Low.Remake + +{- $introduction + +Key agreement is a scheme where two parties exchange public keys, after which +it is possible for them to derive a secret key which is known only to the two +of them. + +There are different approaches possible for key agreement. In many protocols, +both parties generate a new key, exchange public keys, and derive a secret, +after which they throw away their private keys, using them only the once. +However this requires the parties to both be online and able to communicate +with each other. + +In other protocols, one of the parties publishes their public key online in +some way, and then it is possible for someone to send encrypted messages to +that recipient by generating a new keypair, performing key exchange with the +published public key, and then sending both the message along with their +ephemeral public key. Then the recipient uses the provided public key along +with their private key to complete the key exchange, recover the shared secret, +and decrypt the message. + +Typically the raw output of the key agreement function is not uniformly +distributed, and may not be of an appropriate length to use as a key. To +resolve these problems, key agreement will use a Key Derivation Functions (KDF) +on the shared secret to produce an output of the desired length. + +- ECDH over GF(p) Weierstrass curves +- ECDH over x25519 +- DH over prime fields + +-} + +{- $usage + +First, Alice and Bob generate their private keys: + +> import Botan.Low.PubKey +> import Botan.Low.PubKey.KeyAgreement +> import Botan.Low.RNG +> import Botan.Low.Hash +> import Botan.Low.KDF +> rng <- rngInit "system" +> -- Alice creates her private key +> alicePrivKey <- privKeyCreate ECDH Secp521r1 rng +> -- Bob creates his private key +> bobPrivKey <- privKeyCreate ECDH Secp521r1 rng + +Then, they exchange their public keys using any channel, private or public: + +> -- Alice and Bob exchange public keys +> alicePubKey <- keyAgreementExportPublic alicePrivKey +> bobPubKey <- keyAgreementExportPublic bobPrivKey +> -- ... + +Then, they may separately generate the same agreed-upon key and a randomized, +agreed-upon salt: + +> salt <- rngGet rng 4 +> -- Alice generates her shared key: +> aliceKeyAgreement <- keyAgreementCreate alicePrivKey (kdf2 SHA256) +> aliceSharedKey <- keyAgreement aliceKeyAgreement bobPubKey salt +> -- Bob generates his shared key: +> bobKeyAgreement <- keyAgreementCreate bobPrivKey (kdf2 SHA256) +> bobSharedKey <- keyAgreement bobKeyAgreement alicePubKey salt +> -- They are the same +> aliceSharedKey == bobSharedKey +> -- True + +> WARNING: There used to be a memory leak in keyAgreement. Please +> report this bug to the maintainers if it returns. + +-} + +newtype KeyAgreement = MkKeyAgreement { getKeyAgreementForeignPtr :: ForeignPtr BotanPKOpKeyAgreementStruct } + +newKeyAgreement :: BotanPKOpKeyAgreement -> IO KeyAgreement +withKeyAgreement :: KeyAgreement -> (BotanPKOpKeyAgreement -> IO a) -> IO a +keyAgreementDestroy :: KeyAgreement -> IO () +createKeyAgreement :: (Ptr BotanPKOpKeyAgreement -> IO CInt) -> IO KeyAgreement +(newKeyAgreement, withKeyAgreement, keyAgreementDestroy, createKeyAgreement, _) + = mkBindings + MkBotanPKOpKeyAgreement runBotanPKOpKeyAgreement + MkKeyAgreement getKeyAgreementForeignPtr + botan_pk_op_key_agreement_destroy + +-- NOTE: Silently uses the system RNG +keyAgreementCreate + :: PrivKey -- ^ __key__ + -> KDFName -- ^ __kdf__ + -> IO KeyAgreement -- ^ __op__ +keyAgreementCreate sk algo = withPrivKey sk $ \ skPtr -> do + asCString algo $ \ algoPtr -> do + createKeyAgreement $ \ out -> botan_pk_op_key_agreement_create + out + skPtr + (ConstPtr algoPtr) + 0 + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withKeyAgreementCreate :: PrivKey -> KDFName -> (KeyAgreement -> IO a) -> IO a +withKeyAgreementCreate = mkWithTemp2 keyAgreementCreate keyAgreementDestroy + +-- NOTE: I do not know if this provides a different functionality than just being +-- an alias for botan_privkey_export_pubkey / privKeyExportPubKey +-- Observe that it *does* just take a privkey, instead of a keyagreement +-- It may simply be here for convenience. +{- +int botan_pk_op_key_agreement_export_public(botan_privkey_t key, uint8_t out[], size_t* out_len) { + return copy_view_bin(out, out_len, botan_pk_op_key_agreement_view_public, key); +} + +int botan_pk_op_key_agreement_view_public(botan_privkey_t key, botan_view_ctx ctx, botan_view_bin_fn view) { + return BOTAN_FFI_VISIT(key, [=](const auto& k) -> int { + if(auto kak = dynamic_cast(&k)) + return invoke_view_callback(view, ctx, kak->public_value()); + else + return BOTAN_FFI_ERROR_INVALID_INPUT; + }); +} +-} +keyAgreementExportPublic + :: PrivKey -- ^ __key__ + -> IO ByteString -- ^ __out[]__ +keyAgreementExportPublic sk = withPrivKey sk $ \ skPtr -> do + allocBytesQuerying $ \ outPtr outLen -> botan_pk_op_key_agreement_export_public + skPtr + outPtr + outLen + +keyAgreementSize + :: KeyAgreement -- ^ __op__ + -> IO Int -- ^ __out_len__ +keyAgreementSize = mkGetSize withKeyAgreement botan_pk_op_key_agreement_size + +{-# WARNING keyAgreement "This function was leaking memory and causing crashes. Please observe carefully and report any future leaks." #-} +keyAgreement + :: KeyAgreement -- ^ __op__ + -> ByteString -- ^ __out[]__ + -> ByteString -- ^ __other_key[]__ + -> IO ByteString -- ^ __salt[]__ +keyAgreement ka key salt = withKeyAgreement ka $ \ kaPtr -> do + asBytesLen key $ \ keyPtr keyLen -> do + asBytesLen salt $ \ saltPtr saltLen -> do + outSz <- keyAgreementSize ka + alloca $ \ szPtr -> do + -- NOTE: This poke was necessary to stop a memory leak + -- Similar pokes have been needed elsewere + -- TODO: Ensure that all alloca szPtr elsewhere are properly poked + poke szPtr (fromIntegral outSz) + out <- allocBytes outSz $ \ outPtr -> do + throwBotanIfNegative_ $ botan_pk_op_key_agreement + kaPtr + outPtr + szPtr + (ConstPtr keyPtr) + keyLen + (ConstPtr saltPtr) + saltLen + sz <- fromIntegral <$> peek szPtr + return $! ByteString.take sz out diff --git a/src/Botan/Low/PubKey/KeyEncapsulation.hs b/src/Botan/Low/PubKey/KeyEncapsulation.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/KeyEncapsulation.hs @@ -0,0 +1,251 @@ +{-| +Module : Botan.Low.KeyEncapsulation +Description : Key Encapsulation +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.KeyEncapsulation +( + +-- * PK Key Encapsulation +-- $introduction +-- * Usage +-- $usage + +-- * KEM Encryption + KEMSharedKey(..) +, KEMEncapsulatedKey(..) +, KEMEncrypt(..) +, withKEMEncrypt +, kemEncryptDestroy +, kemEncryptCreate +, kemEncryptSharedKeyLength +, kemEncryptEncapsulatedKeyLength +, kemEncryptCreateSharedKey + +-- * KEM Decryption +, KEMDecrypt(..) +, withKEMDecrypt +, kemDecryptDestroy +, kemDecryptCreate +, kemDecryptSharedKeyLength +, kemDecryptSharedKey + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey.KeyEncapsulation + +import Botan.Low.Error +import Botan.Low.KDF +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.PubKey +import Botan.Low.Remake +import Botan.Low.RNG + +{- $introduction + +Key encapsulation (KEM) is a variation on public key encryption which is +commonly used by post-quantum secure schemes. Instead of choosing a random +secret and encrypting it, as in typical public key encryption, a KEM encryption +takes no inputs and produces two values, the shared secret and the encapsulated +key. The decryption operation takes in the encapsulated key and returns the +shared secret. + +-} + +{- $usage + +> NOTE: KEM only requires the public knowledge of one person's key pair, unlike +> Key Agreement. + +First, Alice generates her private and public key pair: + +> import Botan.Low.PubKey +> import Botan.Low.PubKey.KeyEncapsulation +> import Botan.Low.Hash +> import Botan.Low.KDF +> import Botan.Low.RNG +> rng <- rngInit UserRNG +> -- Alice generates her private and public keys +> alicePrivKey <- privKeyCreate RSA "2048" rng +> alicePubKey <- privKeyExportPubKey alicePrivKey + +Then, Alice shares her public key somewhere where others can see. When Bob +wants to create a shared key with Alice, they choose a KDF algorithm, generate +a salt, and choose a shared key length. + +> kdfAlg = hkdf SHA256 +> salt <- rngGet rng 4 +> sharedKeyLength = 256 + +Then, Bob generates the shared + encapsulated key, and sends the +encapsulated key to Alice: + +> encryptCtx <- kemEncryptCreate alicePubKey kdfAlg +> (bobSharedKey, encapsulatedKey) <- kemEncryptCreateSharedKey encryptCtx rng salt sharedKeyLength +> -- sendToAlice encapsulatedKey + +Upon receiving the encapsulated key, Alice can decrypt and extract the shared +key using her private key: + +> decryptCtx <- kemDecryptCreate alicePrivKey kdfAlg +> aliceSharedKey <- kemDecryptSharedKey decryptCtx salt encapsulatedKey sharedKeyLength +> bobSharedKey == aliceSharedKey +> -- True + +Then, this shared key may be used for any suitable purpose. + +-} + +-- TODO: KEM supports the following key types: +-- RSA +-- Kyber +-- McEliece +-- https://botan.randombit.net/handbook/api_ref/pubkey.html#key-encapsulation +-- KYBER is post-quantum + +type KEMSharedKey = ByteString +type KEMEncapsulatedKey = ByteString + +newtype KEMEncrypt = MkKEMEncrypt { getKEMEncryptForeignPtr :: ForeignPtr BotanPKOpKEMEncryptStruct } + +newKEMEncrypt :: BotanPKOpKEMEncrypt -> IO KEMEncrypt +withKEMEncrypt :: KEMEncrypt -> (BotanPKOpKEMEncrypt -> IO a) -> IO a +kemEncryptDestroy :: KEMEncrypt -> IO () +createKEMEncrypt :: (Ptr BotanPKOpKEMEncrypt -> IO CInt) -> IO KEMEncrypt +(newKEMEncrypt, withKEMEncrypt, kemEncryptDestroy, createKEMEncrypt, _) + = mkBindings + MkBotanPKOpKEMEncrypt runBotanPKOpKEMEncrypt + MkKEMEncrypt getKEMEncryptForeignPtr + botan_pk_op_kem_encrypt_destroy + + + + + +kemEncryptCreate + :: PubKey -- ^ __key__ + -> KDFName -- ^ __kdf__ + -> IO KEMEncrypt -- ^ __op__ +kemEncryptCreate pk algo = withPubKey pk $ \ pkPtr -> do + asCString algo $ \ algoPtr -> do + createKEMEncrypt $ \ out -> botan_pk_op_kem_encrypt_create + out + pkPtr + (ConstPtr algoPtr) + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withKEMEncryptCreate :: PubKey -> KDFName -> (KEMEncrypt -> IO a) -> IO a +withKEMEncryptCreate = mkWithTemp2 kemEncryptCreate kemEncryptDestroy + +kemEncryptSharedKeyLength + :: KEMEncrypt -- ^ __op__ + -> Int -- ^ __desired_shared_key_length__ + -> IO Int -- ^ __output_shared_key_length__ +kemEncryptSharedKeyLength = mkGetSize_csize withKEMEncrypt botan_pk_op_kem_encrypt_shared_key_length + + +kemEncryptEncapsulatedKeyLength + :: KEMEncrypt -- ^ __op__ + -> IO Int -- ^ __output_encapsulated_key_length__ +kemEncryptEncapsulatedKeyLength = mkGetSize withKEMEncrypt botan_pk_op_kem_encrypt_encapsulated_key_length + +-- NOTE: Awkward because of double-query and returning double bytestrings +-- Cannot use allocBytesQuerying because of double-return +-- NOTE: Returns (SharedKey, EncapsulatedKey) + + +kemEncryptCreateSharedKey + :: KEMEncrypt -- ^ __op__ + -> RNG -- ^ __rng__ + -> ByteString -- ^ __salt[]__ + -> Int -- ^ __desired_shared_key_len__ + -> IO (KEMSharedKey,KEMEncapsulatedKey) -- ^ __(shared_key,encapsulated_key)__ +kemEncryptCreateSharedKey ke rng salt desiredLen = withKEMEncrypt ke $ \ kePtr -> do + withRNG rng $ \ botanRNG -> do + asBytesLen salt $ \ saltPtr saltLen -> do + alloca $ \ sharedSzPtr -> do + alloca $ \ encapSzPtr -> do + sharedSz <- kemEncryptSharedKeyLength ke desiredLen + encapSz <- kemEncryptEncapsulatedKeyLength ke + poke sharedSzPtr (fromIntegral sharedSz) + poke encapSzPtr (fromIntegral encapSz) + allocBytesWith encapSz $ \ encapPtr -> do + allocBytes sharedSz $ \ sharedPtr -> do + throwBotanIfNegative_ $ botan_pk_op_kem_encrypt_create_shared_key + kePtr + botanRNG + (ConstPtr saltPtr) + saltLen + (fromIntegral desiredLen) + sharedPtr + sharedSzPtr + encapPtr + encapSzPtr + +newtype KEMDecrypt = MkKEMDecrypt { getKEMDecryptForeignPtr :: ForeignPtr BotanPKOpKEMDecryptStruct } + +newKEMDecrypt :: BotanPKOpKEMDecrypt -> IO KEMDecrypt +withKEMDecrypt :: KEMDecrypt -> (BotanPKOpKEMDecrypt -> IO a) -> IO a +kemDecryptDestroy :: KEMDecrypt -> IO () +createKEMDecrypt :: (Ptr BotanPKOpKEMDecrypt -> IO CInt) -> IO KEMDecrypt +(newKEMDecrypt, withKEMDecrypt, kemDecryptDestroy, createKEMDecrypt, _) + = mkBindings + MkBotanPKOpKEMDecrypt runBotanPKOpKEMDecrypt + MkKEMDecrypt getKEMDecryptForeignPtr + botan_pk_op_kem_decrypt_destroy + +kemDecryptCreate + :: PrivKey -- ^ __key__ + -> KDFName -- ^ __kdf__ + -> IO KEMDecrypt -- ^ __op__ +kemDecryptCreate sk algo = withPrivKey sk $ \ skPtr -> do + asCString algo $ \ algoPtr -> do + createKEMDecrypt $ \ out -> botan_pk_op_kem_decrypt_create + out + skPtr + (ConstPtr algoPtr) + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withKEMDecryptCreate :: PrivKey -> KDFName -> (KEMDecrypt -> IO a) -> IO a +withKEMDecryptCreate = mkWithTemp2 kemDecryptCreate kemDecryptDestroy + +kemDecryptSharedKeyLength + :: KEMDecrypt -- ^ __op__ + -> Int -- ^ __desired_shared_key_length__ + -> IO Int -- ^ __output_shared_key_length__ +kemDecryptSharedKeyLength = mkGetSize_csize withKEMDecrypt botan_pk_op_kem_decrypt_shared_key_length + +kemDecryptSharedKey + :: KEMDecrypt -- ^ __op__ + -> ByteString -- ^ __salt[]__ + -> KEMEncapsulatedKey -- ^ __encapsulated_key[]__ + -> Int -- ^ __desired_shared_key_len__ + -> IO KEMSharedKey -- ^ __shared_key[]__ +kemDecryptSharedKey kd salt encap desiredLen = withKEMDecrypt kd $ \ kdPtr -> do + asBytesLen salt $ \ saltPtr saltLen -> do + asBytesLen encap $ \ encapPtr encapLen -> do + -- TODO: Consolidate with allocBytesUpperBound or whatever I end up calling it + alloca $ \ sharedSzPtr -> do + sharedSz <- kemDecryptSharedKeyLength kd desiredLen + poke sharedSzPtr (fromIntegral sharedSz) + bytes <- allocBytes sharedSz $ \ outPtr -> do + throwBotanIfNegative_ $ botan_pk_op_kem_decrypt_shared_key + kdPtr + (ConstPtr saltPtr) + saltLen + (ConstPtr encapPtr) + encapLen + (fromIntegral desiredLen) + outPtr + sharedSzPtr + actualSharedSz <- peek sharedSzPtr + return $!! ByteString.take (fromIntegral actualSharedSz) bytes + diff --git a/src/Botan/Low/PubKey/RSA.hs b/src/Botan/Low/PubKey/RSA.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/RSA.hs @@ -0,0 +1,51 @@ +{-| +Module : Botan.Low.RSA +Description : Algorithm specific key operations: RSA +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.RSA where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey.RSA + +import Botan.Low.Error +import Botan.Low.Remake +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.PubKey + +-- /* +-- * Algorithm specific key operations: RSA +-- */ + +privKeyLoadRSA + :: MP -- ^ __p__ + -> MP -- ^ __q__ + -> MP -- ^ __e__ + -> IO PrivKey -- ^ __key__ +privKeyLoadRSA = mkPrivKeyLoad3 botan_privkey_load_rsa + +privKeyLoadRSA_PKCS1 + :: ByteString -- ^ __bits__ + -> IO PrivKey -- ^ __key__ +privKeyLoadRSA_PKCS1 = mkCreateObjectCBytesLen createPrivKey botan_privkey_load_rsa_pkcs1 + +privKeyRSAGetPrivKey + :: PrivKey -- ^ __rsa_key__ + -> Word32 -- ^ __flags__ + -> IO ByteString -- ^ __out__ +-- WRONG: privKeyRSAGetPrivKey = mkCreateObjectCBytesLen1 botan_privkey_rsa_get_privkey +privKeyRSAGetPrivKey = mkWithObjectGetterCBytesLen1 withPrivKey + $ \ rsa_key flags out out_len -> botan_privkey_rsa_get_privkey rsa_key out out_len flags + +pubKeyLoadRSA + :: MP -- ^ __n__ + -> MP -- ^ __e__ + -> IO PubKey -- ^ __key__ +pubKeyLoadRSA = mkPubKeyLoad2 botan_pubkey_load_rsa diff --git a/src/Botan/Low/PubKey/SM2.hs b/src/Botan/Low/PubKey/SM2.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/SM2.hs @@ -0,0 +1,29 @@ +module Botan.Low.PubKey.SM2 where + +import Botan.Bindings.PubKey +import Botan.Bindings.PubKey.SM2 + +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.PubKey + +privKeyLoadSM2 + :: MP -- ^ __scalar__ + -> ByteString -- ^ __curve_name__ + -> IO PrivKey -- ^ __key__ +privKeyLoadSM2 = mkPrivKeyLoad1_name botan_privkey_load_sm2 + +pubKeyLoadSM2 + :: MP -- ^ __public_x__ + -> MP -- ^ __public_y__ + -> ByteString -- ^ __curve_name__ + -> IO PubKey -- ^ __key__ +pubKeyLoadSM2 = mkPubKeyLoad2_name botan_pubkey_load_sm2 + +-- TODO: +-- pubKeySM2ComputeZA +-- :: ByteString -- ^ __ident__ +-- -> ByteString -- ^ __hash_algo__ +-- -> PubKey -- ^ __key__ +-- -> IO ByteString -- ^ __out[]__ +-- pubKeySM2omputeZA = undefined diff --git a/src/Botan/Low/PubKey/Sign.hs b/src/Botan/Low/PubKey/Sign.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/Sign.hs @@ -0,0 +1,129 @@ +{-| +Module : Botan.Low.PubKey.Sign +Description : Signature Generation +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.Sign +( + +-- * Public key signatures + Sign(..) +, SigningFlags(..) +, pattern StandardFormatSignature +, pattern DERFormatSignature +, withSign +, signCreate +, signDestroy +, signOutputLength +, signUpdate +, signFinish + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey.Sign + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.Remake + +-- /* +-- * Signature Generation +-- */ + +newtype Sign = MkSign { getSignForeignPtr :: ForeignPtr BotanPKOpSignStruct } + +newSign :: BotanPKOpSign -> IO Sign +withSign :: Sign -> (BotanPKOpSign -> IO a) -> IO a +signDestroy :: Sign -> IO () +createSign :: (Ptr BotanPKOpSign -> IO CInt) -> IO Sign +(newSign, withSign, signDestroy, createSign, _) + = mkBindings + MkBotanPKOpSign runBotanPKOpSign + MkSign getSignForeignPtr + botan_pk_op_sign_destroy + +-- TODO: Rename SignAlgoParams / SigningParams +type SignAlgoName = ByteString + +type SigningFlags = Word32 + +pattern StandardFormatSignature -- ^ Not an actual flags + , DERFormatSignature + :: SigningFlags +pattern StandardFormatSignature = BOTAN_PUBKEY_STD_FORMAT_SIGNATURE +pattern DERFormatSignature = BOTAN_PUBKEY_DER_FORMAT_SIGNATURE + +signCreate + :: PrivKey -- ^ __key__ + -> EMSAName -- ^ __hash_and_padding__ + -> SigningFlags -- ^ __flags__ + -> IO Sign -- ^ __op__ +signCreate sk algo flags = withPrivKey sk $ \ skPtr -> do + asCString algo $ \ algoPtr -> do + createSign $ \ out -> botan_pk_op_sign_create + out + skPtr + (ConstPtr algoPtr) + flags + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withSignCreate :: PrivKey -> EMSAName -> SigningFlags -> (Sign -> IO a) -> IO a +withSignCreate = mkWithTemp3 signCreate signDestroy + +signOutputLength + :: Sign -- ^ __op__ + -> IO Int -- ^ __olen__ +signOutputLength = mkGetSize withSign botan_pk_op_sign_output_length + +signUpdate + :: Sign -- ^ __op__ + -> ByteString -- ^ __in[]__ + -> IO () +-- signUpdate = mkSetBytesLen withSign botan_pk_op_sign_update +signUpdate = mkWithObjectSetterCBytesLen withSign botan_pk_op_sign_update + +-- TODO: Signature type +-- NOTE: This function is still highly suspect +signFinish + :: Sign -- ^ __op__ + -> RNG -- ^ __rng__ + -> IO ByteString -- ^ __sig[]__ +signFinish sign rng = withSign sign $ \ signPtr -> do + withRNG rng $ \ botanRNG -> do + -- NOTE: Investigation into DER format shows lots of trailing nulls that may need to be trimmed + -- using the output of szPtr if sz is just an upper-bound estimate + -- sz <- signOutputLength sign + -- allocBytes sz $ \ sigPtr -> do + -- alloca $ \ szPtr -> do + -- poke szPtr (fromIntegral sz) + -- throwBotanIfNegative_ $ botan_pk_op_sign_finish signPtr botanRNG sigPtr szPtr + -- NOTE: This doesn't work, I think the output length poke is necessary + -- allocBytesQuerying $ \ sigPtr szPtr -> do + -- botan_pk_op_sign_finish signPtr botanRNG sigPtr szPtr + -- NOTE: Trying combo, this should be packaged as allocBytesUpperBound or something + -- We get an upper bound, allocate at least that many, poke the size, perform the + -- op, read the actual size, and trim. + sz <- signOutputLength sign + (sz',bytes) <- allocBytesWith sz $ \ sigPtr -> do + alloca $ \ szPtr -> do + poke szPtr (fromIntegral sz) + throwBotanIfNegative_ $ botan_pk_op_sign_finish signPtr botanRNG sigPtr szPtr + peek szPtr + return $!! ByteString.take (fromIntegral sz') bytes +{-# WARNING signFinish "Depending on the algorithm, signatures produced using StandardFormatSignature may have trailing null bytes." #-} + +-- /** +-- * Signature Scheme Utility Functions +-- */ + +-- TODO: botan_pkcs_hash_id diff --git a/src/Botan/Low/PubKey/Verify.hs b/src/Botan/Low/PubKey/Verify.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/Verify.hs @@ -0,0 +1,87 @@ +{-| +Module : Botan.Low.Verify +Description : Signature Verification +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.Verify +( + +-- * Public key signature verification + Verify(..) +, withVerify +, verifyCreate +, verifyDestroy +, verifyUpdate +, verifyFinish + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey.Verify + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.Sign (SigningFlags(..)) +import Botan.Low.Remake + +-- /* +-- * Signature Verification +-- */ + +newtype Verify = MkVerify { getVerifyForeignPtr :: ForeignPtr BotanPKOpVerifyStruct } + +newVerify :: BotanPKOpVerify -> IO Verify +withVerify :: Verify -> (BotanPKOpVerify -> IO a) -> IO a +verifyDestroy :: Verify -> IO () +createVerify :: (Ptr BotanPKOpVerify -> IO CInt) -> IO Verify +(newVerify, withVerify, verifyDestroy, createVerify, _) + = mkBindings + MkBotanPKOpVerify runBotanPKOpVerify + MkVerify getVerifyForeignPtr + botan_pk_op_verify_destroy + +type VerifyAlgo = ByteString + +verifyCreate + :: PubKey -- ^ __key__ + -> EMSAName -- ^ __hash_and_padding__ + -> SigningFlags -- ^ __flags__ + -> IO Verify -- ^ __op__ +verifyCreate pk algo flags = withPubKey pk $ \ pkPtr -> do + asCString algo $ \ algoPtr -> do + createVerify $ \ out -> botan_pk_op_verify_create + out + pkPtr + (ConstPtr algoPtr) + flags + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withVerifyCreate :: PubKey -> EMSAName -> SigningFlags -> (Verify -> IO a) -> IO a +withVerifyCreate = mkWithTemp3 verifyCreate verifyDestroy + +verifyUpdate + :: Verify -- ^ __op__ + -> ByteString -- ^ __in[]__ + -> IO () +verifyUpdate = mkWithObjectSetterCBytesLen withVerify botan_pk_op_verify_update + +-- TODO: Signature type +verifyFinish + :: Verify -- ^ __op__ + -> ByteString -- ^ __sig[]__ + -> IO Bool +verifyFinish verify sig = withVerify verify $ \ verifyPtr -> do + asBytesLen sig $ \ sigPtr sigLen -> do + throwBotanCatchingSuccess $ botan_pk_op_verify_finish + verifyPtr + (ConstPtr sigPtr) + sigLen diff --git a/src/Botan/Low/PubKey/X25519.hs b/src/Botan/Low/PubKey/X25519.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PubKey/X25519.hs @@ -0,0 +1,59 @@ +{-| +Module : Botan.Low.X25519 +Description : Algorithm specific key operations: X25519 +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.PubKey.X25519 where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PubKey + +import Botan.Bindings.PubKey.X25519 + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.MPI +import Botan.Low.Prelude +import Botan.Low.PubKey +import Botan.Low.Remake + +-- /* +-- * Algorithm specific key operations: X25519 +-- */ + +-- NOTE: X25519 is Curve25519: +-- lib/pubkey/curve25519/curve25519.h: +-- typedef Curve25519_PublicKey X25519_PublicKey; +-- typedef Curve25519_PrivateKey X25519_PrivateKey; + +-- NOTE: Input must be exactly 32 bytes long +privKeyLoadX25519 + :: ByteString -- ^ __privkey[32]__ + -> IO PrivKey -- ^ __key__ +privKeyLoadX25519 = mkCreateObjectCBytes createPrivKey botan_privkey_load_x25519 + +-- NOTE: Input must be exactly 32 bytes long +pubKeyLoadX25519 + :: ByteString -- ^ __pubkey[32]__ + -> IO PubKey -- ^ __key__ +pubKeyLoadX25519 = mkCreateObjectCBytes createPubKey botan_pubkey_load_x25519 + +privKeyX25519GetPrivKey + :: PrivKey -- ^ __key__ + -> IO ByteString -- ^ __output[32]__ +privKeyX25519GetPrivKey sk = withPrivKey sk $ \ skPtr -> do + allocBytes 32 $ \ outPtr -> do + throwBotanIfNegative_ $ botan_privkey_x25519_get_privkey skPtr outPtr + +pubKeyX25519GetPubKey + :: PubKey -- ^ __key__ + -> IO ByteString -- ^ __pubkey[32]__ +pubKeyX25519GetPubKey pk = withPubKey pk $ \ pkPtr -> do + allocBytes 32 $ \ outPtr -> do + throwBotanIfNegative_ $ botan_pubkey_x25519_get_pubkey pkPtr outPtr diff --git a/src/Botan/Low/PwdHash.hs b/src/Botan/Low/PwdHash.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/PwdHash.hs @@ -0,0 +1,130 @@ +{-| +Module : Botan.Low.PwdHash +Description : Password hashing +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +Derive a key from a passphrase +-} + +module Botan.Low.PwdHash +( + +-- * Password hashing + + PBKDFName(..) +, pwdhash +, pwdhashTimed + +-- * Password hashing algorithms + +, pattern PBKDF2 +, pbkdf2 +, pattern Scrypt +, pattern Argon2d +, pattern Argon2i +, pattern Argon2id +, pattern Bcrypt_PBKDF +, pattern OpenPGP_S2K +, openPGP_S2K + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.PwdHash + +import Botan.Low.Hash +import Botan.Low.MAC +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude + +type PBKDFName = ByteString + +pattern PBKDF2 + , Scrypt + , Argon2d + , Argon2i + , Argon2id + , Bcrypt_PBKDF + , OpenPGP_S2K + :: PBKDFName + +pattern PBKDF2 = BOTAN_PBKDF_PBKDF2 +pattern Scrypt = BOTAN_PBKDF_SCRYPT +pattern Argon2d = BOTAN_PBKDF_ARGON2D +pattern Argon2i = BOTAN_PBKDF_ARGON2I +pattern Argon2id = BOTAN_PBKDF_ARGON2ID +pattern Bcrypt_PBKDF = BOTAN_PBKDF_BCRYPT_PBKDF +pattern OpenPGP_S2K = BOTAN_PBKDF_OPENPGP_S2K + +-- NOTE: May require HMAC +pbkdf2 :: MACName -> PBKDFName +pbkdf2 m = PBKDF2 /$ m + +openPGP_S2K:: HashName -> PBKDFName +openPGP_S2K h = OpenPGP_S2K /$ h + +-- NOTE: Should passphrase be Text or ByteString? Text is implied by use of const char* +-- as well as the non-null context implied by passphrase_len == 0. ByteString for now. +pwdhash + :: PBKDFName -- ^ __algo__: PBKDF algorithm, e.g., "Scrypt" or "PBKDF2(SHA-256)" + -> Int -- ^ __param1__: the first PBKDF algorithm parameter + -> Int -- ^ __param2__: the second PBKDF algorithm parameter (may be zero if unneeded) + -> Int -- ^ __param3__: the third PBKDF algorithm parameter (may be zero if unneeded) + -> Int -- ^ __out_len__: the desired length of the key to produce + -> ByteString -- ^ __passphrase__: the password to derive the key from + -> ByteString -- ^ __salt[]__: a randomly chosen salt + -> IO ByteString -- ^ __out[]__: buffer to store the derived key, must be of out_len bytes +pwdhash algo p1 p2 p3 outLen passphrase salt = allocBytes outLen $ \ outPtr -> do + asCString algo $ \ algoPtr -> do + asCStringLen passphrase $ \ passphrasePtr passphraseLen -> do + asBytesLen salt $ \ saltPtr saltLen -> do + throwBotanIfNegative_ $ botan_pwdhash + (ConstPtr algoPtr) + (fromIntegral p1) + (fromIntegral p2) + (fromIntegral p3) + outPtr + (fromIntegral outLen) + (ConstPtr passphrasePtr) + passphraseLen + (ConstPtr saltPtr) + saltLen +{-# WARNING pwdhash "pwdhash and pwdhashTimed's parameter order may be inconsistent. See botan-low/test/Botan/Low/PwdHashSpec.hs for more information." #-} + + + +pwdhashTimed + :: PBKDFName -- ^ __algo__: PBKDF algorithm, e.g., "Scrypt" or "PBKDF2(SHA-256)" + -> Int -- ^ __msec__: the desired runtime in milliseconds + -> Int -- ^ __out_len__: the desired length of the key to produce + -> ByteString -- ^ __passphrase__: the password to derive the key from + -> ByteString -- ^ __salt[]__: a randomly chosen salt + -> IO (Int,Int,Int,ByteString) -- ^ __out[]__: buffer to store the derived key, must be of out_len bytes +pwdhashTimed algo msec outLen passphrase salt = alloca $ \ p1Ptr -> alloca $ \ p2Ptr -> alloca $ \ p3Ptr -> do + out <- allocBytes outLen $ \ outPtr -> do + asCString algo $ \ algoPtr -> do + asCStringLen passphrase $ \ passphrasePtr passphraseLen -> do + asBytesLen salt $ \ saltPtr saltLen -> do + throwBotanIfNegative_ $ botan_pwdhash_timed + (ConstPtr algoPtr) + (fromIntegral msec) + p1Ptr + p2Ptr + p3Ptr + outPtr + (fromIntegral outLen) + (ConstPtr passphrasePtr) + passphraseLen + (ConstPtr saltPtr) + saltLen + p1 <- fromIntegral <$> peek p1Ptr + p2 <- fromIntegral <$> peek p2Ptr + p3 <- fromIntegral <$> peek p3Ptr + return (p1,p2,p3,out) +{-# WARNING pwdhashTimed "pwdhash and pwdhashTimed's parameter order may be inconsistent. See botan-low/test/Botan/Low/PwdHashSpec.hs for more information." #-} diff --git a/src/Botan/Low/RNG.hs b/src/Botan/Low/RNG.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/RNG.hs @@ -0,0 +1,180 @@ +{-| +Module : Botan.Low.RNG +Description : Random number generators +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +Pseudo-random number generation. +-} + +module Botan.Low.RNG +( + +-- * Random number generators +-- $introduction + +-- * Usage +-- $usage + + RNG(..) +, RNGType(..) +, withRNG +, rngInit +, rngDestroy +, rngGet +, systemRNGGet +, rngReseed +, rngReseedFromRNG +, rngAddEntropy + +-- * RNG Types + +, pattern SystemRNG +, pattern UserRNG +, pattern UserThreadsafeRNG +, pattern RDRandRNG + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.RNG + +import Botan.Low.Error ( throwBotanIfNegative_ ) +import Botan.Low.Make ( mkWithTemp1 ) +import Botan.Low.Remake +import Botan.Low.Prelude + +{- $introduction + +A `random number generator` is used to generate uniform samples of pseudorandom +bytes. + +-} + +{- $usage + +You can always use the system `RNG`: + +> import Botan.Low.RNG +> randomBytes <- systemRNGGet 16 + +Unless you need a specific `RNG`, it is strongly recommended that you use the +autoseeded `user` RNG. + +> import Botan.Low.RNG +> rng <- rngInit "user" +> randomBytes <- rngGet rng 16 + +You can reseed a generator using the system generator: + +> rngReseed rng 64 + +You can also reseed a generator using a specific generator: + +> systemRNG <- rngInit "system" +> rngReseedFromRNG rng systemRNG 64 + +You can also seed it with your own entropy; this is safe and can never +*decrease* the amount of entropy in the generator. + +> rngAddEntropy rng "Fee fi fo fum!" + +-} + +-- NOTE: Does not take advantage of Remake +-- NOTE: Uses ConstPtr / unConstPtr manually +-- TODO: Take advantage of Remake / better peek / (peekConst or constPeek) functions + +newtype RNG = MkRNG { getRNGForeignPtr :: ForeignPtr BotanRNGStruct } + +newRNG :: BotanRNG -> IO RNG +withRNG :: RNG -> (BotanRNG -> IO a) -> IO a +-- | Destroy a random number generator object immediately +rngDestroy :: RNG -> IO () +createRNG :: (Ptr BotanRNG -> IO CInt) -> IO RNG +(newRNG, withRNG, rngDestroy, createRNG, _) + = mkBindings MkBotanRNG runBotanRNG MkRNG getRNGForeignPtr botan_rng_destroy + +type RNGType = ByteString + +pattern SystemRNG -- ^ system RNG + , UserRNG -- ^ userspace RNG + , UserThreadsafeRNG -- ^ userspace RNG, with internal locking + , RDRandRNG -- ^ directly read RDRAND + :: RNGType +pattern SystemRNG = BOTAN_RNG_TYPE_SYSTEM +pattern UserRNG = BOTAN_RNG_TYPE_USER +pattern UserThreadsafeRNG = BOTAN_RNG_TYPE_USER_THREADSAFE +pattern RDRandRNG = BOTAN_RNG_TYPE_RDRAND + +{- | +Initialize a random number generator object + +rng_type has the possible values: + + - "system": system RNG + - "user": userspace RNG + - "user-threadsafe": userspace RNG, with internal locking + - "rdrand": directly read RDRAND + +Set rng_type to null to let the library choose some default. +-} +rngInit + :: RNGType -- ^ __rng_type__: type of the rng + -> IO RNG -- ^ __rng__ +rngInit = mkCreateObjectCString createRNG botan_rng_init + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withRNGInit :: RNGType -> (RNG -> IO a) -> IO a +withRNGInit = mkWithTemp1 rngInit rngDestroy + +-- | Get random bytes from a random number generator +rngGet + :: RNG -- ^ __rng__: rng object + -> Int -- ^ __out_len__: number of requested bytes + -> IO ByteString -- ^ __out__: output buffer of size out_len +rngGet rng len = withRNG rng $ \ botanRNG -> do + allocBytes len $ \ bytesPtr -> do + throwBotanIfNegative_ $ botan_rng_get botanRNG bytesPtr (fromIntegral len) + +-- | Get random bytes from system random number generator +systemRNGGet + :: Int -- ^ __out_len__: number of requested bytes + -> IO ByteString -- ^ __out__: output buffer of size out_len +systemRNGGet len = allocBytes len $ \ bytesPtr -> do + throwBotanIfNegative_ $ botan_system_rng_get bytesPtr (fromIntegral len) + +{- | +Reseed a random number generator + +Uses the System_RNG as a seed generator. +-} +rngReseed + :: RNG -- ^ __rng__: rng object + -> Int -- ^ __bits__: number of bits to reseed with + -> IO () +rngReseed rng bits = withRNG rng $ \ botanRNG -> do + throwBotanIfNegative_ $ botan_rng_reseed botanRNG (fromIntegral bits) + +-- | Reseed a random number generator +rngReseedFromRNG + :: RNG -- ^ __rng__: rng object + -> RNG -- ^ __source_rng__: the rng that will be read from + -> Int -- ^ __bits__: number of bits to reseed with + -> IO () +rngReseedFromRNG rng source bits = withRNG rng $ \ botanRNG -> do + withRNG source $ \ sourcePtr -> do + throwBotanIfNegative_ $ botan_rng_reseed_from_rng botanRNG sourcePtr (fromIntegral bits) + +-- | Add some seed material to a random number generator +rngAddEntropy + :: RNG -- ^ __rng__: rng object + -> ByteString -- ^ __entropy__: the data to add + -> IO () +rngAddEntropy rng bytes = withRNG rng $ \ botanRNG -> do + asBytesLen bytes $ \ bytesPtr bytesLen -> do + throwBotanIfNegative_ $ botan_rng_add_entropy botanRNG (ConstPtr bytesPtr) bytesLen diff --git a/src/Botan/Low/Remake.hs b/src/Botan/Low/Remake.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/Remake.hs @@ -0,0 +1,273 @@ +{-| +Module : Botan.Low.Remake +Description : Low-level binding generators +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +Generate low-level bindings automatically +-} + +module Botan.Low.Remake +( mkBindings +, mkCreateObject +, mkCreateObjects +, mkCreateObjectWith +, mkCreateObjectCString +, mkCreateObjectCString1 +, mkCreateObjectCBytes +, mkCreateObjectCBytesLen +, mkCreateObjectCBytesLen1 +, mkWithObjectAction +, mkWithObjectGetterCBytesLen +, mkWithObjectGetterCBytesLen1 +, mkWithObjectSetterCString +, mkWithObjectSetterCBytesLen +) where + +import Botan.Low.Prelude +import Botan.Low.Error + +import qualified Data.ByteString.Internal as ByteString + +import Botan.Low.Make (allocBytesQuerying) + +-- ByteString Helpers + +-- NOTE: Was allocBytes +createByteString :: Int -> (Ptr byte -> IO ()) -> IO ByteString +createByteString sz f = ByteString.create sz (f . castPtr) + +-- NOTE: Was allocBytesWith +-- createByteString' :: Int -> (Ptr byte -> IO a) -> IO (a, ByteString) + +-- NOTE: Was allocBytesQuerying +-- createByteStringQuerying :: (Ptr byte -> Ptr CSize -> IO CInt) -> IO ByteString +-- createByteStringQuerying fn = do +-- alloca $ \ szPtr -> do +-- -- TODO: Maybe poke szPtr 0 for extra safety in cas its not initially zero +-- code <- fn nullPtr szPtr +-- case code of +-- InsufficientBufferSpace -> do +-- sz <- fromIntegral <$> peek szPtr +-- allocBytes sz $ \ outPtr -> throwBotanIfNegative_ $ fn outPtr szPtr +-- _ -> do +-- throwBotanError code + +-- NOTE: Was allocBytesQueryingCString +-- NOTE: Does not check length of taken string, vulnerable to null byte injection +-- createByteStringQueryingCString :: (Ptr byte -> Ptr CSize -> IO CInt) -> IO ByteString +-- createByteStringQueryingCString action = do +-- cstring <- allocBytesQuerying action +-- return $!! ByteString.takeWhile (/= 0) cstring + +-- + +-- type NewObject object botan = botan -> IO object +-- type WithObject object botan = (forall a . object -> (botan -> IO a) -> IO a) +-- type DestroyObject object botan = object -> IO () +-- type CreateObject object botan = (Ptr botan -> IO CInt) -> IO object +-- type CreateObjects object botan = (Ptr botan -> Ptr CSize -> IO CInt) -> IO object + +-- Example usage +{- +newtype RNG = MkRNG { getRNGForeignPtr :: ForeignPtr BotanRNGStruct } + +newRNG :: BotanRNG -> IO RNG +withRNG :: RNG -> (BotanRNG -> IO a) -> IO a +rngDestroy :: RNG -> IO () +createRNG :: (Ptr BotanRNG -> IO CInt) -> IO RNG +(newRNG, withRNG, rngDestroy, createRNG, _) + = mkBindings MkBotanRNG runBotanRNG MkRNG getRNGForeignPtr botan_rng_destroy + +rngInit :: RNGType -> IO RNG +rngInit name = asCString name $ \ namePtr -> do + createRNG $ \ outPtr -> botan_rng_init outPtr (ConstPtr namePtr) +-} +mkBindings + :: (Storable botan) + => (Ptr struct -> botan) -- mkBotan + -> (botan -> Ptr struct) -- runBotan + -> (ForeignPtr struct -> object) -- mkForeign + -> (object -> ForeignPtr struct) -- runForeign + -> FinalizerPtr struct -- destroy / finalizer + -> ( botan -> IO object -- newObject + , object -> (botan -> IO a) -> IO a -- withObject + , object -> IO () -- destroyObject + , (Ptr botan -> IO CInt) -> IO object -- createObject + , (Ptr botan -> Ptr CSize -> IO CInt) -> IO [object] -- createObjects + ) +mkBindings mkBotan runBotan mkForeign runForeign destroy = bindings where + bindings = (newObject, withObject, objectDestroy, createObject, createObjects) + newObject botan = do + foreignPtr <- newForeignPtr destroy (runBotan botan) + return $ mkForeign foreignPtr + withObject object f = withForeignPtr (runForeign object) (f . mkBotan) + objectDestroy object = finalizeForeignPtr (runForeign object) + -- NOTE: This ^ is really a Haskell finalizer + -- We could include the actual C++ botan destructor instead of indirectly omitting it: + -- objectFinalize obj = new stable foreign ptr ... destroy + -- objectDestroy obj = withObject obj destroy + createObject = mkCreateObject newObject + createObjects = mkCreateObjects newObject + +{- +Create functions +-} + +-- TODO: Rename mkCreate +mkCreateObject + :: (Storable botan) + => (botan -> IO object) + -> (Ptr botan-> IO CInt) + -> IO object +mkCreateObject newObject init = mask_ $ alloca $ \ outPtr -> do + throwBotanIfNegative_ $ init outPtr + out <- peek outPtr + newObject out + +-- TODO: Rename mkCreates +mkCreateObjects + :: (Storable botan) + => (botan -> IO object) + -> (Ptr botan -> Ptr CSize -> IO CInt) + -> IO [object] +mkCreateObjects newObject inits = mask_ $ alloca $ \ szPtr -> do + code <- inits nullPtr szPtr + case code of + InsufficientBufferSpace -> do + sz <- fromIntegral <$> peek szPtr + allocaArray sz $ \ arrPtr -> do + throwBotanIfNegative_ $ inits arrPtr szPtr + outs <- peekArray sz arrPtr + forM outs newObject + _ -> throwBotanError code + +mkCreateObjectWith + :: ((Ptr botan -> IO CInt) -> IO object) + -> (arg -> (carg -> IO object) -> IO object) + -> (Ptr botan -> carg -> IO CInt) + -> arg + -> IO object +mkCreateObjectWith createObject withArg init arg = withArg arg $ \ carg -> do + createObject $ \ outPtr -> init outPtr carg + +-- TODO: Rename mkCreateCString +mkCreateObjectCString + :: ((Ptr botan -> IO CInt) -> IO object) + -> (Ptr botan -> ConstPtr CChar -> IO CInt) + -> ByteString + -> IO object +-- mkCreateObjectCString createObject init cstr = withCString cstr $ \ namePtr -> do +-- createObject $ \ outPtr -> init outPtr (ConstPtr namePtr) +mkCreateObjectCString createObject = mkCreateObjectWith createObject withConstCString + +-- TODO: Rename mkCreateCString1 +mkCreateObjectCString1 + :: ((Ptr botan -> IO CInt) -> IO object) + -> (Ptr botan -> ConstPtr CChar -> a -> IO CInt) + -> ByteString + -> a + -> IO object +mkCreateObjectCString1 createObject init str a = withCString str $ \ cstr -> do + createObject $ \ outPtr -> init outPtr (ConstPtr cstr) a + +-- TODO: Rename mkCreateCBytes +mkCreateObjectCBytes + :: ((Ptr botan -> IO CInt) -> IO object) + -> (Ptr botan -> ConstPtr Word8 -> IO CInt) + -> ByteString + -> IO object +mkCreateObjectCBytes createObject init bytes = withCBytes bytes $ \ cbytes -> do + createObject $ \ out -> init out (ConstPtr cbytes) +{-# WARNING mkCreateObjectCBytes "You probably want mkCreateObjectCBytesLen; this is for functions that expect a bytestring of known exact length." #-} + +-- TODO: Rename mkCreateCBytesLen +mkCreateObjectCBytesLen + :: ((Ptr botan -> IO CInt) -> IO object) + -> (Ptr botan -> ConstPtr Word8 -> CSize -> IO CInt) + -> ByteString + -> IO object +mkCreateObjectCBytesLen createObject init bytes = withCBytesLen bytes $ \ (cbytes,len) -> do + createObject $ \ out -> init out (ConstPtr cbytes) (fromIntegral len) + +mkCreateObjectCBytesLen1 + :: ((Ptr botan -> IO CInt) -> IO object) + -> (Ptr botan -> ConstPtr Word8 -> CSize -> a -> IO CInt) + -> ByteString + -> a + -> IO object +mkCreateObjectCBytesLen1 createObject init bytes a = withCBytesLen bytes $ \ (cbytes,len) -> do + createObject $ \ out -> init out (ConstPtr cbytes) (fromIntegral len) a + +{- +Action +-} + +-- TODO: Rename mkAction +mkWithObjectAction + :: (forall a . object -> (botan -> IO a) -> IO a) + -> (botan -> IO CInt) + -> object + -> IO () +mkWithObjectAction withObject action obj = withObject obj $ \ cobj -> do + throwBotanIfNegative_ $ action cobj + +{- +Getters +-} + +-- TODO: getter parameter order may be improper - switch up if problematic +mkWithObjectGetterCBytesLen + :: (forall a . object -> (botan -> IO a) -> IO a) + -> (botan -> Ptr Word8 -> Ptr CSize -> IO CInt) + -> object + -> IO ByteString +mkWithObjectGetterCBytesLen withObject getter obj = withObject obj $ \ cobj -> do + allocBytesQuerying $ \ outPtr outLen -> getter + cobj + outPtr + outLen + +-- TODO: getter parameter order may be improper - switch up if problematic +mkWithObjectGetterCBytesLen1 + :: (forall a . object -> (botan -> IO a) -> IO a) + -> (botan -> a -> Ptr Word8 -> Ptr CSize -> IO CInt) + -> object + -> a + -> IO ByteString +mkWithObjectGetterCBytesLen1 withObject getter obj a = withObject obj $ \ cobj -> do + allocBytesQuerying $ \ outPtr outLen -> getter + cobj + a + outPtr + outLen + +{- +Setters +-} + +-- TODO: Rename mkSetterCString +mkWithObjectSetterCString + :: (forall a . object -> (botan -> IO a) -> IO a) + -> (botan -> ConstPtr CChar -> IO BotanErrorCode) + -> object + -> ByteString + -> IO () +mkWithObjectSetterCString withObject setter obj str = withObject obj $ \ cobj -> do + withCString str $ \ cstr -> do + throwBotanIfNegative_ $ setter cobj (ConstPtr cstr) + +-- Replaces mkSetBytesLen +-- TODO: Rename mkSetterCBytesLen +mkWithObjectSetterCBytesLen + :: (forall a . object -> (botan -> IO a) -> IO a) + -> (botan -> ConstPtr Word8 -> CSize -> IO BotanErrorCode) + -> object + -> ByteString + -> IO () +mkWithObjectSetterCBytesLen withObject setter obj bytes = withObject obj $ \ cobj -> do + withCBytesLen bytes $ \ (cbytes,len) -> do + throwBotanIfNegative_ $ setter cobj (ConstPtr cbytes) (fromIntegral len) diff --git a/src/Botan/Low/SRP6.hs b/src/Botan/Low/SRP6.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/SRP6.hs @@ -0,0 +1,333 @@ +{-| +Module : Botan.Low.SRP6 +Description : Secure remote password +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +The library contains an implementation of the SRP6-a password +authenticated key exchange protocol. + +-} + +module Botan.Low.SRP6 +( + +-- * Secure Random Password 6a +-- $introduction + +-- * Usage +-- $usage + + SRP6ServerSession(..) +, withSRP6ServerSession +, srp6ServerSessionInit +, srp6ServerSessionDestroy +, srp6ServerSessionStep1 +, srp6ServerSessionStep2 +, srp6GenerateVerifier +, srp6ClientAgree +, srp6GroupSize + +-- * SRP6 Types + +, SRP6Verifier(..) +, SRP6BValue(..) +, SRP6AValue(..) +, SRP6SharedSecret(..) + +-- * SRP discrete logarithm groups + +, pattern MODP_SRP_1024 +, pattern MODP_SRP_1536 +, pattern MODP_SRP_2048 +, pattern MODP_SRP_3072 +, pattern MODP_SRP_4096 +, pattern MODP_SRP_6144 +, pattern MODP_SRP_8192 + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.SRP6 + +import Botan.Low.Error +import Botan.Low.Hash +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.Remake +import Botan.Low.RNG +import Botan.Low.PubKey + +{- $introduction + +A SRP client provides what is called a SRP verifier to the server. +This verifier is based on a password, but the password cannot be +easily derived from the verifier (however brute force attacks are +possible). Later, the client and server can perform an SRP exchange, +which results in a shared secret key. This key can be used for +mutual authentication and/or encryption. + +SRP works in a discrete logarithm group. Special parameter sets for +SRP6 are defined, denoted in the library as @modp\/srp\/@, for +example @modp\/srp\/2048@. + +Warning + +While knowledge of the verifier does not easily allow an attacker to +get the raw password, they could still use the verifier to impersonate +the server to the client, so verifiers should be protected as carefully +as a plaintext password would be. + +SRP6 may be used as part of SSL/TLS: https://www.rfc-editor.org/rfc/rfc5054 + +-} + +{- $usage + +On signup, the client generates a salt and verifier, and securely sends them to a server: + +> import Botan.Low.SRP6 +> import Botan.Low.Hash +> import Botan.Low.RNG +> import Botan.Low.MAC +> rng <- rngInit UserRNG +> group = MODP_SRP_4096 +> hash = SHA512 +> identifier = "alice" +> password = "Fee fi fo fum!" +> salt <- rngGet rng 12 +> verifier <- srp6GenerateVerifier identifier password salt group hash +> -- signUpUserWithServer identifier verifier salt group hash + +Later, on the server when the client request authentication, the server +looks up the verfier, generates a server key (a SRP6 'B' value), and sends +it back to the client: + +> -- rng <- rngInit UserRNG +> session <- srp6ServerSessionInit +> -- (verifier, salt, group, hash) <- lookupUser identifier +> serverKey <- srp6ServerSessionStep1 session verifier group hash rng + +Once the client receives the server key, it generates a client key (SRP6 'A' value) +and the session key, and sends the client key to the server: + +> -- serverKey <- didReceiveServerKey +> (clientKey, clientSessionKey) <- srp6ClientAgree identifier password group hash salt serverKey rng +> -- sendClientKey clientKey + +The server then receives client key, and generates a matching session key: + +> -- clientKey <- didReceiveClientKey +> serverSessionKey <- srp6ServerSessionStep2 session clientKey + +At this point, clientSessionKey and serverSessionKey should be equal, +but this should be confirmed by exchanging a hash digest to check for integrity, +using the exchange's session key, identifier, salt, and client and server keys. + +There are many ways to do this, but preferrably, an (h)mac digest should be used +to also include authentication and avoid impersonation. + +> NOTE: Both sides could calculate 'identifier <> salt <> serverKey <> clientKey' +> individually but then we need to prove that each side has calculated it without +relying on the copy received for validation, so we do this song and dance: + +The client should first calculate and send the HMAC auth, using identifier + salt + clientKey: + +> mac <- macInit (hmac SHA3) +> macSetKey mac clientSessionKey +> macUpdate mac $ identifier <> salt <> clientKey +> clientAuth <- macFinal mac +> -- sendClientAuth clientAuth + +The server should then verify the client auth, and send its own HMAC +auth back to the client using serverKey + clientAuth: + +> -- clientAuth <- didReceiveClientAuth +> mac <- macInit (hmac SHA3) +> macSetKey mac serverSessionKey +> macUpdate mac $ identifier <> salt <> clientKey +> verifiedClientAuth <- macFinal mac +> -- clientAuth == verifiedClientAuth +> macClear mac +> macSetKey mac serverSessionKey +> macUpdate mac $ serverKey <> clientAuth +> serverAuth <- macFinal mac +> -- sendServerAuth serverAuth + +The client then receives the server HMAC auth, and validates it + +> -- serverAuth <- didReceiveServerAuth +> macClear mac +> macSetKey mac clientSessionKey +> macUpdate mac $ serverKey <> clientAuth +> verifiedServerAuth <- macFinal mac +> -- serverAuth == verifiedServerAuth + +After this, the shared session key may be safely used. + +-} + + +-- TODO: Unify with other / move to botan +type Identifier = ByteString +type Password = ByteString +type Salt = ByteString + +type SRP6Verifier = ByteString +type SRP6BValue = ByteString +type SRP6AValue = ByteString +type SRP6SharedSecret = ByteString + +newtype SRP6ServerSession = MkSRP6ServerSession { getSRP6ServerSessionForeignPtr :: ForeignPtr BotanSRP6ServerSessionStruct } + +newSRP6ServerSession :: BotanSRP6ServerSession -> IO SRP6ServerSession +withSRP6ServerSession :: SRP6ServerSession -> (BotanSRP6ServerSession -> IO a) -> IO a +-- | Destroy a SRP6 server session object immediately +srp6ServerSessionDestroy :: SRP6ServerSession -> IO () +createSRP6ServerSession :: (Ptr BotanSRP6ServerSession -> IO CInt) -> IO SRP6ServerSession +(newSRP6ServerSession, withSRP6ServerSession, srp6ServerSessionDestroy, createSRP6ServerSession, _) + = mkBindings + MkBotanSRP6ServerSession runBotanSRP6ServerSession + MkSRP6ServerSession getSRP6ServerSessionForeignPtr + botan_srp6_server_session_destroy + +-- | Initialize an SRP-6 server session object +srp6ServerSessionInit + :: IO SRP6ServerSession -- ^ __srp6__: SRP-6 server session object +srp6ServerSessionInit = createSRP6ServerSession botan_srp6_server_session_init + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withSRP6ServerSessionInit :: (SRP6ServerSession -> IO a) -> IO a +withSRP6ServerSessionInit = mkWithTemp srp6ServerSessionInit srp6ServerSessionDestroy + +-- | SRP-6 Server side step 1: Generate a server B-value +srp6ServerSessionStep1 + :: SRP6ServerSession -- ^ __srp6__: SRP-6 server session object + -> SRP6Verifier -- ^ __verifier[]__: the verification value saved from client registration + -> DLGroupName -- ^ __group_id__: the SRP group id + -> HashName -- ^ __hash_id__: the SRP hash in use + -> RNG -- ^ __rng_obj__: a random number generator object + -> IO SRP6BValue -- ^ __B_pub[]__: out buffer to store the SRP-6 B value +srp6ServerSessionStep1 srp6 verifier groupId hashId rng = withSRP6ServerSession srp6 $ \ srp6Ptr -> do + asBytesLen verifier $ \ verifierPtr verifierLen -> do + asCString groupId $ \ groupIdPtr -> do + asCString hashId $ \ hashIdPtr -> do + withRNG rng $ \ botanRNG -> do + allocBytesQuerying $ \ outPtr outLen -> botan_srp6_server_session_step1 + srp6Ptr + (ConstPtr verifierPtr) + verifierLen + (ConstPtr groupIdPtr) + (ConstPtr hashIdPtr) + botanRNG + outPtr + outLen + +-- | SRP-6 Server side step 2: Generate the server shared key +srp6ServerSessionStep2 + :: SRP6ServerSession -- ^ __srp6__: SRP-6 server session object + -> SRP6AValue -- ^ __A[]__: the client's value + -> IO SRP6SharedSecret -- ^ __key[]__: out buffer to store the symmetric key value +srp6ServerSessionStep2 srp6 a = withSRP6ServerSession srp6 $ \ srp6Ptr -> do + asBytesLen a $ \ aPtr aLen -> do + allocBytesQuerying $ \ outPtr outLen -> botan_srp6_server_session_step2 + srp6Ptr + (ConstPtr aPtr) + aLen + outPtr + outLen + +-- | SRP-6 Client side step 1: Generate a new SRP-6 verifier +srp6GenerateVerifier + :: Identifier -- ^ __identifier__: a username or other client identifier + -> Password -- ^ __password__: the secret used to authenticate user + -> Salt -- ^ __salt[]__: a randomly chosen value, at least 128 bits long + -> DLGroupName -- ^ __group_id__: specifies the shared SRP group + -> HashName -- ^ __hash_id__: specifies a secure hash function + -> IO SRP6Verifier -- ^ __verifier[]__: out buffer to store the SRP-6 verifier value +srp6GenerateVerifier identifier password salt groupId hashId = asCString identifier $ \ identifierPtr -> do + asCString password $ \ passwordPtr -> do + asBytesLen salt $ \ saltPtr saltLen -> do + asCString groupId $ \ groupIdPtr -> do + asCString hashId $ \ hashIdPtr -> do + allocBytesQuerying $ \ outPtr outLen -> botan_srp6_generate_verifier + (ConstPtr identifierPtr) + (ConstPtr passwordPtr) + (ConstPtr saltPtr) + saltLen + (ConstPtr groupIdPtr) + (ConstPtr hashIdPtr) + outPtr + outLen + +-- NOTE: ORDER IS DIFFERENT FROM SERVER GENERATE VERIFIER +-- | SRP6a Client side step 2: Generate a client A-value and the client shared key +srp6ClientAgree + :: Identifier -- ^ __username__: the username we are attempting login for + -> Password -- ^ __password__: the password we are attempting to use + -> DLGroupName -- ^ __group_id__: specifies the shared SRP group + -> HashName -- ^ __hash_id__: specifies a secure hash function + -> Salt -- ^ __salt[]__: is the salt value sent by the server + -> SRP6BValue -- ^ __uint8_t__: B[] is the server's public value + -> RNG -- ^ __rng_obj__: is a random number generator object + -> IO (SRP6AValue, SRP6SharedSecret) -- @(A,K)@ +srp6ClientAgree identifier password groupId hashId salt b rng = do + asCString identifier $ \ identifierPtr -> do + asCString password $ \ passwordPtr -> do + asCString groupId $ \ groupIdPtr -> do + asCString hashId $ \ hashIdPtr -> do + asBytesLen salt $ \ saltPtr saltLen -> do + asBytesLen b $ \ bPtr bLen -> do + withRNG rng $ \ botanRNG -> do + alloca $ \ aSzPtr -> do + alloca $ \ kSzPtr -> do + -- Query sizes + -- TODO: Actually ensure expected error (insufficient buffer space) + -- and propagate unexpected errors + _ <- botan_srp6_client_agree + (ConstPtr identifierPtr) + (ConstPtr passwordPtr) + (ConstPtr groupIdPtr) + (ConstPtr hashIdPtr) + (ConstPtr saltPtr) + saltLen + (ConstPtr bPtr) + bLen + botanRNG + nullPtr + aSzPtr + nullPtr + kSzPtr + kSz <- fromIntegral <$> peek kSzPtr + aSz <- fromIntegral <$> peek aSzPtr + allocBytesWith kSz $ \ kPtr -> do + allocBytes aSz $ \ aPtr -> do + throwBotanIfNegative_ $ botan_srp6_client_agree + (ConstPtr identifierPtr) + (ConstPtr passwordPtr) + (ConstPtr groupIdPtr) + (ConstPtr hashIdPtr) + (ConstPtr saltPtr) + saltLen + (ConstPtr bPtr) + bLen + botanRNG + aPtr + aSzPtr + kPtr + kSzPtr + +-- NOTE: Missing FFI function: srp6_group_identifierz + +-- | Return the size, in bytes, of the prime associated with group_id +srp6GroupSize + :: DLGroupName -- ^ __group_id__ + -> IO Int -- ^ __group_p_bytes__ +srp6GroupSize groupId = asCString groupId $ \ groupIdPtr -> do + alloca $ \ szPtr -> do + throwBotanIfNegative_ $ botan_srp6_group_size (ConstPtr groupIdPtr) szPtr + fromIntegral <$> peek szPtr diff --git a/src/Botan/Low/TOTP.hs b/src/Botan/Low/TOTP.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/TOTP.hs @@ -0,0 +1,234 @@ +{-| +Module : Botan.Low.TOTP +Description : Time-based one time passwords +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +One time password schemes are a user authentication method that +relies on a fixed secret key which is used to derive a sequence +of short passwords, each of which is accepted only once. Commonly +this is used to implement two-factor authentication (2FA), where +the user authenticates using both a conventional password (or a +public key signature) and an OTP generated by a small device such +as a mobile phone. + +-} + +module Botan.Low.TOTP +( + +-- * Time-based one time passwords +-- $introduction +-- * Usage +-- $usage + +-- * TOTP + + TOTP(..) +, TOTPHashName(..) +, TOTPTimestep(..) +, TOTPTimestamp(..) +, TOTPCode(..) +, withTOTP +, totpInit +, totpDestroy +, totpGenerate +, totpCheck + +-- * TOTP Hashes + +, pattern TOTP_SHA1 +, pattern TOTP_SHA256 +, pattern TOTP_SHA512 + +-- * Convenience + +, totpHashes + +) where + +import qualified Data.ByteString as ByteString + +import Botan.Bindings.TOTP + +import Botan.Low.Error +import Botan.Low.Hash +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.Remake + +-- NOTE: RFC 6238 + +{- $introduction + +Botan implements the HOTP and TOTP schemes from RFC 4226 and 6238. + +Since the range of possible OTPs is quite small, applications must +rate limit OTP authentication attempts to some small number per +second. Otherwise an attacker could quickly try all 1000000 6-digit +OTPs in a brief amount of time. + +TOTP generates OTPs that are a short numeric sequence, between 6 +and 8 digits (most applications use 6 digits), created using a +64-bit timestamp counter value. If the counter ever repeats the +OTP will also repeat, thus both parties must assure the counter +only increments and is never repeated or decremented. Thus both +client and server must keep their clocks synchronized. + +Anyone with access to the client-specific secret key can authenticate +as that client, so it should be treated with the same security +consideration as would be given to any other symmetric key or +plaintext password. + +TOTP is based on the same algorithm as HOTP, but instead of a +counter a timestamp is used. + +-} + +{- $usage + +To use TOTP for MFA / 2FA, the client authenticator must generate a +client-specific shared secret, and securely communicate it to the +server authenticator. + +The secret key may be any bytestring value with more than 160 bits, such as +a Bcrypt digest or SRP6 shared key. + +> import Botan.Low.TOTP +> import Botan.Low.RNG +> import Data.Time.Clock.POSIX +> timestep = 30 +> drift = 3 +> sharedSecret <- systemRNGGet 16 + +The client and server authenticators are now in a shared state, and any login +attempts from a new device may be authenticated using TOTP as MFA. + +A client has requested a new connection, and TOTP is being used as MFA/2FA to +authenticate their request. The server authenticator receives the client connection +request and initializes a TOTP session using the stored client-specific shared +secret, and then sends an authentication request to the client authenticator: + +> -- serverSharedSecret <- lookupServerSharedSecret +> serverSession <- totpInit serverSharedSecret TOTP_SHA512 8 timestep +> -- sendMFAAuthenticationRequest + +> NOTE: We are using a timestep value of 30 seconds, which means that the +> code will refresh every 30 seconds + +The client authenticator receives the authentication request, generates a +client-side code using their timestamp, and displays the TOTP code to +the user: + +> -- clientSharedSecret <- lookupClientSharedSecret +> clientSession <- totpInit clientSharedSecret TOTP_SHA512 8 timestep +> (clientTimestamp :: TOTPTimestamp) <- round <$> getPOSIXTime +> clientCode <- totpGenerate clientSession clientTimestamp +> -- displayClientCode clientCode + +The client then sends the client code to the server authenticator using the +unauthenticated / requested connection: + +> -- clientCode <- readClientCode +> -- sendMFAAuthenticationResponse clientCode + +The server authenticator receives the authentication response, and performs +a check of the key, with an acceptable clock drift in steps, in case the client +and server are slightly desynchronized. + +> -- serverClientCode <- didreceiveMFAAuthenticationResponse +> (serverTimestamp :: TOTPTimestamp) <- round <$> getPOSIXTime +> isValid <- totpCheck serverSession serverClientCode serverTimestamp drift + +> NOTE: We are using a acceptable clock drift value of 3, which means that the +> codes for the previous 3 time steps are still valid. + +If the code is valid, then the signin may be completed on the new connection +as normal. + +The server should discontinue the session and refuse any new connections +to the account after multiple unsuccessful authentication attempts. +The user should then be notified. + +-} + +newtype TOTP = MkTOTP { getTOTPForeignPtr :: ForeignPtr BotanTOTPStruct } + +newTOTP :: BotanTOTP -> IO TOTP +withTOTP :: TOTP -> (BotanTOTP -> IO a) -> IO a +totpDestroy :: TOTP -> IO () +createTOTP :: (Ptr BotanTOTP -> IO CInt) -> IO TOTP +(newTOTP, withTOTP, totpDestroy, createTOTP, _) + = mkBindings + MkBotanTOTP runBotanTOTP + MkTOTP getTOTPForeignPtr + botan_totp_destroy + +type TOTPHashName = HashName + +pattern TOTP_SHA1 + , TOTP_SHA256 + , TOTP_SHA512 + :: TOTPHashName + +pattern TOTP_SHA1 = SHA1 +pattern TOTP_SHA256 = SHA256 +pattern TOTP_SHA512 = SHA512 + +-- TODO: Do any other hashes work? +totpHashes = + [ TOTP_SHA1 + , TOTP_SHA256 + , TOTP_SHA512 + ] + +type TOTPTimestep = Word64 +type TOTPTimestamp = Word64 +type TOTPCode = Word32 + +-- | Initialize a TOTP instance +-- +-- NOTE: Digits should be 6-8 +totpInit + :: ByteString -- ^ __key[]__ + -> TOTPHashName -- ^ __hash_algo__ + -> Int -- ^ __digits__ + -> TOTPTimestep -- ^ __time_step__ + -> IO TOTP -- ^ __totp__ +totpInit key algo digits timestep = asBytesLen key $ \ keyPtr keyLen -> do + asCString algo $ \ algoPtr -> do + createTOTP $ \ out -> botan_totp_init + out + (ConstPtr keyPtr) + keyLen + (ConstPtr algoPtr) + (fromIntegral digits) + (fromIntegral timestep) + +-- WARNING: withFooInit-style limited lifetime functions moved to high-level botan +withTOTPInit :: ByteString -> ByteString -> Int -> TOTPTimestep -> (TOTP -> IO a) -> IO a +withTOTPInit = mkWithTemp4 totpInit totpDestroy + +-- | Generate a TOTP code for the provided timestamp +totpGenerate + :: TOTP -- ^ __totp__: the TOTP object + -> TOTPTimestamp -- ^ __totp_code__: the OTP code will be written here + -> IO TOTPCode -- ^ __timestamp__: the current local timestamp +totpGenerate totp timestamp = withTOTP totp $ \ totpPtr -> do + alloca $ \ outPtr -> do + throwBotanIfNegative $ botan_totp_generate totpPtr outPtr timestamp + peek outPtr + +-- | Verify a TOTP code +totpCheck + :: TOTP -- ^ __totp__: the TOTP object + -> TOTPCode -- ^ __totp_code__: the presented OTP + -> TOTPTimestamp -- ^ __timestamp__: the current local timestamp + -> Int -- ^ __acceptable_clock_drift__: specifies the acceptable amount + -- of clock drift (in terms of time steps) between the two hosts. + -> IO Bool +totpCheck totp code timestamp drift = withTOTP totp $ \ totpPtr -> do + throwBotanCatchingSuccess $ botan_totp_check totpPtr code timestamp (fromIntegral drift) diff --git a/src/Botan/Low/Utility.hs b/src/Botan/Low/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/Utility.hs @@ -0,0 +1,128 @@ +{-| +Module : Botan.Low.Utility +Description : Utility functions +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.Utility +( constantTimeCompare +, scrubMem +, HexEncodingFlags +, pattern HexUpperCase +, pattern HexLowerCase +, hexEncode +, hexDecode +, base64Encode +, base64Decode +) where + +import Data.Bool + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import qualified Data.ByteString as ByteString + +import System.IO.Unsafe + +import Botan.Bindings.Utility + +import Botan.Low.Error +import Botan.Low.Prelude +import Botan.Low.Make (allocBytesQuerying, allocBytesQueryingCString) + +-- NOTE: Use of Text is unique here - leave for Text for `botan` + +-- | Returns 0 if x[0..len] == y[0..len], -1 otherwise. +constantTimeCompare + :: ByteString -- ^ __x__ + -> ByteString -- ^ __y__ + -> Int -- ^ __len__ + -> IO Bool +constantTimeCompare x y len = do + asBytesLen x $ \ xPtr xlen -> do + asBytesLen y $ \ yPtr ylen -> do + result <- botan_constant_time_compare + (ConstPtr xPtr) + (ConstPtr yPtr) + xlen + case result of + 0 -> return True + _ -> return False + +scrubMem + :: Ptr a -- ^ __mem__ + -> Int -- ^ __bytes__ + -> IO () +scrubMem ptr sz = throwBotanIfNegative_ $ botan_scrub_mem (castPtr ptr) (fromIntegral sz) + +type HexEncodingFlags = Word32 + +pattern HexUpperCase -- ^ NOTE: Not an actual flag + , HexLowerCase + :: HexEncodingFlags + +pattern HexUpperCase = BOTAN_FFI_HEX_UPPER_CASE +pattern HexLowerCase = BOTAN_FFI_HEX_LOWER_CASE + +-- | Performs hex encoding of binary data in x of size len bytes. The output buffer out must be of at least x*2 bytes in size. If flags contains BOTAN_FFI_HEX_LOWER_CASE, hex encoding will only contain lower-case letters, upper-case letters otherwise. Returns 0 on success, 1 otherwise. +-- DISCUSS: Handling of positive return code / BOTAN_FFI_INVALID_VERIFIER? +-- DISCUSS: Use of Text.decodeUtf8 - bad, partial function! - but safe here? +hexEncode + :: ByteString -- ^ __x__ + -> HexEncodingFlags -- ^ __flags__ + -> IO Text -- ^ __y__ +hexEncode bytes flags = Text.decodeUtf8 <$> do + asBytesLen bytes $ \ bytesPtr bytesLen -> do + allocBytes (fromIntegral $ 2 * bytesLen) $ \ hexPtr -> do + throwBotanIfNegative_ $ botan_hex_encode + (ConstPtr bytesPtr) + bytesLen + hexPtr + flags + +-- | "Hex decode some data" +-- DISCUSS: Return value, maybe vs exception +-- DISCUSS: Botan documentation is lacking here +-- WARNING: Does not actually check that len is a multiple of 2 +hexDecode + :: Text -- ^ __hex_str__ + -> IO ByteString -- ^ __out__ +hexDecode txt = do + asBytesLen (Text.encodeUtf8 txt) $ \ hexPtr hexLen -> do + allocBytesQuerying $ \ bytesPtr szPtr -> do + botan_hex_decode + (ConstPtr hexPtr) + hexLen + bytesPtr + szPtr + +-- NOTE: Does not check tht base64Len == peek sizePtr +base64Encode + :: ByteString -- ^ __x__ + -> IO Text -- ^ __out__ +base64Encode bytes = Text.decodeUtf8 <$> do + asBytesLen bytes $ \ bytesPtr bytesLen -> do + allocBytesQueryingCString $ \ base64Ptr szPtr -> do + botan_base64_encode + (ConstPtr bytesPtr) + bytesLen + base64Ptr + szPtr + +-- | Ditto everything hexDecode +base64Decode + :: Text -- ^ __base64_str__ + -> IO ByteString -- ^ __out__ +base64Decode txt = do + asBytesLen (Text.encodeUtf8 txt) $ \ base64Ptr base64Len -> do + allocBytesQueryingCString $ \ bytesPtr szPtr -> do + botan_base64_decode + (ConstPtr base64Ptr) + base64Len + bytesPtr + szPtr diff --git a/src/Botan/Low/Version.hs b/src/Botan/Low/Version.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/Version.hs @@ -0,0 +1,70 @@ +{-| +Module : Botan.Low.Version +Description : Botan version info +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.Version +( botanFFIAPIVersion +, botanFFISupportsAPI +, botanVersionString +, botanVersionMajor +, botanVersionMinor +, botanVersionPatch +, botanVersionDatestamp +) where + +import Data.Bool + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Unsafe as ByteString + +import qualified Data.Text as Text +import qualified Data.Text.Foreign as Text + +import System.IO.Unsafe + +import Botan.Bindings.Version + +import Botan.Low.Prelude +import Botan.Low.Error (throwBotanCatchingSuccess) +import GHC.Generics ((:.:)(unComp1)) + +-- https://botan.randombit.net/handbook/api_ref/ffi.html#versioning + +-- | Returns the version of the currently supported FFI API. This is expressed in the form YYYYMMDD of the release date of this version of the API. +botanFFIAPIVersion :: IO Int +botanFFIAPIVersion = fromIntegral <$> botan_ffi_api_version + +-- | Returns 0 iff the FFI version specified is supported by this library. Otherwise returns -1. The expression botan_ffi_supports_api(botan_ffi_api_version()) will always evaluate to 0. A particular version of the library may also support other (older) versions of the FFI API. +botanFFISupportsAPI :: Int -> IO Bool +botanFFISupportsAPI version = do + supports <- botan_ffi_supports_api $ fromIntegral version + case supports of + 0 -> return True + _ -> return False +-- TODO: botanFFISupportsAPI = throwBotanCatchingSuccess . botan_ffi_supports_api . fromIntegral +-- AFTER renaming current throwBotanCatchingSuccess to throwBotanCatchingInvalidIdentifier + +botanVersionString :: IO ByteString +botanVersionString = botan_version_string >>= peekCString . unConstPtr + +-- | Returns the major version of the library +botanVersionMajor :: IO Int +botanVersionMajor = fromIntegral <$> botan_version_major + +-- | Returns the minor version of the library +botanVersionMinor :: IO Int +botanVersionMinor = fromIntegral <$> botan_version_minor + +-- | Returns the patch version of the library +botanVersionPatch :: IO Int +botanVersionPatch = fromIntegral <$> botan_version_patch + +-- | Returns the date this version was released as an integer YYYYMMDD, or 0 if an unreleased version +botanVersionDatestamp :: IO Int +botanVersionDatestamp = fromIntegral <$> botan_version_datestamp diff --git a/src/Botan/Low/View.hs b/src/Botan/Low/View.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/View.hs @@ -0,0 +1,39 @@ +{-| +Module : Botan.Low.View +Description : View functions +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX +-} + +module Botan.Low.View +( + + BotanViewBinFn(..) +, BotanViewBinCallback(..) +, viewBin +, BotanViewStrFn(..) +, BotanViewStrCallback(..) +, viewStr + +)where + +import qualified Data.ByteString as ByteString + +import Data.Void + +import System.IO + +import Botan.Bindings.View + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude + +viewBin :: BotanViewBinFn ctx -> (BotanViewBinCallback ctx -> IO a) -> IO a +viewBin f = bracket (mallocBotanViewBinCallback f) freeBotanViewBinCallback + +viewStr :: BotanViewStrFn ctx -> (BotanViewStrCallback ctx -> IO a) -> IO a +viewStr f = bracket (mallocBotanViewStrCallback f) freeBotanViewStrCallback diff --git a/src/Botan/Low/X509.hs b/src/Botan/Low/X509.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/X509.hs @@ -0,0 +1,429 @@ +{-| +Module : Botan.Low.X509 +Description : X.509 Certificates and CRLs +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +A certificate is a binding between some identifying information +(called a subject) and a public key. This binding is asserted by +a signature on the certificate, which is placed there by some +authority (the issuer) that at least claims that it knows the +subject named in the certificate really “owns” the private key +corresponding to the public key in the certificate. + +The major certificate format in use today is X.509v3, used for +instance in the Transport Layer Security (TLS) protocol. +-} + +module Botan.Low.X509 +( + +-- * X509 Certificates + + X509Cert(..) +, withX509Cert +, x509CertLoad +, x509CertLoadFile +, x509CertDestroy +, x509CertDup +, x509CertGetTimeStarts +, x509CertGetTimeExpires +, x509CertNotBefore +, x509CertNotAfter +, x509CertGetPubKeyFingerprint +, x509CertGetSerialNumber +, x509CertGetAuthorityKeyId +, x509CertGetSubjectKeyId +, x509CertGetPublicKeyBits +, x509CertGetPublicKey +, x509CertGetIssuerDN +, x509CertGetSubjectDN +, x509CertToString +, x509CertAllowedUsage +, x509CertHostnameMatch +, x509CertVerify +, x509CertValidationStatus + +-- * X509 Key constraints + +, X509KeyConstraints(..) +, pattern NoConstraints +, pattern DigitalSignature +, pattern NonRepudiation +, pattern KeyEncipherment +, pattern DataEncipherment +, pattern KeyAgreement +, pattern KeyCertSign +, pattern CRLSign +, pattern EncipherOnly +, pattern DecipherOnly + +-- * X509 Certificate revocation list + +, X509CRL(..) +, withX509CRL +, x509CRLLoad +, x509CRLLoadFile +, x509CRLDestroy +, x509IsRevoked +, x509CertVerifyWithCLR + +-- * Convenience +, DistinguishedName(..) + +) where + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 + +import Botan.Bindings.PubKey +import Botan.Bindings.X509 + +import Botan.Low.Hash (HashName(..)) + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.PubKey +import Botan.Low.Remake +import Data.Maybe (fromMaybe) +import Data.ByteString (packCString) +import qualified Foreign.C.String as String (withCString) +import Botan.Low.Remake (mkCreateObjectCBytesLen) +import Botan.Low.PubKey (createPubKey) + +-- TODO: Use *.Make module to ensure consistency + +-- /* +-- * X.509 certificates +-- **************************/ + +type DistinguishedName = ByteString + +newtype X509Cert = MkX509Cert { getX509CertForeignPtr :: ForeignPtr BotanX509CertStruct } + +newX509Cert :: BotanX509Cert -> IO X509Cert +withX509Cert :: X509Cert -> (BotanX509Cert -> IO a) -> IO a +-- | Destroy an x509 cert object immediately +x509CertDestroy :: X509Cert -> IO () +createX509Cert :: (Ptr BotanX509Cert -> IO CInt) -> IO X509Cert +(newX509Cert, withX509Cert, x509CertDestroy, createX509Cert, _) + = mkBindings MkBotanX509Cert runBotanX509Cert MkX509Cert getX509CertForeignPtr botan_x509_cert_destroy + +x509CertLoad + :: ByteString -- ^ __cert[]__ + -> IO X509Cert -- ^ __cert_obj__ +x509CertLoad = mkCreateObjectCBytesLen createX509Cert botan_x509_cert_load + +x509CertLoadFile + :: FilePath -- ^ __filename__ + -> IO X509Cert -- ^ __cert_obj__ +x509CertLoadFile = mkCreateObjectCString createX509Cert botan_x509_cert_load_file . Char8.pack + +x509CertDup + :: X509Cert -- ^ __new_cert__ + -> IO X509Cert -- ^ __cert__ +x509CertDup = mkCreateObjectWith createX509Cert withX509Cert botan_x509_cert_dup + +x509CertGetTimeStarts + :: X509Cert -- ^ __cert__ + -> IO ByteString -- ^ __out[]__ +x509CertGetTimeStarts = mkGetBytes withX509Cert botan_x509_cert_get_time_starts + +x509CertGetTimeExpires + :: X509Cert -- ^ __cert__ + -> IO ByteString -- ^ __out[]__ +x509CertGetTimeExpires = mkGetBytes withX509Cert botan_x509_cert_get_time_expires + +-- TODO: mkGetIntegral +x509CertNotBefore + :: X509Cert -- ^ __cert__ + -> IO Word64 -- ^ __time_since_epoch__ +x509CertNotBefore cert = withX509Cert cert $ \ certPtr -> do + alloca $ \ timePtr -> do + botan_x509_cert_not_before + certPtr + timePtr + fromIntegral <$> peek timePtr + +-- TODO: mkGetIntegral +x509CertNotAfter + :: X509Cert -- ^ __cert__ + -> IO Word64 -- ^ __time_since_epoch__ +x509CertNotAfter cert = withX509Cert cert $ \ certPtr -> do + alloca $ \ timePtr -> do + botan_x509_cert_not_after + certPtr + timePtr + fromIntegral <$> peek timePtr + + +x509CertGetPubKeyFingerprint + :: X509Cert -- ^ __cert__ + -> HashName -- ^ __hash__ + -> IO ByteString -- ^ __out[]__ +x509CertGetPubKeyFingerprint cert algo = withX509Cert cert $ \ certPtr -> do + asCString algo $ \ algoPtr -> do + allocBytesQuerying $ \ outPtr outLen -> botan_x509_cert_get_fingerprint + certPtr + (ConstPtr algoPtr) + outPtr + outLen + +x509CertGetSerialNumber + :: X509Cert -- ^ __cert__ + -> IO ByteString -- ^ __out[]__ +x509CertGetSerialNumber = mkGetBytes withX509Cert botan_x509_cert_get_serial_number + +x509CertGetAuthorityKeyId + :: X509Cert -- ^ __cert__ + -> IO ByteString -- ^ __out[]__ +x509CertGetAuthorityKeyId = mkGetBytes withX509Cert botan_x509_cert_get_authority_key_id + +x509CertGetSubjectKeyId + :: X509Cert -- ^ __cert__ + -> IO ByteString -- ^ __out[]__ +x509CertGetSubjectKeyId = mkGetBytes withX509Cert botan_x509_cert_get_subject_key_id + +x509CertGetPublicKeyBits + :: X509Cert -- ^ __cert__ + -> IO ByteString -- ^ __out[]__ +x509CertGetPublicKeyBits = mkGetBytes withX509Cert botan_x509_cert_get_public_key_bits + +-- NOTE: Unique / quirk - the return value is the second argument? +-- This necessitates the use of `flip` +x509CertGetPublicKey + :: X509Cert -- ^ __cert__ + -> IO PubKey -- ^ __key__ +x509CertGetPublicKey = mkCreateObjectWith createPubKey withX509Cert (flip botan_x509_cert_get_public_key) + +-- Distinguished Names +-- SEE: https://www.ibm.com/docs/en/ibm-mq/7.5?topic=certificates-distinguished-names +x509CertGetIssuerDN + :: X509Cert -- ^ __cert__ + -> ByteString -- ^ __key__ + -> Int -- ^ __index__ + -> IO ByteString -- ^ __out[]__ +x509CertGetIssuerDN cert key index = withX509Cert cert $ \ certPtr -> do + asCString key $ \ keyPtr -> do + allocBytesQuerying $ \ outPtr outLen -> botan_x509_cert_get_issuer_dn + certPtr + (ConstPtr keyPtr) + (fromIntegral index) + outPtr + outLen + +-- Distinguished Names +-- SEE: https://www.ibm.com/docs/en/ibm-mq/7.5?topic=certificates-distinguished-names +x509CertGetSubjectDN + :: X509Cert -- ^ __cert__ + -> ByteString -- ^ __key__ + -> Int -- ^ __index__ + -> IO ByteString -- ^ __out[]__ +x509CertGetSubjectDN cert key index = withX509Cert cert $ \ certPtr -> do + asCString key $ \ keyPtr -> do + allocBytesQuerying $ \ outPtr outLen -> botan_x509_cert_get_issuer_dn + certPtr + (ConstPtr keyPtr) + (fromIntegral index) + outPtr + outLen + +x509CertToString + :: X509Cert -- ^ __cert__ + -> IO ByteString -- ^ __out[]__ +x509CertToString = mkGetCString withX509Cert botan_x509_cert_to_string + +-- NOTE: Per X509 key usage extension, the extension should +-- only be present if at least one of the bits is set, and +-- usage is unrestricted if the extension is not present. +-- That is, it is an optional restriction. +-- pattern NoConstraints = BOTAN_X509_CERT_KEY_CONSTRAINTS_NO_CONSTRAINTS +-- pattern DigitalSignature = BOTAN_X509_CERT_KEY_CONSTRAINTS_DIGITAL_SIGNATURE +-- pattern NonRepudiation = BOTAN_X509_CERT_KEY_CONSTRAINTS_NON_REPUDIATION +-- pattern KeyEncipherment = BOTAN_X509_CERT_KEY_CONSTRAINTS_KEY_ENCIPHERMENT +-- pattern DataEncipherment = BOTAN_X509_CERT_KEY_CONSTRAINTS_DATA_ENCIPHERMENT +-- pattern KeyAgreement = BOTAN_X509_CERT_KEY_CONSTRAINTS_KEY_AGREEMENT +-- pattern KeyCertSign = BOTAN_X509_CERT_KEY_CONSTRAINTS_KEY_CERT_SIGN +-- pattern CRLSign = BOTAN_X509_CERT_KEY_CONSTRAINTS_CRL_SIGN +-- pattern EncipherOnly = BOTAN_X509_CERT_KEY_CONSTRAINTS_ENCIPHER_ONLY +-- pattern DecipherOnly = BOTAN_X509_CERT_KEY_CONSTRAINTS_DECIPHER_ONLY +type X509KeyConstraints = CUInt + +pattern NoConstraints + , DigitalSignature + , NonRepudiation + , KeyEncipherment + , DataEncipherment + , KeyAgreement + , KeyCertSign + , CRLSign + , EncipherOnly + , DecipherOnly + :: X509KeyConstraints +pattern NoConstraints = NO_CONSTRAINTS +pattern DigitalSignature = DIGITAL_SIGNATURE +pattern NonRepudiation = NON_REPUDIATION +pattern KeyEncipherment = KEY_ENCIPHERMENT +pattern DataEncipherment = DATA_ENCIPHERMENT +pattern KeyAgreement = KEY_AGREEMENT +pattern KeyCertSign = KEY_CERT_SIGN +pattern CRLSign = CRL_SIGN +pattern EncipherOnly = ENCIPHER_ONLY +pattern DecipherOnly = DECIPHER_ONLY + +{-# WARNING x509CertAllowedUsage "Unexplained function, best-guess implementation" #-} +-- NOTE: This function lacks documentation, and it is unknown whether this is +-- setting a value (as implied by Z-botan), or whether it is using either +-- a negative error or INVALID_IDENTIFIER to return a bool +x509CertAllowedUsage + :: X509Cert -- ^ __cert__ + -> X509KeyConstraints -- ^ __key_usage__ + -> IO Bool +x509CertAllowedUsage cert usage = withX509Cert cert $ \ certPtr -> do + throwBotanCatchingSuccess $ botan_x509_cert_allowed_usage certPtr usage + +{-# WARNING x509CertHostnameMatch "Unexplained function, best-guess implementation" #-} +{- | +Check if the certificate matches the specified hostname via alternative name or CN match. +RFC 5280 wildcards also supported. +-} +x509CertHostnameMatch + :: X509Cert -- ^ __cert__ + -> ByteString -- ^ __hostname__ + -> IO Bool +x509CertHostnameMatch cert hostname = withX509Cert cert $ \ certPtr -> do + asCString hostname $ \ hostnamePtr -> do + throwBotanCatchingSuccess $ botan_x509_cert_hostname_match + certPtr + (ConstPtr hostnamePtr) + +{- | +Returns 0 if the validation was successful, 1 if validation failed, +and negative on error. A status code with details is written to +*validation_result + +Intermediates or trusted lists can be null +Trusted path can be null +-} +x509CertVerify + :: X509Cert -- ^ __cert__ + -> [X509Cert] -- ^ __intermediates__ + -> [X509Cert] -- ^ __trusted__ + -> Maybe FilePath -- ^ __trusted_path__ + -> Int -- ^ __required_strength__ + -> ByteString -- ^ __hostname__ + -> Word64 -- ^ __reference_time__ + -> IO (Bool, Int) -- ^ __(valid,validation_result)__ +x509CertVerify cert icerts tcerts tpath strength hostname time = do + withX509Cert cert $ \ certPtr -> do + withPtrs withX509Cert icerts $ flip withArrayLen $ \ icertsLen icertsPtr -> do + withPtrs withX509Cert tcerts $ flip withArrayLen $ \ tcertsLen tcertsPtr -> do + maybe ($ nullPtr) String.withCString tpath $ \ tpathPtr -> do + asCString hostname $ \ hostnamePtr -> do + alloca $ \ statusPtr -> do + success <- throwBotanCatchingSuccess $ botan_x509_cert_verify + statusPtr + certPtr + (ConstPtr icertsPtr) + (fromIntegral icertsLen) + (ConstPtr tcertsPtr) + (fromIntegral tcertsLen) + (ConstPtr tpathPtr) + (fromIntegral strength) + (ConstPtr hostnamePtr) + time + code <- fromIntegral <$> peek statusPtr + return (success, code) + -- TODO: The above works, but there's more to it + -- Need to allow null pointer for empty lists too, something like: + -- where + -- withNullPtr withPtr m = if m == mempty then ($ nullPtr) else withPtr m + -- but we'll need to fiddle with this function (and x509CertVerifyWithCLR) + +x509CertValidationStatus + :: Int -- ^ __code__ + -> IO (Maybe ByteString) +x509CertValidationStatus code = do + status <- botan_x509_cert_validation_status (fromIntegral code) + if status == ConstPtr nullPtr + then return Nothing + else Just <$> packCString (unConstPtr status) + +-- /* +-- * X.509 CRL +-- **************************/ + +-- TODO: Move to Botan.Low.X509.CRL after merging extended FFI + +newtype X509CRL = MkX509CRL { getX509CRLForeignPtr :: ForeignPtr BotanX509CRLStruct } + +newX509CRL :: BotanX509CRL -> IO X509CRL +withX509CRL :: X509CRL -> (BotanX509CRL -> IO a) -> IO a +x509CRLDestroy :: X509CRL -> IO () +createX509CRL :: (Ptr BotanX509CRL -> IO CInt) -> IO X509CRL +(newX509CRL, withX509CRL, x509CRLDestroy, createX509CRL, _) + = mkBindings MkBotanX509CRL runBotanX509CRL MkX509CRL getX509CRLForeignPtr botan_x509_crl_destroy + +x509CRLLoad + :: ByteString -- ^ __crl_bits[]__ + -> IO X509CRL -- ^ __crl_obj__ +x509CRLLoad = mkCreateObjectCBytesLen createX509CRL botan_x509_crl_load + +x509CRLLoadFile + :: FilePath -- ^ __crl_path__ + -> IO X509CRL -- ^ __crl_obj__ +x509CRLLoadFile = mkCreateObjectCString createX509CRL botan_x509_crl_load_file . Char8.pack + +{- | +Given a CRL and a certificate, +check if the certificate is revoked on that particular CRL +-} +x509IsRevoked + :: X509CRL -- ^ __crl__ + -> X509Cert -- ^ __cert__ + -> IO Bool +x509IsRevoked crl cert = withX509CRL crl $ \ crlPtr -> do + withX509Cert cert $ \ certPtr -> do + throwBotanCatchingSuccess $ botan_x509_is_revoked crlPtr certPtr + +{- | +Different flavor of `botan_x509_cert_verify`, supports revocation lists. +CRLs are passed as an array, same as intermediates and trusted CAs +-} +x509CertVerifyWithCLR + :: X509Cert -- ^ __cert__ + -> [X509Cert] -- ^ __intermediates__ + -> [X509Cert] -- ^ __trusted__ + -> [X509CRL] -- ^ __crls__ + -> Maybe FilePath -- ^ __trusted_path__ + -> Int -- ^ __required_strength__ + -> ByteString -- ^ __hostname__ + -> Word64 -- ^ __reference_time__ + -> IO (Bool, Int) -- ^ __(valid,validation_result)__ +x509CertVerifyWithCLR cert icerts tcerts crls tpath strength hostname time = do + withX509Cert cert $ \ certPtr -> do + withPtrs withX509Cert icerts $ flip withArrayLen $ \ icertsLen icertsPtr -> do + withPtrs withX509Cert tcerts $ flip withArrayLen $ \ tcertsLen tcertsPtr -> do + withPtrs withX509CRL crls $ flip withArrayLen $ \ crlsLen crlsPtr -> do + maybe ($ nullPtr) String.withCString tpath $ \ tpathPtr -> do + asCString hostname $ \ hostnamePtr -> do + alloca $ \ statusPtr -> do + success <- throwBotanCatchingSuccess $ botan_x509_cert_verify_with_crl + statusPtr + certPtr + (ConstPtr icertsPtr) + (fromIntegral icertsLen) + (ConstPtr tcertsPtr) + (fromIntegral tcertsLen) + (ConstPtr crlsPtr) + (fromIntegral crlsLen) + (ConstPtr tpathPtr) + (fromIntegral strength) + (ConstPtr hostnamePtr) + time + code <- fromIntegral <$> peek statusPtr + return (success, code) diff --git a/src/Botan/Low/X509/CA.hs b/src/Botan/Low/X509/CA.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/X509/CA.hs @@ -0,0 +1,115 @@ +module Botan.Low.X509.CA where + +import Data.Bool + +import Botan.Low.Error +import Botan.Low.Prelude +import Botan.Low.Hash +import Botan.Low.Make +import Botan.Low.MPI +import Botan.Low.PubKey +import Botan.Low.PubKey.Sign +import Botan.Low.RNG +import Botan.Low.X509 +import Botan.Low.X509.CSR +import Botan.Low.X509.Extensions + +import Botan.Bindings.X509 +import Botan.Bindings.X509.CA +import Botan.Bindings.X509.Extensions + +-- /* +-- * X.509 certificate authority +-- **************************/ + +newtype X509CA = MkX509CA { getX509CAForeignPtr :: ForeignPtr X509CAStruct } + +withX509CAPtr :: X509CA -> (X509CAPtr -> IO a) -> IO a +withX509CAPtr = withForeignPtr . getX509CAForeignPtr + +x509CADestroy :: X509CA -> IO () +x509CADestroy ca = finalizeForeignPtr (getX509CAForeignPtr ca) + +x509CACreate :: X509Cert -> PrivKey -> HashName -> RNG -> IO X509CA +x509CACreate cert key hash_fn rng = do + withX509Cert cert $ \ certPtr -> do + withPrivKey key $ \ keyPtr -> do + asCString hash_fn $ \ hashPtr -> do + withRNG rng $ \ botanRNG -> do + mkInit + MkX509CA + (\ caPtr -> botan_x509_ca_create + caPtr + certPtr + keyPtr + hashPtr + botanRNG + ) + botan_x509_ca_destroy + +x509CACreatePadding :: X509Cert -> PrivKey -> HashName -> X509PaddingName -> RNG -> IO X509CA +x509CACreatePadding cert key hash_fn padding_fn rng = do + withX509Cert cert $ \ certPtr -> do + withPrivKey key $ \ keyPtr -> do + asCString hash_fn $ \ hashPtr -> do + asCString padding_fn $ \ paddingPtr -> do + withRNG rng $ \ botanRNG -> do + mkInit + MkX509CA + (\ caPtr -> botan_x509_ca_create_padding + caPtr + certPtr + keyPtr + hashPtr + paddingPtr + botanRNG + ) + botan_x509_ca_destroy + +x509CASignRequest :: X509CA -> X509CSR -> RNG -> Word64 -> Word64 -> IO X509Cert +x509CASignRequest ca csr rng not_before not_after = do + withX509CAPtr ca $ \ caPtr -> do + withX509CSRPtr csr $ \ csrPtr -> do + withRNG rng $ \ botanRNG -> do + mkInit + MkX509Cert + (\ certPtr -> botan_x509_ca_sign_request certPtr caPtr csrPtr botanRNG not_before not_after) + botan_x509_cert_destroy + +-- NOTE: This is a static function on X509CA, so it doesn't take an actual X509CA object +x509CAMakeCertSerial :: SignCtx -> RNG -> MP -> SignAlgoName -> PubKey -> Word64 -> Word64 -> X509SubjectDN -> X509IssuerDN -> X509Extensions -> IO X509Cert +x509CAMakeCertSerial signer rng serial signalgo pubkey not_before not_after subject_dn issuer_dn exts = do + withSignPtr signer $ \ signerPtr -> do + withRNG rng $ \ botanRNG -> do + withMP serial $ \ serialPtr -> do + asCString signalgo $ \ signalgoPtr -> do + withPubKey pubkey $ \ pubkeyPtr -> do + asBytesLen subject_dn $ \ subject_dn_ptr subject_dn_len -> do + asBytesLen issuer_dn $ \ issuer_dn_ptr issuer_dn_len -> do + withX509ExtensionsPtr exts $ \ extsPtr -> do + mkInit + MkX509Cert + (\ certPtr -> botan_x509_ca_make_cert_serial + certPtr + signerPtr + botanRNG + serialPtr + signalgoPtr + pubkeyPtr + not_before + not_after + subject_dn_ptr subject_dn_len + issuer_dn_ptr issuer_dn_len + extsPtr + ) + botan_x509_cert_destroy + +x509CAChooseExtensions :: X509CSR -> X509Cert -> HashName -> IO X509Extensions +x509CAChooseExtensions csr cert hash_fn = do + withX509CSRPtr csr $ \ csrPtr -> do + withX509Cert cert $ \ certPtr -> do + asCString hash_fn $ \ hashPtr -> do + mkInit + MkX509Extensions + (\ extsPtr -> botan_x509_ca_choose_extensions extsPtr csrPtr certPtr hashPtr) + botan_x509_exts_destroy diff --git a/src/Botan/Low/X509/CRL.hs b/src/Botan/Low/X509/CRL.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/X509/CRL.hs @@ -0,0 +1,151 @@ +module Botan.Low.X509.CRL where + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.X509 +import Botan.Low.X509.Extensions + +import Botan.Bindings.X509 +import Botan.Bindings.X509.Extensions +import Botan.Bindings.X509.CRL +import Botan.Low.X509.CSR (X509IssuerDN) + +-- +-- CRL +-- + +-- TODO: Eventually move original / read-only CRL functions here too + +x509CRLGetRevoked :: X509CRL -> IO [X509CRLEntry] +x509CRLGetRevoked crl = withX509CRL crl $ \ crlPtr -> do + -- TODO: Some sort of allocArrayQuerying + undefined + +x509CRLGetIssuerDN :: X509CRL -> ByteString -> Int -> IO X509IssuerDN +x509CRLGetIssuerDN crl key index = withX509CRL crl $ \ crlPtr -> do + asBytes key $ \ keyPtr -> do + allocBytesQuerying $ \ outPtr outLen -> botan_x509_crl_get_issuer_dn + outPtr + outLen + crlPtr + keyPtr + (fromIntegral index) + +x509CRLExtensions :: X509CRL -> IO X509Extensions +x509CRLExtensions crl = withX509CRL crl $ \ crlPtr -> mkInit + MkX509Extensions + (\ ptr -> botan_x509_crl_extensions ptr crlPtr) + botan_x509_exts_destroy + +x509CRLAuthorityKeyId :: X509CRL -> IO ByteString +x509CRLAuthorityKeyId crl = withX509CRL crl $ \ crlPtr -> do + allocBytesQuerying $ \ outPtr outLen -> botan_x509_crl_authority_key_id + outPtr outLen + crlPtr + +x509CRLSerialNumber :: X509CRL -> IO Word32 +x509CRLSerialNumber crl = withX509CRL crl $ \ crlPtr -> do + alloca $ \ snPtr -> do + throwBotanIfNegative_ $ botan_x509_crl_serial_number snPtr crlPtr + peek snPtr + +x509CRLThisUpdate :: X509CRL -> IO Word64 +x509CRLThisUpdate crl = withX509CRL crl $ \ crlPtr -> do + alloca $ \ timePtr -> do + throwBotanIfNegative_ $ botan_x509_crl_this_update timePtr crlPtr + peek timePtr + +x509CRLNextUpdate :: X509CRL -> IO Word64 +x509CRLNextUpdate crl = withX509CRL crl $ \ crlPtr -> do + alloca $ \ timePtr -> do + throwBotanIfNegative_ $ botan_x509_crl_next_update timePtr crlPtr + peek timePtr + +x509CRLIssuingDistributionPoint :: X509CRL -> IO ByteString +x509CRLIssuingDistributionPoint crl = withX509CRL crl $ \ crlPtr -> do + allocBytesQuerying $ \ outPtr outLen -> botan_x509_crl_issuing_distribution_point + outPtr outLen + crlPtr + +x509CRLCreateDER :: ByteString -> IO X509CRL +x509CRLCreateDER der = do + asBytesLen der $ \ derPtr derLen -> mkInit + MkX509CRL + (\ptr -> botan_x509_crl_create_der ptr derPtr derLen) + botan_x509_crl_destroy + +x509CRLCreate :: X509IssuerDN -> Word64 -> Word64 -> [X509CRLEntry] -> IO X509CRL +x509CRLCreate der this next entries = do + -- TODO: withArray, ownership transfer + -- asBytesLen der $ \ derPtr derLen -> mkInit + -- MkX509CRL + -- (\ptr -> botan_x509_crl_create ptr derPtr derLen) + -- botan_x509_crl_destroy + undefined + +x509CRLAddEntry :: X509CRL -> X509CRLEntry -> IO () +x509CRLAddEntry crl entry = undefined + +x509CRLRevokeCert :: X509CRL -> X509Cert -> X509CRLCode -> IO () +x509CRLRevokeCert crl entry reason = undefined + +-- +-- CRL Entry +-- + +newtype X509CRLEntry = MkX509CRLEntry { getX509CRLEntryForeignPtr :: ForeignPtr X509CRLEntryStruct } + +withX509CRLEntryPtr :: X509CRLEntry -> (X509CRLEntryPtr -> IO a) -> IO a +withX509CRLEntryPtr = withForeignPtr . getX509CRLEntryForeignPtr + +x509CRLEntryDestroy :: X509CRLEntry -> IO () +x509CRLEntryDestroy crl = finalizeForeignPtr (getX509CRLEntryForeignPtr crl) + +type X509CRLCode = Word32 + +-- Must match values of CRL_Code in pkix_enums.h +pattern BOTAN_X509_CRL_CODE_UNSPECIFIED = 0 :: X509CRLCode +pattern BOTAN_X509_CRL_CODE_KEY_COMPROMISE = 1 :: X509CRLCode +pattern BOTAN_X509_CRL_CODE_CA_COMPROMISE = 2 :: X509CRLCode +pattern BOTAN_X509_CRL_CODE_AFFILIATION_CHANGED = 3 :: X509CRLCode +pattern BOTAN_X509_CRL_CODE_SUPERCEDED = 4 :: X509CRLCode +pattern BOTAN_X509_CRL_CODE_CESSATION_OF_OPERATION = 5 :: X509CRLCode +pattern BOTAN_X509_CRL_CODE_CERTIFICATE_HOLD = 6 :: X509CRLCode +pattern BOTAN_X509_CRL_CODE_REMOVE_FROM_CRL = 8 :: X509CRLCode +pattern BOTAN_X509_CRL_CODE_PRIVILEGE_WITHDRAWN = 9 :: X509CRLCode +pattern BOTAN_X509_CRL_CODE_AA_COMPROMISE = 10 :: X509CRLCode + +x509CRLEntryCreate :: X509Cert -> X509CRLCode -> IO X509CRLEntry +x509CRLEntryCreate cert crl_code = do + withX509Cert cert $ \ certPtr -> mkInit + MkX509CRLEntry + (\ptr -> botan_x509_crl_entry_create ptr certPtr crl_code) + botan_x509_crl_entry_destroy + +-- -- TODO: CRL_Entry PEM / BER encode / decode (and for CRL too) + +-- NOTE: Is bytestring serial number vs MP serial number elsewhere - need to consistentize +x509CRLEntryGetSerialNumber :: X509CRLEntry -> IO ByteString +x509CRLEntryGetSerialNumber entry = withX509CRLEntryPtr entry $ \ entryPtr -> do + allocBytesQuerying $ \ outPtr szPtr -> do + botan_x509_crl_entry_get_serial_number outPtr szPtr entryPtr + +x509CRLEntryGetExpireTime :: X509CRLEntry -> IO Word64 +x509CRLEntryGetExpireTime entry = withX509CRLEntryPtr entry $ \ entryPtr -> do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ botan_x509_crl_entry_get_expire_time outPtr entryPtr + peek outPtr + +x509CRLEntryGetReasonCode :: X509CRLEntry -> IO X509CRLCode +x509CRLEntryGetReasonCode entry = withX509CRLEntryPtr entry $ \ entryPtr -> do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ botan_x509_crl_entry_get_reason_code outPtr entryPtr + peek outPtr + +x509CRLEntryGetExtensions :: X509CRLEntry -> IO X509Extensions +x509CRLEntryGetExtensions entry = withX509CRLEntryPtr entry $ \ entryPtr -> do + mkInit + MkX509Extensions + (\ ptr -> botan_x509_crl_entry_get_extensions ptr entryPtr) + botan_x509_exts_destroy diff --git a/src/Botan/Low/X509/CSR.hs b/src/Botan/Low/X509/CSR.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/X509/CSR.hs @@ -0,0 +1,85 @@ +module Botan.Low.X509.CSR where + +import Botan.Low.Error +import Botan.Low.Hash (HashName(..)) +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.PubKey +import Botan.Low.RNG +import Botan.Low.X509 +import Botan.Low.X509.Extensions +import Botan.Low.X509.Options + +import Botan.Bindings.X509 +import Botan.Bindings.X509.CSR + +-- /* +-- * X.509 certificate signing request +-- **************************/ + +type X509SubjectDN = ByteString +type X509IssuerDN = ByteString + +-- NOTE: It is unknown which paddings are accepted (eg, compare cbc vs pk padding) +type X509PaddingName = ByteString +type X509Challenge = ByteString + +newtype X509CSR = MkX509CSR { getX509CSRForeignPtr :: ForeignPtr X509CSRStruct } + +withX509CSRPtr :: X509CSR -> (X509CSRPtr -> IO a) -> IO a +withX509CSRPtr = withForeignPtr . getX509CSRForeignPtr + +x509CSRDestroy :: X509CSR -> IO () +x509CSRDestroy csr = finalizeForeignPtr (getX509CSRForeignPtr csr) + +-- NOTE: It really appears that this is the successful init pattern; +-- I ought to formalize it using type-level lists or something +x509CreateCertReq :: X509CertOptions -> PrivKey -> HashName -> RNG -> IO X509CSR +x509CreateCertReq options key hash_fn rng = withX509CertOptionsPtr options $ \ optionsPtr -> do + withPrivKey key $ \ keyPtr -> do + asCString hash_fn $ \ hashPtr -> do + withRNG rng $ \ botanRNG -> do + mkInit + MkX509CSR + (\ csrPtr -> botan_x509_create_cert_req csrPtr optionsPtr keyPtr hashPtr botanRNG) + botan_x509_csr_destroy + +x509CSRCreate :: PrivKey -> X509SubjectDN -> X509Extensions -> HashName -> RNG -> X509PaddingName -> X509Challenge -> IO X509CSR +x509CSRCreate privkey subjectDN exts hash_fn rng padding_fn challenge = do + withPrivKey privkey $ \ privkeyPtr -> do + asBytesLen subjectDN $ \ subjectDNPtr subjectDNLen -> do + withX509ExtensionsPtr exts $ \ extsPtr -> do + asCString hash_fn $ \ hashPtr -> do + withRNG rng $ \ botanRNG -> do + asCString padding_fn $ \ paddingPtr -> do + asCString challenge $ \ challengePtr -> do + mkInit + MkX509CSR + (\ csrPtr -> botan_x509_csr_create + csrPtr + privkeyPtr + subjectDNPtr subjectDNLen + extsPtr + hashPtr + botanRNG + paddingPtr + challengePtr + ) + botan_x509_csr_destroy + +x509CreateSelfSignedCert :: X509CertOptions -> PrivKey -> HashName -> RNG -> IO X509Cert +x509CreateSelfSignedCert options key hash_fn rng = do + withX509CertOptionsPtr options $ \ optionsPtr -> do + withPrivKey key $ \ keyPtr -> do + asCString hash_fn $ \ hashPtr -> do + withRNG rng $ \ botanRNG -> do + mkInit + MkX509Cert + (\ certPtr -> botan_x509_create_self_signed_cert + certPtr + optionsPtr + keyPtr + hashPtr + botanRNG + ) + botan_x509_cert_destroy diff --git a/src/Botan/Low/X509/DN.hs b/src/Botan/Low/X509/DN.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/X509/DN.hs @@ -0,0 +1,60 @@ +module Botan.Low.X509.DN where + +import Botan.Low.Error +import Botan.Low.Prelude +import Botan.Low.X509 + +import Botan.Bindings.X509.DN + +newtype X509DN = MkX509DN { getX509DNForeignPtr :: ForeignPtr X509DNStruct } + +withX509DNPtr :: X509DN -> (X509DNPtr -> IO a) -> IO a +withX509DNPtr = withForeignPtr . getX509DNForeignPtr + +x509DNDestroy :: X509DN -> IO () +x509DNDestroy dn = finalizeForeignPtr (getX509DNForeignPtr dn) + +-- foreign import ccall unsafe botan_x509_dn_create +-- :: Ptr X509DNPtr +-- -> IO BotanErrorCode + +-- foreign import ccall unsafe botan_x509_dn_create_from_multimap +-- :: Ptr X509DNPtr +-- -> Ptr Word8 -> Ptr CSize +-- -> Ptr Word8 -> Ptr CSize +-- -> CSize +-- -> IO BotanErrorCode + +-- foreign import ccall unsafe botan_x509_dn_to_string +-- :: Ptr Word8 -> Ptr CSize +-- -> X509DNPtr +-- -> IO BotanErrorCode + +-- -- NOTE: Returns a bool success code +-- foreign import ccall unsafe botan_x509_dn_has_field +-- :: X509DNPtr +-- -> Ptr Word8 -> CSize +-- -> IO BotanErrorCode + +-- foreign import ccall unsafe botan_x509_dn_get_first_attribute +-- :: Ptr Word8 -> Ptr CSize +-- -> X509DNPtr +-- -> Ptr Word8 -> CSize +-- -> IO BotanErrorCode + +-- foreign import ccall unsafe botan_x509_dn_get_attribute +-- :: Ptr (Ptr Word8) -> Ptr CSize -> Ptr CSize +-- -> X509DNPtr +-- -> Ptr Word8 -> CSize +-- -> IO BotanErrorCode + +-- foreign import ccall unsafe botan_x509_dn_contents +-- :: Ptr (Ptr Word8) -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> Ptr CSize +-- -> X509DNPtr +-- -> IO BotanErrorCode + +-- foreign import ccall unsafe botan_x509_dn_add_attribute +-- :: X509DNPtr +-- -> Ptr Word8 -> CSize +-- -> Ptr Word8 -> CSize +-- -> IO BotanErrorCode diff --git a/src/Botan/Low/X509/Extensions.hs b/src/Botan/Low/X509/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/X509/Extensions.hs @@ -0,0 +1,26 @@ +module Botan.Low.X509.Extensions where + +import Botan.Low.Error +import Botan.Low.Prelude +import Botan.Low.X509 + +import Botan.Bindings.X509.Extensions + +newtype X509Extensions = MkX509Extensions { getX509ExtensionsForeignPtr :: ForeignPtr X509ExtensionsStruct } + +withX509ExtensionsPtr :: X509Extensions -> (X509ExtensionsPtr -> IO a) -> IO a +withX509ExtensionsPtr = withForeignPtr . getX509ExtensionsForeignPtr + +x509ExtensionsDestroy :: X509Extensions -> IO () +x509ExtensionsDestroy exts = finalizeForeignPtr (getX509ExtensionsForeignPtr exts) + +newtype X509Extension = MkX509Extension { getX509ExtensionForeignPtr :: ForeignPtr X509ExtensionStruct } + +withX509ExtensionPtr :: X509Extension -> (X509ExtensionPtr -> IO a) -> IO a +withX509ExtensionPtr = withForeignPtr . getX509ExtensionForeignPtr + +x509ExtensionDestroy :: X509Extension -> IO () +x509ExtensionDestroy ext = finalizeForeignPtr (getX509ExtensionForeignPtr ext) + +-- TODO: See C FFI for discussion on pending implementation + diff --git a/src/Botan/Low/X509/Options.hs b/src/Botan/Low/X509/Options.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/X509/Options.hs @@ -0,0 +1,157 @@ +module Botan.Low.X509.Options where + +import Data.Bool + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.X509 +import Botan.Low.X509.Extensions + +import Botan.Bindings.X509.Options + +-- /* +-- * X.509 certificate options +-- **************************/ + +newtype X509CertOptions = MkX509CertOptions { getX509CertOptionsForeignPtr :: ForeignPtr X509CertOptionsStruct } + +withX509CertOptionsPtr :: X509CertOptions -> (X509CertOptionsPtr -> IO a) -> IO a +withX509CertOptionsPtr = withForeignPtr . getX509CertOptionsForeignPtr + +x509CertOptionsDestroy :: X509CertOptions -> IO () +x509CertOptionsDestroy opts = finalizeForeignPtr (getX509CertOptionsForeignPtr opts) + +x509CertOptionsCreate :: IO X509CertOptions +x509CertOptionsCreate = mkInit MkX509CertOptions botan_x509_cert_options_create botan_x509_cert_options_destroy + +x509CertOptionsCreateCommon + :: ByteString + -> ByteString + -> ByteString + -> ByteString + -> Word32 + -> IO X509CertOptions +x509CertOptionsCreateCommon common_name country org org_unit expiration_time = do + alloca $ \ outPtr -> do + asCString common_name $ \ cnPtr -> do + asCString country $ \ countryPtr -> do + asCString org $ \ orgPtr -> do + asCString org_unit $ \ orgUnitPtr -> do + throwBotanIfNegative_ $ botan_x509_cert_options_create_common outPtr + cnPtr + countryPtr + orgPtr + orgUnitPtr + expiration_time + out <- peek outPtr + foreignPtr <- newForeignPtr botan_x509_cert_options_destroy out + return $ MkX509CertOptions foreignPtr + +x509CertOptionsSetCommonName :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetCommonName = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_common_name + +x509CertOptionsSetCountry :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetCountry = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_country + +x509CertOptionsSetOrg :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetOrg = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_organization + +x509CertOptionsSetOrgUnit :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetOrgUnit = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_org_unit + +x509CertOptionsSetMoreOrgUnits :: X509CertOptions -> [ByteString] -> IO () +x509CertOptionsSetMoreOrgUnits opts more_org_units = withX509CertOptionsPtr opts $ \ optsPtr -> do + withPtrs asCString more_org_units $ \ morePtrs -> do + allocaArray moreLen $ \ (morePtrArrayPtr :: Ptr (Ptr CChar)) -> do + pokeArray morePtrArrayPtr morePtrs + throwBotanIfNegative_ $ botan_x509_cert_options_set_more_org_units + optsPtr + morePtrArrayPtr + (fromIntegral moreLen) + where + moreLen = length more_org_units + +x509CertOptionsSetLocality :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetLocality = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_locality + +x509CertOptionsSetState :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetState = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_state + +x509CertOptionsSetSerialNumber :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetSerialNumber = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_serial_number + +x509CertOptionsSetEmail :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetEmail = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_email + +x509CertOptionsSetURI :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetURI = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_uri + +x509CertOptionsSetIP :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetIP = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_ip + +x509CertOptionsSetDNS :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetDNS = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_dns + +x509CertOptionsSetMoreDNS :: X509CertOptions -> [ByteString] -> IO () +x509CertOptionsSetMoreDNS opts more_dns = withX509CertOptionsPtr opts $ \ optsPtr -> do + withPtrs asCString more_dns $ \ morePtrs -> do + allocaArray moreLen $ \ (morePtrArrayPtr :: Ptr (Ptr CChar)) -> do + pokeArray morePtrArrayPtr morePtrs + throwBotanIfNegative_ $ botan_x509_cert_options_set_more_dns + optsPtr + morePtrArrayPtr + (fromIntegral moreLen) + where + moreLen = length more_dns + +x509CertOptionsSetXMPP :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetXMPP = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_xmpp + +x509CertOptionsSetChallenge :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetChallenge = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_challenge + +x509CertOptionsSetStart :: X509CertOptions -> Word64 -> IO () +x509CertOptionsSetStart = mkSet withX509CertOptionsPtr botan_x509_cert_options_set_start + +x509CertOptionsSetEnd :: X509CertOptions -> Word64 -> IO () +x509CertOptionsSetEnd = mkSet withX509CertOptionsPtr botan_x509_cert_options_set_end + +-- // TODO: Convenience functions for set_start_duration, set_expires + +x509CertOptionsSetIsCA :: X509CertOptions -> Bool -> IO () +x509CertOptionsSetIsCA = mkSetOn withX509CertOptionsPtr (CBool . bool 0 1) botan_x509_cert_options_set_is_ca + +x509CertOptionsSetPathLimit :: X509CertOptions -> Int -> IO () +x509CertOptionsSetPathLimit = mkSetCSize withX509CertOptionsPtr botan_x509_cert_options_set_path_limit + +x509CertOptionsSetPaddingScheme :: X509CertOptions -> ByteString -> IO () +x509CertOptionsSetPaddingScheme = mkSetCString withX509CertOptionsPtr botan_x509_cert_options_set_padding_scheme + +-- NOTE: Should probably be Word rather than Int +x509CertOptionsSetKeyConstraints :: X509CertOptions -> Int -> IO () +x509CertOptionsSetKeyConstraints = mkSetOn withX509CertOptionsPtr fromIntegral botan_x509_cert_options_set_key_constraints + +x509CertOptionsSetExConstraints :: X509CertOptions -> [ByteString] -> IO () +x509CertOptionsSetExConstraints opts exConstraints = withX509CertOptionsPtr opts $ \ optsPtr -> do + withPtrs asCString exConstraints $ \ exPtrs -> do + allocaArray exLen $ \ (exPtrArrayPtr :: Ptr (Ptr CChar)) -> do + pokeArray exPtrArrayPtr exPtrs + throwBotanIfNegative_ $ botan_x509_cert_options_set_ex_constraints + optsPtr + exPtrArrayPtr + (fromIntegral exLen) + where + exLen = length exConstraints + +x509CertOptionsSetExtensions :: X509CertOptions -> X509Extensions -> IO () +x509CertOptionsSetExtensions opts extensions = withX509CertOptionsPtr opts $ \ optsPtr -> do + withX509ExtensionsPtr extensions $ \ extensionPtr -> do + throwBotanIfNegative_ $ botan_x509_cert_options_set_extensions + optsPtr + extensionPtr + +-- TODO: botan_x509_cert_options getters + +-- TODO: botan_x509_cert_options functions (above is just members) +-- There's only a few though so its easy diff --git a/src/Botan/Low/X509/Path.hs b/src/Botan/Low/X509/Path.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/X509/Path.hs @@ -0,0 +1,141 @@ +module Botan.Low.X509.Path where + +import Foreign.Marshal.Utils + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.X509 +import Botan.Low.X509.Store + +import Botan.Bindings.X509 +import Botan.Bindings.X509.Path + +newtype X509PathRestrictions = MkX509PathRestrictions { getX509PathRestrictionsForeignPtr :: ForeignPtr X509PathRestrictionsStruct } + +withX509PathRestrictionsPtr :: X509PathRestrictions -> (X509PathRestrictionsPtr -> IO a) -> IO a +withX509PathRestrictionsPtr = withForeignPtr . getX509PathRestrictionsForeignPtr + +x509PathRestrictionsDestroy :: X509PathRestrictions -> IO () +x509PathRestrictionsDestroy restrictions = finalizeForeignPtr (getX509PathRestrictionsForeignPtr restrictions) + +x509PathRestrictionsCreate :: Bool -> Int -> Bool -> Word64 -> X509CertStore -> IO X509PathRestrictions +x509PathRestrictionsCreate require_rev minimum_key_strength ocsp_all_intermediates max_ocsp_age trusted_ocsp_responders = do + withX509CertStorePtr trusted_ocsp_responders $ \ trustedStorePtr -> do + mkInit + MkX509PathRestrictions + (\ pvPtr -> botan_x509_path_restrictions_create + pvPtr + (fromBool require_rev) + (fromIntegral minimum_key_strength) + (fromBool ocsp_all_intermediates) + max_ocsp_age + trustedStorePtr + ) + botan_x509_path_restrictions_destroy + +-- TODO: x509PathRestrictionsCreateTrustedHashes + +newtype X509PathValidation = MkX509PathValidation { getX509PathValidationForeignPtr :: ForeignPtr X509PathValidationStruct } + +withX509PathValidationPtr :: X509PathValidation -> (X509PathValidationPtr -> IO a) -> IO a +withX509PathValidationPtr = withForeignPtr . getX509PathValidationForeignPtr + +x509PathValidationDestroy :: X509PathValidation -> IO () +x509PathValidationDestroy validation = finalizeForeignPtr (getX509PathValidationForeignPtr validation) + +-- NOTE: OCSPResponse not yet implemented +x509PathValidate :: X509Cert -> X509PathRestrictions -> X509CertStore -> ByteString -> Word32 -> Word64 -> Word64 -> Ptr () -> IO X509PathValidation +x509PathValidate cert restrictions store hostname usage validationTime ocspTimeout ocspResponse = do + withX509Cert cert $ \ certPtr -> do + withX509PathRestrictionsPtr restrictions $ \ restrictionsPtr -> do + withX509CertStorePtr store $ \ storePtr -> do + asCString hostname $ \ hostnamePtr -> do + mkInit + MkX509PathValidation + (\ pvPtr -> botan_x509_path_validate + pvPtr + certPtr + restrictionsPtr + storePtr + hostnamePtr + (fromIntegral usage) + validationTime + ocspTimeout + ocspResponse + ) + botan_x509_path_validation_destroy + +x509PathValidationSuccessfulValidation :: X509PathValidation -> IO Bool +x509PathValidationSuccessfulValidation pv = withX509PathValidationPtr pv $ \ pvPtr -> do + throwBotanCatchingSuccess $ botan_x509_path_validation_successful_validation pvPtr + +x509PathValidationResultString :: X509PathValidation -> IO ByteString +x509PathValidationResultString pv = withX509PathValidationPtr pv $ \ pvPtr -> do + allocBytesQueryingCString $ \ resultPtr resultLen -> do + botan_x509_path_validation_result_string resultPtr resultLen pvPtr + +x509PathValidationTrustRoot :: X509PathValidation -> IO X509Cert +x509PathValidationTrustRoot pv = withX509PathValidationPtr pv $ \ pvPtr -> do + mkInit + MkX509Cert + (\ certPtr -> botan_x509_path_validation_trust_root certPtr pvPtr) + botan_x509_cert_destroy + +-- TODO: Need some sort of allocArrayQuerying, or a mkArrayInit +x509PathValidationCertPath :: X509PathValidation -> IO [X509Cert] +x509PathValidationCertPath pv = withX509PathValidationPtr pv $ \ pvPtr -> do + let fn arrPtr szPtr = botan_x509_path_validation_cert_path arrPtr szPtr pvPtr + alloca $ \ szPtr -> do + code <- fn nullPtr szPtr + case code of + InsufficientBufferSpace -> do + sz <- fromIntegral <$> peek szPtr + allocaArray sz $ \ arrPtr -> do + throwBotanIfNegative_ $ fn arrPtr szPtr + certPtrs <- peekArray sz arrPtr + -- NOTE: Cannot use mkInit because that performs an alloca and a peek, + -- whereas we have already performed that work here + forM certPtrs $ \ certPtr -> do + foreignPtr <- newForeignPtr botan_x509_cert_destroy certPtr + return $ MkX509Cert foreignPtr + _ -> throwBotanError code + +type X509PathValidationStatusCode = Int + +x509PathValidationStatusCode :: X509PathValidation -> IO X509PathValidationStatusCode +x509PathValidationStatusCode pv = withX509PathValidationPtr pv $ \ pvPtr -> do + alloca $ \ statusCodePtr -> do + throwBotanIfNegative_ $ botan_x509_path_validation_status_code statusCodePtr pvPtr + fromIntegral <$> peek statusCodePtr + +-- TODO: Need some sort of allocArrayQuerying, or a mkArrayInit +x509PathValidationAllStatusCodes :: X509PathValidation -> IO [X509PathValidationStatusCode] +x509PathValidationAllStatusCodes pv = withX509PathValidationPtr pv $ \ pvPtr -> do + let fn arrPtr szPtr = botan_x509_path_validation_all_status_codes arrPtr szPtr pvPtr + alloca $ \ szPtr -> do + code <- fn nullPtr szPtr + case code of + InsufficientBufferSpace -> do + sz <- fromIntegral <$> peek szPtr + allocaArray sz $ \ arrPtr -> do + throwBotanIfNegative_ $ fn arrPtr szPtr + fmap fromIntegral <$> peekArray sz arrPtr + _ -> throwBotanError code + +-- NOTE: Array of strings - extra tricky, not finished yet, will be reused +-- NOTE: Similar to x509DNGetAttribute / x509DNGetContents +x509PathValidationTrustedHashes :: X509PathValidation -> IO [ByteString] +x509PathValidationTrustedHashes pv = withX509PathValidationPtr pv $ \ pvPtr -> do + let fn arrPtr sizesPtr szPtr = botan_x509_path_validation_trusted_hashes arrPtr sizesPtr szPtr pvPtr + alloca $ \ szPtr -> do + code <- fn nullPtr nullPtr szPtr + case code of + InsufficientBufferSpace -> do + sz <- fromIntegral <$> peek szPtr + allocaArray sz $ \ sizesPtr -> do + code' <- fn nullPtr sizesPtr szPtr + case code' of + -- TODO: Actually fill out array of strings + _ -> undefined + _ -> throwBotanError code diff --git a/src/Botan/Low/X509/Store.hs b/src/Botan/Low/X509/Store.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/X509/Store.hs @@ -0,0 +1,326 @@ +module Botan.Low.X509.Store where + +import Data.Bool +import Foreign.Marshal.Utils + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude +import Botan.Low.PubKey +import Botan.Low.RNG +import Botan.Low.X509 + +import Botan.Bindings.PubKey +import Botan.Bindings.X509 +import Botan.Bindings.X509.Store + +newtype X509CertStore = MkX509CertStore { getX509CertStoreForeignPtr :: ForeignPtr X509CertStoreStruct } + +withX509CertStorePtr :: X509CertStore -> (X509CertStorePtr -> IO a) -> IO a +withX509CertStorePtr = withForeignPtr . getX509CertStoreForeignPtr + +x509CertStoreDestroy :: X509CertStore -> IO () +x509CertStoreDestroy ca = finalizeForeignPtr (getX509CertStoreForeignPtr ca) + +-- NOTE: mkInit cannot handle Maybes (checking for nullPtr), need a mkInitMaybe or to use maybePeek +x509CertStoreFindCert :: X509CertStore -> ByteString -> ByteString -> IO (Maybe X509Cert) +x509CertStoreFindCert store subject_dn key_id = withX509CertStorePtr store $ \ store_ptr -> do + asBytesLen subject_dn $ \ subject_dn_ptr subject_dn_len -> do + asBytesLen key_id $ \ key_id_ptr key_id_len -> do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_find_cert + outPtr + store_ptr + subject_dn_ptr + subject_dn_len + key_id_ptr + key_id_len + out <- peek outPtr + if out == nullPtr + then return Nothing + else do + foreignPtr <- newForeignPtr botan_x509_cert_destroy out + return $ Just $ MkX509Cert foreignPtr + +-- NOTE: Untested +-- TODO: Need some sort of allocArrayQuerying, or a mkArrayInit +x509CertStoreFindAllCerts :: X509CertStore -> ByteString -> ByteString -> IO [X509Cert] +x509CertStoreFindAllCerts store subject_dn key_id = withX509CertStorePtr store $ \ store_ptr -> do + asBytesLen subject_dn $ \ subject_dn_ptr subject_dn_len -> do + asBytesLen key_id $ \ key_id_ptr key_id_len -> do + let fn arrPtr szPtr = botan_x509_cert_store_find_all_certs arrPtr szPtr store_ptr subject_dn_ptr subject_dn_len key_id_ptr key_id_len + alloca $ \ szPtr -> do + code <- fn nullPtr szPtr + case code of + InsufficientBufferSpace -> do + sz <- fromIntegral <$> peek szPtr + allocaArray sz $ \ arrPtr -> do + throwBotanIfNegative_ $ fn arrPtr szPtr + certPtrs <- peekArray sz arrPtr + -- NOTE: Cannot use mkInit because that performs an alloca and a peek, + -- whereas we have already performed that work here + forM certPtrs $ \ certPtr -> do + foreignPtr <- newForeignPtr botan_x509_cert_destroy certPtr + return $ MkX509Cert foreignPtr + _ -> throwBotanError code + +-- TODO: Use mkInitMaybe +x509CertStoreFindCertByPubkeySHA1 :: X509CertStore -> ByteString -> IO (Maybe X509Cert) +x509CertStoreFindCertByPubkeySHA1 store digest = withX509CertStorePtr store $ \ store_ptr -> do + asBytesLen digest $ \ digest_ptr _ -> do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_find_cert_by_pubkey_sha1 + outPtr + store_ptr + digest_ptr + out <- peek outPtr + if out == nullPtr + then return Nothing + else do + foreignPtr <- newForeignPtr botan_x509_cert_destroy out + return $ Just $ MkX509Cert foreignPtr + +-- TODO: Use mkInitMaybe +x509CertStoreFindCertByRawSubjectDNSHA256 :: X509CertStore -> ByteString -> IO (Maybe X509Cert) +x509CertStoreFindCertByRawSubjectDNSHA256 store digest = withX509CertStorePtr store $ \ store_ptr -> do + asBytesLen digest $ \ digest_ptr _ -> do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_find_cert_by_raw_subject_dn_sha256 + outPtr + store_ptr + digest_ptr + out <- peek outPtr + if out == nullPtr + then return Nothing + else do + foreignPtr <- newForeignPtr botan_x509_cert_destroy out + return $ Just $ MkX509Cert foreignPtr + +-- TODO: Use mkInitMaybe +x509CertStoreFindCRLFor :: X509CertStore -> X509Cert -> IO (Maybe X509CRL) +x509CertStoreFindCRLFor store cert = withX509CertStorePtr store $ \ store_ptr -> do + withX509Cert cert $ \ cert_ptr -> do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_find_crl_for + outPtr + store_ptr + cert_ptr + out <- peek outPtr + if out == nullPtr + then return Nothing + else do + foreignPtr <- newForeignPtr botan_x509_crl_destroy out + return $ Just $ MkX509CRL foreignPtr + +x509CertStoreCertificateKnown :: X509CertStore -> X509Cert -> IO Bool +x509CertStoreCertificateKnown store cert = withX509CertStorePtr store $ \ store_ptr -> do + withX509Cert cert $ \ cert_ptr -> do + throwBotanCatchingSuccess $ botan_x509_cert_store_certificate_known store_ptr cert_ptr + +-- {- +-- In-memory cert store +-- -} + +-- TODO: Get rid of bytestring paths +x509CertStoreInMemoryLoadDir :: ByteString -> IO X509CertStore +x509CertStoreInMemoryLoadDir path = asCString path $ \ path_ptr -> mkInit + MkX509CertStore + (\ ptr -> botan_x509_cert_store_in_memory_load_dir + ptr + path_ptr + ) + botan_x509_cert_store_destroy + +x509CertStoreInMemoryLoadCert :: X509Cert -> IO X509CertStore +x509CertStoreInMemoryLoadCert cert = withX509Cert cert $ \ cert_ptr -> mkInit + MkX509CertStore + (\ ptr -> botan_x509_cert_store_in_memory_load_cert + ptr + cert_ptr + ) + botan_x509_cert_store_destroy + +x509CertStoreInMemoryCreate :: IO X509CertStore +x509CertStoreInMemoryCreate = mkInit + MkX509CertStore + botan_x509_cert_store_in_memory_create + botan_x509_cert_store_destroy + +x509CertStoreInMemoryAddCertificate :: X509CertStore -> X509Cert -> IO () +x509CertStoreInMemoryAddCertificate store cert = withX509CertStorePtr store $ \ store_ptr -> do + withX509Cert cert $ \ cert_ptr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_in_memory_add_certificate + store_ptr + cert_ptr + +x509CertStoreInMemoryAddCRL :: X509CertStore -> X509CRL -> IO () +x509CertStoreInMemoryAddCRL store crl = withX509CertStorePtr store $ \ store_ptr -> do + withX509CRL crl $ \ crl_ptr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_in_memory_add_crl + store_ptr + crl_ptr + +-- {- +-- Flatfile cert store +-- -} + +x509CertStoreFlatfileCreate :: ByteString -> Bool -> IO X509CertStore +x509CertStoreFlatfileCreate path ignore_non_ca = asCString path $ \ path_ptr -> mkInit + MkX509CertStore + (\ ptr -> botan_x509_cert_store_flatfile_create + ptr + path_ptr + (fromBool ignore_non_ca) + ) + botan_x509_cert_store_destroy + +{- +SQL cert store +-} + +x509CertStoreSQLInsertCert :: X509CertStore -> X509Cert -> IO Bool +x509CertStoreSQLInsertCert store cert = withX509CertStorePtr store $ \ store_ptr -> do + withX509Cert cert $ \ cert_ptr -> do + throwBotanCatchingSuccess $ botan_x509_cert_store_sql_insert_cert + store_ptr + cert_ptr + +x509CertStoreSQLRemoveCert :: X509CertStore -> X509Cert -> IO Bool +x509CertStoreSQLRemoveCert store cert = withX509CertStorePtr store $ \ store_ptr -> do + withX509Cert cert $ \ cert_ptr -> do + throwBotanCatchingSuccess $ botan_x509_cert_store_sql_remove_cert + store_ptr + cert_ptr + +-- TODO: Use mkInitMaybe +x509CertStoreSQLFindKey :: X509CertStore -> X509Cert -> IO (Maybe PrivKey) +x509CertStoreSQLFindKey store cert = withX509CertStorePtr store $ \ store_ptr -> do + withX509Cert cert $ \ cert_ptr -> do + alloca $ \ outPtr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_sql_find_key + outPtr + store_ptr + cert_ptr + out <- peek outPtr + if out == nullPtr + then return Nothing + else do + foreignPtr <- newForeignPtr botan_privkey_destroy out + return $ Just $ MkPrivKey foreignPtr + +-- NOTE: See notes about returning arrays of things, improper return pointer type +-- TODO: Need some sort of allocArrayQuerying, or a mkArrayInit +x509CertStoreSQLFindCertsForKey :: X509CertStore -> PrivKey -> IO [X509Cert] +x509CertStoreSQLFindCertsForKey store privkey = withX509CertStorePtr store $ \ store_ptr -> do + withPrivKey privkey $ \ privkey_ptr -> do + let fn arrPtr szPtr = botan_x509_cert_store_sql_find_certs_for_key arrPtr szPtr store_ptr privkey_ptr + alloca $ \ szPtr -> do + code <- fn nullPtr szPtr + case code of + InsufficientBufferSpace -> do + sz <- fromIntegral <$> peek szPtr + allocaArray sz $ \ arrPtr -> do + throwBotanIfNegative_ $ fn arrPtr szPtr + certPtrs <- peekArray sz arrPtr + -- NOTE: Cannot use mkInit because that performs an alloca and a peek, + -- whereas we have already performed that work here + forM certPtrs $ \ certPtr -> do + foreignPtr <- newForeignPtr botan_x509_cert_destroy certPtr + return $ MkX509Cert foreignPtr + _ -> throwBotanError code + +x509CertStoreSQLInsertKey :: X509CertStore -> X509Cert -> PrivKey -> IO Bool +x509CertStoreSQLInsertKey store cert privkey = withX509CertStorePtr store $ \ store_ptr -> do + withX509Cert cert $ \ cert_ptr -> do + withPrivKey privkey $ \ privkey_ptr -> do + throwBotanCatchingSuccess $ botan_x509_cert_store_sql_insert_key + store_ptr + cert_ptr + privkey_ptr + +x509CertStoreSQLRemoveKey :: X509CertStore -> PrivKey -> IO () +x509CertStoreSQLRemoveKey store privkey = withX509CertStorePtr store $ \ store_ptr -> do + withPrivKey privkey $ \ privkey_ptr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_sql_remove_key + store_ptr + privkey_ptr + +x509CertStoreSQLRevokeCert :: X509CertStore -> X509Cert -> Word32 -> Word64 -> IO () +x509CertStoreSQLRevokeCert store cert crl_code time = withX509CertStorePtr store $ \ store_ptr -> do + withX509Cert cert $ \ cert_ptr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_sql_revoke_cert + store_ptr + cert_ptr + crl_code + time + +x509CertStoreSQLAffirmCert :: X509CertStore -> X509Cert -> IO () +x509CertStoreSQLAffirmCert store cert = withX509CertStorePtr store $ \ store_ptr -> do + withX509Cert cert $ \ cert_ptr -> do + throwBotanIfNegative_ $ botan_x509_cert_store_sql_affirm_cert + store_ptr + cert_ptr + +-- -- NOTE: See notes about returning arrays of things, improper return pointer type +-- TODO: Need some sort of allocArrayQuerying, or a mkArrayInit +x509CertStoreSQLGenerateCRLs :: X509CertStore -> IO [X509CRL] +x509CertStoreSQLGenerateCRLs store = withX509CertStorePtr store $ \ store_ptr -> do + let fn arrPtr szPtr = botan_x509_cert_store_sql_generate_crls arrPtr szPtr store_ptr + alloca $ \ szPtr -> do + code <- fn nullPtr szPtr + case code of + InsufficientBufferSpace -> do + sz <- fromIntegral <$> peek szPtr + allocaArray sz $ \ arrPtr -> do + throwBotanIfNegative_ $ fn arrPtr szPtr + crlPtrs <- peekArray sz arrPtr + -- NOTE: Cannot use mkInit because that performs an alloca and a peek, + -- whereas we have already performed that work here + forM crlPtrs $ \ crlPtr -> do + foreignPtr <- newForeignPtr botan_x509_crl_destroy crlPtr + return $ MkX509CRL foreignPtr + _ -> throwBotanError code + +{- +SQLite3 cert store +NOTE: Not confirmed to be implemented correctly C++-side +-} + +x509CertStoreSqlite3Create :: ByteString -> ByteString -> RNG -> ByteString -> IO X509CertStore +x509CertStoreSqlite3Create db_path passwd rng table_prefix = asCString db_path $ \ db_path_ptr -> do + asCString passwd $ \ passwd_ptr -> do + withRNG rng $ \ botanRNG -> do + asCString table_prefix $ \ table_prefix_ptr -> mkInit + MkX509CertStore + (\ ptr -> botan_x509_cert_store_sqlite3_create + ptr + db_path_ptr + passwd_ptr botanRNG + table_prefix_ptr + ) + botan_x509_cert_store_destroy + +{- +System cert store +-} + +x509CertStoreSystemCreate :: IO X509CertStore +x509CertStoreSystemCreate = mkInit MkX509CertStore botan_x509_cert_store_system_create botan_x509_cert_store_destroy + +{- +MacOS cert store +NOTE: OS-specific, covered by System certificate store type? +-} + +-- foreign import ccall unsafe botan_x509_cert_store_macos_create +-- :: Ptr X509CertStorePtr +-- -> IO BotanErrorCode + +{- +Windows cert store +NOTE: OS-specific, covered by System certificate store type? +-} + +-- foreign import ccall unsafe botan_x509_cert_store_windows_create +-- :: Ptr X509CertStorePtr +-- -> IO BotanErrorCode diff --git a/src/Botan/Low/ZFEC.hs b/src/Botan/Low/ZFEC.hs new file mode 100644 --- /dev/null +++ b/src/Botan/Low/ZFEC.hs @@ -0,0 +1,187 @@ +{-| +Module : Botan.Low.ZFEC +Description : ZFEC Forward Error Correction +Copyright : (c) Leo D, 2023 +License : BSD-3-Clause +Maintainer : leo@apotheca.io +Stability : experimental +Portability : POSIX + +Forward error correction takes an input and creates multiple +“shares”, such that any K of N shares is sufficient to recover +the entire original input. + +-} + +module Botan.Low.ZFEC +( + +-- * Forward Error Correction +-- $introduction +-- * Usage +-- $usage + +-- * ZFEC + ZFECShare(..) +, zfecEncode +, zfecDecode + +) where + +import Control.Concurrent + +import Data.Foldable + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Unsafe as ByteString + +import Botan.Bindings.ZFEC + +import Botan.Low.Error +import Botan.Low.Make +import Botan.Low.Prelude + +{- $introduction + +The ZFEC module provides forward error correction compatible +with the zfec library. + +Note + +Specific to the ZFEC format, the first K generated shares are +identical to the original input data, followed by N-K shares of +error correcting code. This is very different from threshold +secret sharing, where having fewer than K shares gives no +information about the original input. + +Warning + +If a corrupted share is provided to the decoding algorithm, the +resulting decoding will be invalid. It is recommended to protect +shares using a technique such as a MAC or public key signature, +if corruption is likely in your application. + +-} + +{- $usage + +Forward error correction takes an input and creates multiple +“shares”, such that any K of N shares is sufficient to recover +the entire original input. + +First, we choose a K value appropriate to our message - the higher K is, +the smaller (but more numerous) the resulting shares will be: + +> k = 7 +> message = "The length of this message must be divisible by K" + +> NOTE: ZFEC requires that the input length be exactly divisible by K; if +needed define a padding scheme to pad your input to the necessary +size. + +We can calculate N = K + R, where R is the number of redundant shares, +meaning we can tolerate the loss of up to R shares and still recover +the original message. + +We want 2 additional shares of redundancy, so we set R and N appropriately: + +> r = 2 +> n = k + r -- 7 + 2 = 9 + +Then, we encode the message into N shares: + +> shares <- zfecEncode k n message +> length shares +> -- 9 + +Then, we can recover the message from any K of N shares: + +> someShares <- take k <$> shuffle shares +> recoveredMessage <- zfecDecode k n someShares +> message == recoveredMessage +> -- True + +-} + +type ZFECShare = (Int, ByteString) + +-- Or should this be?: +-- zfecEncode :: Int -> Int -> Int -> Input -> IO [ZFECShare] +-- zfecEncode k n shareSz input = ... +-- ^ is more 'raw'. + +-- | Encode some bytes with certain ZFEC parameters. +-- +-- NOTE: The length in bytes of input must be a multiple of K +zfecEncode + :: Int -- ^ __K__: the number of shares needed for recovery + -> Int -- ^ __N__: the number of shares generated + -> ByteString -- ^ __input__: the data to FEC + -> IO [ZFECShare] +zfecEncode k n input = asBytesLen input $ \ inputPtr inputLen -> do + let shareSize = div (fromIntegral inputLen) k + allocaBytes (n * shareSize) $ \ outPtr -> do + allocaArray n $ \ (sharePtrArrayPtr :: Ptr (Ptr Word8)) -> do + let sharePtrs = fmap (advancePtr outPtr . (* shareSize)) [0..(n-1)] + pokeArray sharePtrArrayPtr sharePtrs + throwBotanIfNegative_ $ botan_zfec_encode + (fromIntegral k) + (fromIntegral n) + (ConstPtr inputPtr) + inputLen + sharePtrArrayPtr + shares <- traverse (ByteString.packCStringLen . (,shareSize) . castPtr) sharePtrs + return $!! zip [0..(n-1)] shares + +-- TODO: Throw a fit if shares are not equal length, not k shares + +-- | Decode some previously encoded shares using certain ZFEC parameters. +-- +-- NOTE: There must be at least K shares of equal length +zfecDecode + :: Int -- ^ __K__: the number of shares needed for recovery + -> Int -- ^ __N__: the total number of shares + -> [ZFECShare] -- ^ __inputs__: K previously encoded shares to decode + -> IO ByteString -- ^ __outputs__: An out parameter pointing to a fully allocated array of size + -- [N][size / K]. For all n in range, an encoded block will be + -- written to the memory starting at outputs[n][0]. +zfecDecode _ _ [] = return "" +zfecDecode k n shares@((_,share0):_) = do + allocaArray k $ \ (indexesPtr :: Ptr CSize) -> do + pokeArray indexesPtr shareIndexes + withPtrs unsafeAsBytes shareBytes $ \ (sharePtrs :: [Ptr Word8]) -> do + allocaArray k $ \ (sharePtrArrayPtr :: Ptr (Ptr Word8)) -> do + pokeArray sharePtrArrayPtr sharePtrs + -- NOTE: This extra work may potentially be avoided by allocating a + -- single contiguous block + -- withPtrs (const $ allocaBytes shareSize) [0..(k-1)] $ \ outPtrs -> do + -- allocaArray k $ \ outPtrArrayPtr -> do + -- pokeArray outPtrArrayPtr outPtrs + -- throwBotanIfNegative_ $ botan_zfec_decode + -- (fromIntegral k) + -- (fromIntegral n) + -- indexesPtr + -- sharePtrArrayPtr + -- (fromIntegral shareSize) + -- outPtrArrayPtr + -- decodedShares <- traverse (ByteString.unsafePackCStringLen . (,shareSize) . castPtr) outPtrs + -- return $!! ByteString.copy $ ByteString.concat decodedShares + -- Single contiguous block method + -- This way is probably superior absent any surprise alignment issues + allocBytes (k * shareSize) $ \ outPtr -> do + allocaArray n $ \ (outPtrArrayPtr :: Ptr (Ptr Word8)) -> do + let outPtrs = fmap (advancePtr outPtr . (* shareSize)) [0..(n-1)] + pokeArray outPtrArrayPtr outPtrs + throwBotanIfNegative_ $ botan_zfec_decode + (fromIntegral k) + (fromIntegral n) + (ConstPtr indexesPtr) + -- NOTE: Use of castPtr here because allocating + -- as a ConstPtr (ConstPtr a) is tedious + (ConstPtr $ castPtr sharePtrArrayPtr) + (fromIntegral shareSize) + outPtrArrayPtr + where + shareIndexes = fmap (fromIntegral . fst) shares + shareBytes = fmap snd shares + shareSize = ByteString.length share0 diff --git a/test-data/4096b-rsa-example-cert.der b/test-data/4096b-rsa-example-cert.der new file mode 100644 Binary files /dev/null and b/test-data/4096b-rsa-example-cert.der differ diff --git a/test-data/4096b-rsa-example-cert.pem b/test-data/4096b-rsa-example-cert.pem new file mode 100644 --- /dev/null +++ b/test-data/4096b-rsa-example-cert.pem @@ -0,0 +1,23 @@ +-----BEGIN CERTIFICATE----- +MIID2jCCA0MCAg39MA0GCSqGSIb3DQEBBQUAMIGbMQswCQYDVQQGEwJKUDEOMAwG +A1UECBMFVG9reW8xEDAOBgNVBAcTB0NodW8ta3UxETAPBgNVBAoTCEZyYW5rNERE +MRgwFgYDVQQLEw9XZWJDZXJ0IFN1cHBvcnQxGDAWBgNVBAMTD0ZyYW5rNEREIFdl +YiBDQTEjMCEGCSqGSIb3DQEJARYUc3VwcG9ydEBmcmFuazRkZC5jb20wHhcNMTIw +ODIyMDUyODAwWhcNMTcwODIxMDUyODAwWjBKMQswCQYDVQQGEwJKUDEOMAwGA1UE +CAwFVG9reW8xETAPBgNVBAoMCEZyYW5rNEREMRgwFgYDVQQDDA93d3cuZXhhbXBs +ZS5jb20wggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCwvWITOLeyTbS1 +Q/UacqeILIK16UHLvSymIlbbiT7mpD4SMwB343xpIlXN64fC0Y1ylT6LLeX4St7A +cJrGIV3AMmJcsDsNzgo577LqtNvnOkLH0GojisFEKQiREX6gOgq9tWSqwaENccTE +sAXuV6AQ1ST+G16s00iN92hjX9V/V66snRwTsJ/p4WRpLSdAj4272hiM19qIg9zr +h92e2rQy7E/UShW4gpOrhg2f6fcCBm+aXIga+qxaSLchcDUvPXrpIxTd/OWQ23Qh +vIEzkGbPlBA8J7Nw9KCyaxbYMBFb1i0lBjwKLjmcoihiI7PVthAOu/B71D2hKcFj +Kpfv4D1Uam/0VumKwhwuhZVNjLq1BR1FKRJ1CioLG4wCTr0LVgtvvUyhFrS+3PdU +R0T5HlAQWPMyQDHgCpbOHW0wc0hbuNeO/lS82LjieGNFxKmMBFF9lsN2zsA6Qw32 +Xkb2/EFltXCtpuOwVztdk4MDrnaDXy9zMZuqFHpv5lWTbDVwDdyEQNclYlbAEbDe +vEQo/rAOZFl94Mu63rAgLiPeZN4IdS/48or5KaQaCOe0DuAb4GWNIQ42cYQ5TsEH +Wt+FIOAMSpf9hNPjDeu1uff40DOtsiyGeX9NViqKtttaHpvd7rb2zsasbcAGUl+f +NQJj4qImPSB9ThqZqPTukEcM/NtbeQIDAQABMA0GCSqGSIb3DQEBBQUAA4GBAIAi +gU3My8kYYniDuKEXSJmbVB+K1upHxWDA8R6KMZGXfbe5BRd8s40cY6JBYL52Tgqd +l8z5Ek8dC4NNpfpcZc/teT1WqiO2wnpGHjgMDuDL1mxCZNL422jHpiPWkWp3AuDI +c7tL1QjbfAUHAQYwmHkWgPP+T2wAv0pOt36GgMCM +-----END CERTIFICATE----- diff --git a/test/Botan/Low/BcryptSpec.hs b/test/Botan/Low/BcryptSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/BcryptSpec.hs @@ -0,0 +1,25 @@ +module Main where + +import Test.Prelude + +import Botan.Low.RNG +import Botan.Low.Bcrypt + +password :: ByteString +password = "Fee fi fo fum!" + +factor = 12 + +main :: IO () +main = hspec $ do + describe "bcryptGenerate" $ do + it "generates a bcrypt hash" $ do + rng <- rngInit "user-threadsafe" + _ <- bcryptGenerate password rng factor + pass + describe "bcryptIsValid" $ do + it "validates a bcrypt hash" $ do + rng <- rngInit "user-threadsafe" + h <- bcryptGenerate password rng factor + valid <- bcryptIsValid password h + valid `shouldBe` True diff --git a/test/Botan/Low/BlockCipherSpec.hs b/test/Botan/Low/BlockCipherSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/BlockCipherSpec.hs @@ -0,0 +1,68 @@ +module Main where + +import Test.Prelude + +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString as ByteString + +import Botan.Low.BlockCipher +import Botan.Low.RNG + +message = "Fee fi fo fum! I smell the blood of an Englishman!" + +main :: IO () +main = hspec $ testSuite allBlockCiphers chars $ \ bc -> do + it "can initialize a block cipher context" $ do + ctx <- blockCipherInit bc + pass + it "has a name" $ do + ctx <- blockCipherInit bc + name <- blockCipherName ctx + -- name `shouldBe` bc -- Name expands to include default parameters - need to record + pass + it "has a key spec" $ do + ctx <- blockCipherInit bc + (_,_,_) <- blockCipherGetKeyspec ctx + pass + it "has a block size" $ do + ctx <- blockCipherInit bc + _ <- blockCipherBlockSize ctx + pass + it "can set the key" $ do + ctx <- blockCipherInit bc + (_,mx,_) <- blockCipherGetKeyspec ctx + k <- systemRNGGet mx + blockCipherSetKey ctx k + pass + it "can encipher a message" $ do + ctx <- blockCipherInit bc + (_,mx,_) <- blockCipherGetKeyspec ctx + k <- systemRNGGet mx + blockCipherSetKey ctx k + bsz <- blockCipherBlockSize ctx + msg <- systemRNGGet $ bsz * 10 + encmsg <- blockCipherEncryptBlocks ctx msg + pass + -- NOTE: It does not actually throw an error - this is slightly concerning. + -- it "can only encipher messages that are a multiple of the block size" $ do + -- ctx <- blockCipherInitName bc + -- bsz <- blockCipherBlockSize ctx + -- if bsz == 1 + -- then pass + -- else do + -- (_,mx,_) <- blockCipherGetKeyspec ctx + -- k <- systemRNGGetIO mx + -- blockCipherSetKey ctx k + -- msg <- systemRNGGetIO $ bsz + 1 + -- blockCipherEncryptBlocks ctx msg `shouldThrow` anyBotanException + it "can decipher an enciphered message" $ do + ctx <- blockCipherInit bc + (_,mx,_) <- blockCipherGetKeyspec ctx + k <- systemRNGGet mx + blockCipherSetKey ctx k + bsz <- blockCipherBlockSize ctx + msg <- systemRNGGet $ bsz * 10 + encmsg <- blockCipherEncryptBlocks ctx msg + decmsg <- blockCipherDecryptBlocks ctx encmsg + decmsg `shouldBe` msg + pass diff --git a/test/Botan/Low/CipherSpec.hs b/test/Botan/Low/CipherSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/CipherSpec.hs @@ -0,0 +1,221 @@ +module Main where + +import Test.Prelude + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 + +import Botan.Bindings.Cipher +import Botan.Low.BlockCipher +import Botan.Low.Cipher +import Botan.Low.RNG + +showBytes :: (Show a) => a -> ByteString +showBytes = Char8.pack . show + +main :: IO () +main = hspec $ testSuite (cipherModes ++ aeads) chars $ \ cipher -> do + it "can initialize a cipher encryption context" $ do + ctx <- cipherInit cipher Encrypt + pass + it "can initialize a cipher decryption context" $ do + ctx <- cipherInit cipher Decrypt + pass + it "has a name" $ do + ctx <- cipherInit cipher Encrypt + name <- cipherName ctx + -- name `shouldBe` bc -- Name expands to include default parameters - need to record + pass + it "has a key spec" $ do + ctx <- cipherInit cipher Encrypt + (_,_,_) <- cipherGetKeyspec ctx + pass + it "can set the key" $ do + ctx <- cipherInit cipher Encrypt + (_,mx,_) <- cipherGetKeyspec ctx + k <- systemRNGGet mx + cipherSetKey ctx k + pass + it "has a valid default nonce length" $ do + ctx <- cipherInit cipher Encrypt + nlen <- cipherGetDefaultNonceLength ctx + pass + it "can validate nonce length" $ do + ctx <- cipherInit cipher Encrypt + nlen <- cipherGetDefaultNonceLength ctx + defaultIsValid <- cipherValidNonceLength ctx nlen + defaultIsValid `shouldBe` True + -- NOTE: Some ciphers accept nonces of any length, eg SIV + -- Others allow any length > 0, eg GCM + -- Some have ranges + -- Some have just 'if (length == 0) return false;' eg OCB + -- Search C++ source for 'valid_nonce_length' to find them all + -- zeroIsValid <- cipherValidNonceLength ctx 0 + -- zeroIsValid `shouldBe` False + -- absurdlyLargeIsValid <- cipherValidNonceLength ctx maxBound + -- absurdlyLargeIsValid `shouldBe` False + pass + it "can calculate output length" $ do + ctx <- cipherInit cipher Encrypt + olen <- cipherOutputLength ctx 1024 + pass + -- NOTE: This check should be ae / aead only + it "has a tag length" $ do + ctx <- cipherInit cipher Encrypt + _ <- cipherGetTagLength ctx + pass + it "has an update graularity" $ do + ctx <- cipherInit cipher Encrypt + _ <- cipherGetUpdateGranularity ctx + pass + it "has an ideal update granularity" $ do + ctx <- cipherInit cipher Encrypt + _ <- cipherGetIdealUpdateGranularity ctx + pass + if cipher `elem` aeads + then it "can set the associated data" $ do + ctx <- cipherInit cipher Encrypt + -- NOTE: Undocumented: A cipher must set the key before setting AD + (_,mx,_) <- cipherGetKeyspec ctx + k <- systemRNGGet mx + cipherSetKey ctx k + -- END NOTE + ad <- systemRNGGet 64 + cipherSetAssociatedData ctx ad + pass + else pass + it "can reset all message state" $ do + ctx <- cipherInit cipher Encrypt + cipherReset ctx + pass + it "can clear all internal state" $ do + ctx <- cipherInit cipher Encrypt + cipherClear ctx + pass + it "can start processing a message" $ do + ctx <- cipherInit cipher Encrypt + (_,mx,_) <- cipherGetKeyspec ctx + k <- systemRNGGet mx + cipherSetKey ctx k + if cipher `elem` aeads + then do + ad <- systemRNGGet 64 + cipherSetAssociatedData ctx ad + else pass + n <- systemRNGGet =<< cipherGetDefaultNonceLength ctx + cipherStart ctx n + pass + -- TODO: More extensive testing in Botan; these are just binding sanity checks + it "can one-shot / offline encipher a message" $ do + ctx <- cipherInit cipher Encrypt + (_,mx,_) <- cipherGetKeyspec ctx + k <- systemRNGGet mx + cipherSetKey ctx k + if cipher `elem` aeads + then do + ad <- systemRNGGet 64 + cipherSetAssociatedData ctx ad + else pass + n <- systemRNGGet =<< cipherGetDefaultNonceLength ctx + cipherStart ctx n + g <- cipherGetIdealUpdateGranularity ctx + msg <- systemRNGGet g + encmsg <- cipherEncrypt ctx msg + pass + it "can one-shot / offline decipher a message" $ do + -- Same as prior test + ctx <- cipherInit cipher Encrypt + (_,mx,_) <- cipherGetKeyspec ctx + k <- systemRNGGet mx + cipherSetKey ctx k + ad <- systemRNGGet 64 + if cipher `elem` aeads + then do + cipherSetAssociatedData ctx ad + else pass + n <- systemRNGGet =<< cipherGetDefaultNonceLength ctx + cipherStart ctx n + g <- cipherGetIdealUpdateGranularity ctx + msg <- systemRNGGet g + encmsg <- cipherEncrypt ctx msg + -- Start actual test + dctx <- cipherInit cipher Decrypt + cipherSetKey dctx k + if cipher `elem` aeads + then do + cipherSetAssociatedData dctx ad + else pass + cipherStart dctx n + decmsg <- cipherDecrypt dctx encmsg + msg `shouldBe` decmsg + pass + it "can incrementally / online encipher a message" $ do + -- Same as prior test + ctx <- cipherInit cipher Encrypt + (_,mx,_) <- cipherGetKeyspec ctx + k <- systemRNGGet mx + cipherSetKey ctx k + ad <- systemRNGGet 64 + if cipher `elem` aeads + then do + cipherSetAssociatedData ctx ad + else pass + n <- systemRNGGet =<< cipherGetDefaultNonceLength ctx + cipherStart ctx n + g <- cipherGetIdealUpdateGranularity ctx + msg <- systemRNGGet (8 * g) + encmsg <- cipherEncryptOnline ctx msg + pass + -- NOTE: Fails for SIV, CCM because they are offline-only algorithms + -- This is expected, but not reflected in the tests yet + it "can incrementally / online decipher a message" $ do + ctx <- cipherInit cipher Encrypt + (_,mx,_) <- cipherGetKeyspec ctx + k <- systemRNGGet mx + cipherSetKey ctx k + ad <- systemRNGGet 64 + if cipher `elem` aeads + then do + cipherSetAssociatedData ctx ad + else pass + n <- systemRNGGet =<< cipherGetDefaultNonceLength ctx + cipherStart ctx n + g <- cipherGetIdealUpdateGranularity ctx + msg <- systemRNGGet (8 * g) + encmsg <- cipherEncryptOnline ctx msg + -- Start actual test + dctx <- cipherInit cipher Decrypt + cipherSetKey dctx k + if cipher `elem` aeads + then do + cipherSetAssociatedData dctx ad + else pass + cipherStart dctx n + decmsg <- cipherDecryptOnline dctx encmsg + msg `shouldBe` decmsg + pass + -- NOTE: Fails for SIV, CCM because they are offline-only algorithms + -- This is expected, but not reflected in the tests yet + it "has parity between online and offline" $ do + onlinectx <- cipherInit cipher Encrypt + offlinectx <- cipherInit cipher Encrypt + (_,mx,_) <- cipherGetKeyspec onlinectx + k <- systemRNGGet mx + cipherSetKey onlinectx k + cipherSetKey offlinectx k + ad <- systemRNGGet 64 + when (cipher `elem` aeads) $ do + cipherSetAssociatedData onlinectx ad + cipherSetAssociatedData offlinectx ad + n <- systemRNGGet =<< cipherGetDefaultNonceLength onlinectx + cipherStart onlinectx n + cipherStart offlinectx n + g <- cipherGetIdealUpdateGranularity onlinectx + msg <- systemRNGGet (8 * g) + putStrLn " Testing online encryption:" + onlinemsg <- cipherEncryptOnline onlinectx msg + putStrLn " Testing offline encryption:" + offlinemsg <- cipherEncrypt offlinectx msg + putStrLn " Result:" + onlinemsg `shouldBe` offlinemsg + pass diff --git a/test/Botan/Low/FPESpec.hs b/test/Botan/Low/FPESpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/FPESpec.hs @@ -0,0 +1,97 @@ +module Main where + +import Test.Prelude + +import Botan.Low.FPE +import Botan.Bindings.FPE +import Botan.Low.MPI +import Botan.Low.RNG + +import Botan.Low.Error + +-- NOTE: FPE operations encrypt/decrypt integers less than n +nStr :: ByteString +nStr = "1000000000000" + +key :: ByteString +key = "0000DEADBEEF0000" + +rounds :: Int +rounds = 3 + +newRng :: IO RNG +newRng = rngInit "system" + +newX :: MP -> IO MP +newX n = do + x <- mpInit + z <- mpInit + mpSetFromInt z 0 + -- n <- mpInit + -- mpSetFromStr n nStr + rng <- newRng + mpRandRange x rng z n + return x + +newFE1Ctx :: IO (MP, FPE) +newFE1Ctx = do + n <- mpInit + mpSetFromStr n nStr + ctx <- fpeInitFE1 n key rounds BOTAN_FPE_FLAG_NONE + return (n,ctx) + +newFE1CtxCompatMode :: IO (MP, FPE) +newFE1CtxCompatMode = do + n <- mpInit + mpSetFromStr n nStr + ctx <- fpeInitFE1 n key rounds BOTAN_FPE_FLAG_FE1_COMPAT_MODE + return (n,ctx) + +main :: IO () +main = hspec $ do + describe "fpeInitFE1" $ do + it "initializes an FE1 FPE context" $ do + newFE1Ctx + pass + it "initializes an FE1 FPE context in compat mode" $ (do + newFE1CtxCompatMode + pass + ) -- `shouldThrow` anyBotanException + describe "fpeEncrypt" $ do + it "performs format-preserving encryption" $ do + (n,ctx) <- newFE1Ctx + x <- newX n + y <- mpCopy x + fpeEncrypt ctx y "" + isSame <- mpEqual x y + isSame `shouldBe` False + pass + it "performs format-preserving encryption in compat mode" $ do + (n,ctx) <- newFE1CtxCompatMode + x <- newX n + y <- mpCopy x + fpeEncrypt ctx y "" + isSame <- mpEqual x y + isSame `shouldBe` False + pass + describe "fpeDecrypt" $ do + it "performs format-preserving decryption" $ do + (n,ctx) <- newFE1Ctx + x <- newX n + y <- mpCopy x + fpeEncrypt ctx y "" + z <- mpCopy y + fpeDecrypt ctx z "" + isSame <- mpEqual x z + isSame `shouldBe` True + pass + it "performs format-preserving decryption in compat mode" $ do + (n,ctx) <- newFE1CtxCompatMode + x <- newX n + y <- mpCopy x + fpeEncrypt ctx y "" + z <- mpCopy y + fpeDecrypt ctx z "" + isSame <- mpEqual x z + isSame `shouldBe` True + pass diff --git a/test/Botan/Low/HOTPSpec.hs b/test/Botan/Low/HOTPSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/HOTPSpec.hs @@ -0,0 +1,27 @@ +module Main where + +import Test.Prelude +import Botan.Low.Hash (HashName(..)) + +import Botan.Low.HOTP + +key :: ByteString +key = "Fee fi fo fum" + +counter :: HOTPCounter +counter = 12345 + +main :: IO () +main = hspec $ testSuite hotpHashes chars $ \ h -> do + it "hotpInit" $ do + ctx <- hotpInit key h 6 + pass + it "hotpGenerate" $ do + ctx <- hotpInit key h 6 + code <- hotpGenerate ctx counter + pass + it "hotpCheck" $ do + ctx <- hotpInit key h 6 + code <- hotpGenerate ctx counter + (success,next) <- hotpCheck ctx code counter 0 + success `shouldBe` True diff --git a/test/Botan/Low/HashSpec.hs b/test/Botan/Low/HashSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/HashSpec.hs @@ -0,0 +1,48 @@ +module Main where + +import Test.Prelude + +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString as ByteString + +import Botan.Bindings.Hash +import Botan.Low.Hash + +message = "Fee fi fo fum! I smell the blood of an Englishman!" + +main :: IO () +main = hspec $ testSuite allHashes chars $ \ h -> do + it "can initialize a hash context" $ do + ctx <- hashInit h + pass + it "has a name" $ do + ctx <- hashInit h + name <- hashName ctx + pass + it "has an output length" $ do + ctx <- hashInit h + olen <- hashOutputLength ctx + pass + it "can copy the internal state" $ do + ctx <- hashInit h + -- TODO: Populate with state and actually prove + ctx' <- hashCopyState ctx + pass + it "can clear all internal state" $ do + ctx <- hashInit h + -- TODO: Populate with state and actually prove + hashClear ctx + pass + it "can update the internal state with a single message block" $ do + ctx <- hashInit h + hashUpdate ctx message + pass + it "can update the internal state with multiple message blocks" $ do + ctx <- hashInit h + forM_ (splitBlocks 4 message) $ hashUpdate ctx + pass + it "can finalize a digest" $ do + ctx <- hashInit h + hashUpdate ctx message + d <- hashFinal ctx + pass diff --git a/test/Botan/Low/KDFSpec.hs b/test/Botan/Low/KDFSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/KDFSpec.hs @@ -0,0 +1,34 @@ +module Main where + +import Test.Prelude + +import qualified Data.ByteString as ByteString + +-- import Botan.Low.Hash +import Botan.Low.KDF + +-- NOTE: Many of these tests fail because different kdfs / macs / hashes have different requirements +-- such as input or output lengths. +-- Failing tests: +-- - Checksums: Adler32, CRC24, CRC32, BadParameterException for almost everything +-- - Probably because they are not cryptographic hashes +-- - All fail for HKDF, SP800-108-*(HMAC(hash)), SP800-56A(hash), SP800-56A(HMAC(hash)), SP800-56C(hash), SP800-56C(HMAC(hash)) +-- - CRC24 fails for KDF1, probably because we asked for 4 bits +-- - HKDF-Extract - BadParameterException for unknown reasons +-- - X9.42-PRF: About half fail with NotImplementedException +-- - SP800-108-*: Requires HMAC wrapping, may support other MACs? +-- - SP800-56A / SP800-56C: Allow HMAC wrapping, may support other MACs? +-- Many do accept HMAC(hash) as an argument instead of just hash +-- It is not yet known which if any MACs work aside from HMAC (eg whether anything with CMAC, GMAC does) due to non-exhaustive +-- enumeration of MACs in their own tests. +-- SP800 KDFs fail with InvalidKeyLengthException for X9.19-MAC, Poly1305, SipHash(2,4) +-- except for SP800-56A which fails with NotImplementedException +-- TODO: Exhaustive algorithm testing (see Botan.KDF notes) + +-- NOTE: Some kdfs (HKDF-Extract) do not support label input arguments +main :: IO () +main = hspec $ testSuite kdfs chars $ \ algo -> do + describe "kdf" $ do + it "can derive a key" $ do + key <- kdf algo 3 "secret" "salt" "" -- "label" + pass diff --git a/test/Botan/Low/KeyWrapSpec.hs b/test/Botan/Low/KeyWrapSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/KeyWrapSpec.hs @@ -0,0 +1,42 @@ +module Main where + +import Test.Prelude + +import Botan.Low.BlockCipher + +import Botan.Low.RNG + +import Botan.Low.KeyWrap + +kwKey :: ByteString +kwKey = "This key *must* be a multiple of 8 bytes" + +kwpKey :: ByteString +kwpKey = "Fee fi fo fum! I smell the blood of an Englishman!" + +main :: IO () +main = hspec $ testSuite blockCipher128s chars $ \ algo -> do + it "nistKeyWrapEncode" $ do + (_,keklen,_) <- blockCipherGetKeyspec =<< blockCipherInit algo + kek <- systemRNGGet keklen + wrappedKey <- nistKeyWrapEncode algo 0 kwKey kek + pass + it "nistKeyWrapDecode" $ do + (_,keklen,_) <- blockCipherGetKeyspec =<< blockCipherInit algo + kek <- systemRNGGet keklen + wrappedKey <- nistKeyWrapEncode algo 0 kwKey kek + unwrappedKey <- nistKeyWrapDecode algo 0 wrappedKey kek + unwrappedKey `shouldBe` kwKey + pass + it "nistKeyWrapEncode padded" $ do + (_,keklen,_) <- blockCipherGetKeyspec =<< blockCipherInit algo + kek <- systemRNGGet keklen + wrappedKey <- nistKeyWrapEncode algo 1 kwpKey kek + pass + it "nistKeyWrapDecode padded" $ do + (_,keklen,_) <- blockCipherGetKeyspec =<< blockCipherInit algo + kek <- systemRNGGet keklen + wrappedKey <- nistKeyWrapEncode algo 1 kwpKey kek + unwrappedKey <- nistKeyWrapDecode algo 1 wrappedKey kek + unwrappedKey `shouldBe` kwpKey + pass diff --git a/test/Botan/Low/MACSpec.hs b/test/Botan/Low/MACSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/MACSpec.hs @@ -0,0 +1,132 @@ +module Main where + +import Test.Prelude + +import Botan.Bindings.MAC +import Botan.Low.MAC + +import Botan.Low.RNG + +-- NOTE: Full testing of all algorithms will require botan ADT types instead +-- of names, to be able to query for acceptable key and nonce parameters + +-- nonceMACs :: [(MACName, Maybe Int)] +-- nonceMACs = concat +-- [ [ "CMAC(" <> bc <> ")" | bc <- allBlockCiphers ] +-- , [ "GMAC(" <> bc <> ")" | bc <- allBlockCiphers ] +-- , [ "CBC-MAC(" <> bc <> ")" | bc <- allBlockCiphers ] +-- ] + +-- macs :: [(MACName, Maybe Int)] +-- macs = concat +-- [ nonceMACs +-- , [ "HMAC(" <> h <> ")" | h <- hashes ] +-- , [ "Poly1305", "SipHash(2,4)", "X9.19-MAC" ] +-- ] + +macs :: [MACName] +macs = fmap fst macsAndNonceSzs + +macsAndNonceSzs :: [(MACName, Int)] +macsAndNonceSzs = + [ ("CMAC(AES-256)", 0) + , ("GMAC(AES-256)", 16) + -- , ("CBC-MAC(AES-256)", 16) -- Not supported + , ("HMAC(SHA-3)", 0) + , ("Poly1305", 0) + , ("SipHash(2,4)", 0) + , ("X9.19-MAC", 0) + ] + +message :: ByteString +message = "Fee fi fo fum! I smell the blood of an Englishman!" + +main :: IO () +main = hspec $ testSuite macsAndNonceSzs (chars . fst) $ \ (h,nonceSz) -> do + it "can initialize a mac context" $ do + ctx <- macInit h + pass + it "has a name" $ do + ctx <- macInit h + name <- macName ctx + pass + it "has an output length" $ do + ctx <- macInit h + olen <- macOutputLength ctx + pass + -- it "can copy the internal state" $ do + -- ctx <- macInit h + -- -- TODO: Populate with state and actually prove + -- ctx' <- macCopyState ctx + -- pass + it "has a key spec" $ do + ctx <- macInit h + (_,_,_) <- macGetKeyspec ctx + pass + it "can set the key" $ do + ctx <- macInit h + (_,mx,_) <- macGetKeyspec ctx + k <- systemRNGGet mx + macSetKey ctx k + pass + -- it "has a nonce spec" $ do + it "can set the nonce" $ do + if nonceSz > 0 + then do + ctx <- macInit h + (_,mx,_) <- macGetKeyspec ctx + k <- systemRNGGet mx + macSetKey ctx k + n <- systemRNGGet nonceSz + macSetNonce ctx n + else pass + it "can clear all internal state" $ do + ctx <- macInit h + (_,mx,_) <- macGetKeyspec ctx + k <- systemRNGGet mx + macSetKey ctx k + if nonceSz > 0 + then do + n <- systemRNGGet nonceSz + macSetNonce ctx n + else pass + -- TODO: Populate with state and actually prove + macClear ctx + pass + it "can update the internal state with a single message block" $ do + ctx <- macInit h + (_,mx,_) <- macGetKeyspec ctx + k <- systemRNGGet mx + macSetKey ctx k + if nonceSz > 0 + then do + n <- systemRNGGet nonceSz + macSetNonce ctx n + else pass + macUpdate ctx message + pass + it "can update the internal state with multiple message blocks" $ do + ctx <- macInit h + (_,mx,_) <- macGetKeyspec ctx + k <- systemRNGGet mx + macSetKey ctx k + if nonceSz > 0 + then do + n <- systemRNGGet nonceSz + macSetNonce ctx n + else pass + forM_ (splitBlocks 4 message) $ macUpdate ctx + pass + it "can finalize a digest" $ do + ctx <- macInit h + (_,mx,_) <- macGetKeyspec ctx + k <- systemRNGGet mx + macSetKey ctx k + if nonceSz > 0 + then do + n <- systemRNGGet nonceSz + macSetNonce ctx n + else pass + macUpdate ctx message + d <- macFinal ctx + pass diff --git a/test/Botan/Low/MPISpec.hs b/test/Botan/Low/MPISpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/MPISpec.hs @@ -0,0 +1,380 @@ +module Main where + +import Test.Prelude + +import Botan.Low.MPI +import Botan.Low.RNG + +-- NOTE: These unit tests are mostly checking that the functions are bound correctly. +-- These are kind of crappy and repetative, but that also exposes what needs to be done +-- in the higher libraries to make things ergonomic. + +main :: IO () +main = hspec $ do + it "can initialize a mutable MPI reference" $ do + mp <- mpInit + pass + it "can set the value from an int" $ do + mp <- mpInit + mpSetFromInt mp 512 + pass + it "can set the value from another reference" $ do + mp <- mpInit + mpSetFromInt mp 512 + mp' <- mpInit + mpSetFromMP mp' mp + isEqual <- mpEqual mp mp' + isEqual `shouldBe` True + pass + it "can be converted to a hex string" $ do + mp <- mpInit + mpSetFromInt mp 512 + hex <- mpToHex mp + hex `shouldBe` "0x0200" + hex' <- mpToStr mp 16 + hex' `shouldBe` "0x0200" + pass + it "can be converted to a decimal string" $ do + mp <- mpInit + mpSetFromInt mp 512 + dec <- mpToStr mp 10 + dec `shouldBe` "512" + pass + it "can be cleared to zero" $ do + mp <- mpInit + mpSetFromInt mp 512 + mpClear mp + zero <- mpInit + mpSetFromInt zero 0 + isClear <- mpEqual mp zero + isClear `shouldBe` True + pass + it "can copy the value to a new reference" $ do + mp <- mpInit + mpSetFromInt mp 512 + mp' <- mpCopy mp + isEqual <- mpEqual mp mp' + isEqual `shouldBe` True + pass + it "can set the value from a decimal string" $ do + mp <- mpInit + mpSetFromStr mp "512" + mp' <- mpInit + mpSetFromInt mp' 512 + isEqualStr <- mpEqual mp mp' + isEqualStr `shouldBe` True + mpSetFromRadixStr mp "512" 10 + isEqualRadixStr <- mpEqual mp mp' + isEqualRadixStr `shouldBe` True + pass + it "can set the value from a hex string" $ do + mp <- mpInit + mpSetFromStr mp "0x0200" + mp' <- mpInit + mpSetFromInt mp' 512 + isEqualStr <- mpEqual mp mp' + isEqualStr `shouldBe` True + mpSetFromRadixStr mp "0200" 16 -- NOTE: Lack of "0x" prefix + isEqualRadixStr <- mpEqual mp mp' + isEqualRadixStr `shouldBe` True + pass + it "has a number of bits" $ do + mp <- mpInit + mpSetFromStr mp "512" + n <- mpNumBits mp + n `shouldBe` 10 + pass + it "has a number of bytes" $ do + mp <- mpInit + mpSetFromStr mp "512" + n <- mpNumBytes mp + n `shouldBe` 2 + pass + it "can be converted to a bytestring" $ do + mp <- mpInit + mpSetFromInt mp 512 + bin <- mpToBin mp + bin `shouldBe` "\STX\NUL" -- NOTE: 0b 0000 0010 0000 0000 + pass + it "can set the value from a bytestring" $ do + mp <- mpInit + mpFromBin mp "\STX\NUL" + mp' <- mpInit + mpSetFromInt mp' 512 + isEqual <- mpEqual mp mp' + isEqual `shouldBe` True + pass + it "can be converted to a 32-bit word" $ do + mp <- mpInit + mpSetFromInt mp 512 + w <- mpToWord32 mp + w `shouldBe` 512 + pass + -- NOTE: Returns whether x >= 0, not x > 0 because 0 is treated as positive. + it "can check if a value is positive" $ do + n <- mpInit + mpSetFromInt n (-512) + nIsPositive <- mpIsPositive n + nIsPositive `shouldBe` False + z <- mpInit + mpSetFromInt z 0 + zIsPositive <- mpIsPositive z + zIsPositive `shouldBe` True + p <- mpInit + mpSetFromInt p 512 + pIsPositive <- mpIsPositive p + pIsPositive `shouldBe` True + pass + it "can check if a value is negative" $ do + n <- mpInit + mpSetFromInt n (-512) + nIsPositive <- mpIsNegative n + nIsPositive `shouldBe` True + z <- mpInit + mpSetFromInt z 0 + zIsPositive <- mpIsNegative z + zIsPositive `shouldBe` False + p <- mpInit + mpSetFromInt p 512 + pIsPositive <- mpIsNegative p + pIsPositive `shouldBe` False + pass + it "can flip the sign of a value" $ do + p <- mpInit + mpSetFromInt p 512 + n <- mpInit + mpSetFromInt n (-512) + mpFlipSign p + isEqual <- mpEqual p n + pass + it "can check whether a value is zero" $ do + mp <- mpInit + mpSetFromInt mp 512 + isZeroA <- mpIsZero mp + isZeroA `shouldBe` False + mpSetFromInt mp 0 + isZeroB <- mpIsZero mp + isZeroB `shouldBe` True + mpSetFromInt mp (-512) + isZeroC <- mpIsZero mp + isZeroC `shouldBe` False + pass + it "can add a 32-bit word to the value and store the result" $ do + mp <- mpInit + mpSetFromInt mp 512 + mp' <- mpInit + mpAddWord32 mp' mp 512 + result <- mpToWord32 mp' + result `shouldBe` 1024 + pass + it "can subtract a 32-bit word from the value and store the result" $ do + mp <- mpInit + mpSetFromInt mp 512 + mp' <- mpInit + mpSubWord32 mp' mp 512 + result <- mpToWord32 mp' + result `shouldBe` 0 + pass + it "can add one value to another and store the result" $ do + a <- mpInit + mpSetFromInt a 512 + b <- mpInit + mpSetFromInt b 512 + c <- mpInit + mpAdd c a b + result <- mpToWord32 c + result `shouldBe` 1024 + pass + it "can subtract one value from another and store the result" $ do + a <- mpInit + mpSetFromInt a 512 + b <- mpInit + mpSetFromInt b 512 + c <- mpInit + mpSub c a b + result <- mpToWord32 c + result `shouldBe` 0 + pass + it "can multiply one value by another and store the result" $ do + a <- mpInit + mpSetFromInt a 512 + b <- mpInit + mpSetFromInt b 512 + c <- mpInit + mpMul c a b + result <- mpToWord32 c + result `shouldBe` 262144 + pass + it "can divide one value by another and store the result" $ do + a <- mpInit + mpSetFromInt a 512 + b <- mpInit + mpSetFromInt b 512 + q <- mpInit + r <- mpInit + mpDiv q r a b + quotient <- mpToWord32 q + quotient `shouldBe` 1 + remainder <- mpToWord32 r + remainder `shouldBe` 0 + pass + it "can perform multiplication and modulus at the same time and store the result" $ do + r <- mpInit + x <- mpInit + mpSetFromInt x 2 + y <- mpInit + mpSetFromInt y 4 + mod <- mpInit + mpSetFromInt mod 7 + mpModMul r x y mod + result <- mpToWord32 r + result `shouldBe` 1 + pass + it "can check whether two values are equal" $ do + a <- mpInit + mpSetFromInt a 512 + b <- mpInit + mpSetFromInt b 512 + c <- mpInit + mpSetFromInt c 256 + abEqual <- mpEqual a b + abEqual `shouldBe` True + bcEqual <- mpEqual b c + bcEqual `shouldBe` False + pass + it "can compare two values for order" $ do + n <- mpInit + mpSetFromInt n (-1) + z <- mpInit + mpSetFromInt z 0 + p <- mpInit + mpSetFromInt p 1 + nz <- mpCmp n z + nz `shouldBe` -1 + zp <- mpCmp z p + zp `shouldBe` -1 + np <- mpCmp n p + np `shouldBe` -1 + nn <- mpCmp n n + nn `shouldBe` 0 + zz <- mpCmp z z + zz `shouldBe` 0 + pp <- mpCmp p p + pp `shouldBe` 0 + pz <- mpCmp p z + pz `shouldBe` 1 + zn <- mpCmp z n + zn `shouldBe` 1 + pn <- mpCmp p n + pn `shouldBe` 1 + pass + it "can swap the values of two references" $ do + a <- mpInit + mpSetFromInt a 512 + b <- mpInit + mpSetFromInt b 256 + mpSwap a b + a' <- mpToWord32 a + a' `shouldBe` 256 + b' <- mpToWord32 b + b' `shouldBe` 512 + pass + it "can perform exponentiation and modulus at the same time and store the result" $ do + r <- mpInit + x <- mpInit + mpSetFromInt x 2 + y <- mpInit + mpSetFromInt y 4 + mod <- mpInit + mpSetFromInt mod 7 + mpPowMod r x y mod + result <- mpToWord32 r + result `shouldBe` 2 + pass + it "can perform a left shift and store the result" $ do + mp <- mpInit + result <- mpInit + mpSetFromInt mp 512 + mpLeftShift result mp 3 + r <- mpToWord32 result + r `shouldBe` 4096 + pass + it "can perform a right shift and store the result" $ do + mp <- mpInit + result <- mpInit + mpSetFromInt mp 512 + mpRightShift result mp 3 + r <- mpToWord32 result + r `shouldBe` 64 + pass + it "can compute the modular inverse" $ do + r <- mpInit + x <- mpInit + mpSetFromInt x 512 + mod <- mpInit + mpSetFromInt mod 29 + mpModInverse r x mod + -- TODO: Actually check more than just being bound + pass + it "can generate a number of random bits" $ do + mp <- mpInit + rng <- rngInit "system" + mpRandBits mp rng 9 + r <- mpToWord32 mp + 0 <= r && r < 512 `shouldBe` True + pass + it "can generate a random value within a range [lower,upper)" $ do + result <- mpInit + rng <- rngInit "system" + lower <- mpInit + mpSetFromInt lower 4 + upper <- mpInit + mpSetFromInt upper 8 + mpRandRange result rng lower upper + isGTELower <- (<= 0) <$> mpCmp lower result + isGTELower `shouldBe` True + isLTUpper <- (== -1) <$> mpCmp result upper + isLTUpper `shouldBe` True + pass + it "can calculate the greatest common divisor of a value" $ do + r <- mpInit + x <- mpInit + mpSetFromInt x 35 + y <- mpInit + mpSetFromInt y 21 + mpGCD r x y + result <- mpToWord32 r + result `shouldBe` 7 + pass + it "can probabilistically calculate whether a value is prime" $ do + mp <- mpInit + rng <- rngInit "system" + mpSetFromInt mp 131 + isPrime131 <- mpIsPrime mp rng 100 + isPrime131 `shouldBe` True + mpSetFromInt mp 133 + isPrime133 <- mpIsPrime mp rng 100 + isPrime133 `shouldBe` False + pass + it "can get the value of a single bit" $ do + mp <- mpInit + mpSetFromInt mp 512 + f <- mpGetBit mp 8 + f `shouldBe` False + t <- mpGetBit mp 9 + t `shouldBe` True + pass + it "can set the value of a single bit (set it to 1)" $ do + mp <- mpInit + mpSetFromInt mp 512 + mpSetBit mp 8 + result <- mpToWord32 mp + result `shouldBe` 768 + pass + it "can clear the value of a single bit (set it to 0)" $ do + mp <- mpInit + mpSetFromInt mp 768 + mpClearBit mp 8 + result <- mpToWord32 mp + result `shouldBe` 512 + pass diff --git a/test/Botan/Low/PubKey/DHSpec.hs b/test/Botan/Low/PubKey/DHSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/DHSpec.hs @@ -0,0 +1,69 @@ +module Main where + +import Test.Prelude + +import Botan.Low.MPI +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.DH + +-- TODO: Consolidate +dlGroups :: [ByteString] +dlGroups = + [ "ffdhe/ietf/2048" + , "ffdhe/ietf/3072" + , "ffdhe/ietf/4096" + , "ffdhe/ietf/6144" + , "ffdhe/ietf/8192" + , "modp/ietf/1024" + , "modp/ietf/1536" + , "modp/ietf/2048" + , "modp/ietf/3072" + , "modp/ietf/4096" + , "modp/ietf/6144" + , "modp/ietf/8192" + , "modp/srp/1024" + , "modp/srp/1536" + , "modp/srp/2048" + , "modp/srp/3072" + , "modp/srp/4096" + , "modp/srp/6144" + , "modp/srp/8192" + , "dsa/jce/1024" + , "dsa/botan/2048" + , "dsa/botan/3072" + ] + +-- TODO: Consolidate +privKeyField :: PrivKey -> ByteString -> IO MP +privKeyField privKey field = do + mp <- mpInit + privKeyGetField mp privKey field + return mp + +-- TODO: Consolidate +pubKeyField :: PubKey -> ByteString -> IO MP +pubKeyField pubKey field = do + mp <- mpInit + pubKeyGetField mp pubKey field + return mp + +main :: IO () +main = hspec $ testSuite dlGroups chars $ \ dlGroup -> do + it "privKeyLoadDH" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "DH" dlGroup rng + p <- privKeyField privKey "p" + g <- privKeyField privKey "g" + x <- privKeyField privKey "x" + loadedKey <- privKeyLoadDH p g x + pass + it "pubKeyLoadDH" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "DH" dlGroup rng + pubKey <- privKeyExportPubKey privKey + p <- pubKeyField pubKey "p" + g <- pubKeyField pubKey "g" + y <- pubKeyField pubKey "y" + loadedKey <- pubKeyLoadDH p g y + pass diff --git a/test/Botan/Low/PubKey/DSASpec.hs b/test/Botan/Low/PubKey/DSASpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/DSASpec.hs @@ -0,0 +1,76 @@ +module Main where + +import Test.Prelude + +import Botan.Low.MPI +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.DSA + +-- TODO: Consolidate +dlGroups :: [ByteString] +dlGroups = + [ "ffdhe/ietf/2048" + , "ffdhe/ietf/3072" + , "ffdhe/ietf/4096" + , "ffdhe/ietf/6144" + , "ffdhe/ietf/8192" + , "modp/ietf/1024" + , "modp/ietf/1536" + , "modp/ietf/2048" + , "modp/ietf/3072" + , "modp/ietf/4096" + , "modp/ietf/6144" + , "modp/ietf/8192" + , "modp/srp/1024" + , "modp/srp/1536" + , "modp/srp/2048" + , "modp/srp/3072" + , "modp/srp/4096" + , "modp/srp/6144" + , "modp/srp/8192" + , "dsa/jce/1024" + , "dsa/botan/2048" + , "dsa/botan/3072" + ] + +-- TODO: Consolidate +privKeyField :: PrivKey -> ByteString -> IO MP +privKeyField privKey field = do + mp <- mpInit + privKeyGetField mp privKey field + return mp + +-- TODO: Consolidate +pubKeyField :: PubKey -> ByteString -> IO MP +pubKeyField pubKey field = do + mp <- mpInit + pubKeyGetField mp pubKey field + return mp + +-- NOTE: Fields are +-- DLGroup PubKey: p, q, g, y +-- DLGroup PrivKey: p, q, g, x, y + +-- NOTE: Fails on pubKeyLoadDSA for srp curves (but not privKeyLoadDSA?) +main :: IO () +main = hspec $ testSuite dlGroups chars $ \ dlGroup -> do + it "privKeyLoadDSA" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "DH" dlGroup rng + p <- privKeyField privKey "p" + q <- privKeyField privKey "q" + g <- privKeyField privKey "g" + x <- privKeyField privKey "x" + loadedKey <- privKeyLoadDSA p q g x + pass + it "pubKeyLoadDSA" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "DH" dlGroup rng + pubKey <- privKeyExportPubKey privKey + p <- pubKeyField pubKey "p" + q <- pubKeyField pubKey "q" + g <- pubKeyField pubKey "g" + y <- pubKeyField pubKey "y" + loadedKey <- pubKeyLoadDSA p q g y + pass diff --git a/test/Botan/Low/PubKey/DecryptSpec.hs b/test/Botan/Low/PubKey/DecryptSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/DecryptSpec.hs @@ -0,0 +1,43 @@ +module Main where + +import Test.Prelude + +import Botan.Low.PubKey +import Botan.Low.PubKey.Encrypt +import Botan.Low.PubKey.Decrypt +import Botan.Low.RNG + +pks = + [ ("RSA", "2048", "PKCS1v15") + , ("SM2", "sm2p256v1", "SHA-256") -- NOTE: Decrypt fails with InsufficientBufferSpace + , ("ElGamal", "modp/ietf/1024", "PKCS1v15") + ] + +pkTestName :: (ByteString, ByteString, ByteString) -> String +pkTestName (pk, param, padding) = chars $ pk <> " " <> param <> " " <> padding + +main :: IO () +main = hspec $ testSuite pks pkTestName $ \ (pk, param, padding) -> do + it "decryptCreate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + ctx <- decryptCreate privKey padding + pass + it "decryptOutputLength" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + ctx <- decryptCreate privKey padding + _ <- decryptOutputLength ctx 128 + pass + it "decrypt" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + ectx <- encryptCreate pubKey padding + dctx <- decryptCreate privKey padding + encrypted <- encrypt ectx rng "Fee fi fo fum!" + decrypted <- decrypt dctx encrypted + decrypted `shouldBe` "Fee fi fo fum!" + pass diff --git a/test/Botan/Low/PubKey/ECDHSpec.hs b/test/Botan/Low/PubKey/ECDHSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/ECDHSpec.hs @@ -0,0 +1,78 @@ +module Main where + +import Test.Prelude + +import Botan.Low.MPI +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.ECDH + +-- TODO: Consolidate +ecGroups :: [ByteString] +ecGroups = + [ "secp160k1" + , "secp160r1" + , "secp160r2" + , "secp192k1" + , "secp192r1" + , "secp224k1" + , "secp224r1" + , "secp256k1" + , "secp256r1" + , "secp384r1" + , "secp521r1" + , "brainpool160r1" + , "brainpool192r1" + , "brainpool224r1" + , "brainpool256r1" + , "brainpool320r1" + , "brainpool384r1" + , "brainpool512r1" + , "x962_p192v2" + , "x962_p192v3" + , "x962_p239v1" + , "x962_p239v2" + , "x962_p239v3" + , "gost_256A" + , "gost_512A" + , "frp256v1" + , "sm2p256v1" + ] + +-- TODO: Consolidate +privKeyField :: PrivKey -> ByteString -> IO MP +privKeyField privKey field = do + mp <- mpInit + privKeyGetField mp privKey field + return mp + +-- TODO: Consolidate +pubKeyField :: PubKey -> ByteString -> IO MP +pubKeyField pubKey field = do + mp <- mpInit + pubKeyGetField mp pubKey field + return mp + +main :: IO () +main = hspec $ testSuite ecGroups chars $ \ ecGroup -> do + it "privKeyLoadECDH" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "ECDH" ecGroup rng + x <- privKeyField privKey "x" + loadedPrivKey <- privKeyLoadECDH x ecGroup + -- Inscrutible >_> but shows key equality + -- pubKeyBytes <- privKeyExportPubKey privKey >>= \ pubKey -> pubKeyExport pubKey PubKeyExportPEM + -- loadedPubKeyBytes <- privKeyExportPubKey loadedPrivKey >>= \ loadedPubKey -> pubKeyExport loadedPubKey PubKeyExportPEM + -- pubKeyBytes `shouldBe` loadedPubKeyBytes + pass + it "pubKeyLoadECDH" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "ECDH" ecGroup rng + pubKey <- privKeyExportPubKey privKey + public_x <- pubKeyField pubKey "public_x" + public_y <- pubKeyField pubKey "public_y" + loadedPubKey <- pubKeyLoadECDH public_x public_y ecGroup + -- pubKeyBytes <- pubKeyExport pubKey PubKeyExportPEM + -- loadedPubKeyBytes <- pubKeyExport loadedPubKey PubKeyExportPEM + -- pubKeyBytes `shouldBe` loadedPubKeyBytes + pass diff --git a/test/Botan/Low/PubKey/ECDSASpec.hs b/test/Botan/Low/PubKey/ECDSASpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/ECDSASpec.hs @@ -0,0 +1,72 @@ +module Main where + +import Test.Prelude + +import Botan.Low.MPI +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.ECDSA + +-- TODO: Consolidate +ecGroups :: [ByteString] +ecGroups = + [ "secp160k1" + , "secp160r1" + , "secp160r2" + , "secp192k1" + , "secp192r1" + , "secp224k1" + , "secp224r1" + , "secp256k1" + , "secp256r1" + , "secp384r1" + , "secp521r1" + , "brainpool160r1" + , "brainpool192r1" + , "brainpool224r1" + , "brainpool256r1" + , "brainpool320r1" + , "brainpool384r1" + , "brainpool512r1" + , "x962_p192v2" + , "x962_p192v3" + , "x962_p239v1" + , "x962_p239v2" + , "x962_p239v3" + , "gost_256A" + , "gost_512A" + , "frp256v1" + , "sm2p256v1" + ] + +-- TODO: Consolidate +privKeyField :: PrivKey -> ByteString -> IO MP +privKeyField privKey field = do + mp <- mpInit + privKeyGetField mp privKey field + return mp + +-- TODO: Consolidate +pubKeyField :: PubKey -> ByteString -> IO MP +pubKeyField pubKey field = do + mp <- mpInit + pubKeyGetField mp pubKey field + return mp + +-- TODO: Don't assume just "ECDSA", other elliptic curve DSA might be valid here +main :: IO () +main = hspec $ testSuite ecGroups chars $ \ ecGroup -> do + it "privKeyLoadECDSA" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "ECDSA" ecGroup rng + x <- privKeyField privKey "x" + loadedPrivKey <- privKeyLoadECDSA x ecGroup + pass + it "pubKeyLoadECDSA" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "ECDSA" ecGroup rng + pubKey <- privKeyExportPubKey privKey + public_x <- pubKeyField pubKey "public_x" + public_y <- pubKeyField pubKey "public_y" + loadedPubKey <- pubKeyLoadECDSA public_x public_y ecGroup + pass diff --git a/test/Botan/Low/PubKey/Ed25519Spec.hs b/test/Botan/Low/PubKey/Ed25519Spec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/Ed25519Spec.hs @@ -0,0 +1,34 @@ +module Main where + +import Test.Prelude + +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.Ed25519 + +main :: IO () +main = hspec $ do + it "privKeyEd25519GetPrivKey" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "Ed25519" "" rng + exportedPrivKey <- privKeyEd25519GetPrivKey privKey + pass + it "pubKeyEd25519GetPubKey" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "Ed25519" "" rng + pubKey <- privKeyExportPubKey privKey + exportedPubKey <- pubKeyEd25519GetPubKey pubKey + pass + it "privKeyLoadEd25519" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "Ed25519" "" rng + exportedPrivKey <- privKeyEd25519GetPrivKey privKey + loadedPrivKey <- privKeyLoadEd25519 exportedPrivKey + pass + it "pubKeyLoadEd25519" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "Ed25519" "" rng + pubKey <- privKeyExportPubKey privKey + exportedPubKey <- pubKeyEd25519GetPubKey pubKey + loadedPubKey <- pubKeyLoadEd25519 exportedPubKey + pass diff --git a/test/Botan/Low/PubKey/ElGamalSpec.hs b/test/Botan/Low/PubKey/ElGamalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/ElGamalSpec.hs @@ -0,0 +1,71 @@ +module Main where + +import Test.Prelude + +import Botan.Low.MPI +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.ElGamal + +-- TODO: Consolidate +dlGroups :: [ByteString] +dlGroups = + [ "ffdhe/ietf/2048" + , "ffdhe/ietf/3072" + , "ffdhe/ietf/4096" + , "ffdhe/ietf/6144" + , "ffdhe/ietf/8192" + , "modp/ietf/1024" + , "modp/ietf/1536" + , "modp/ietf/2048" + , "modp/ietf/3072" + , "modp/ietf/4096" + , "modp/ietf/6144" + , "modp/ietf/8192" + , "modp/srp/1024" + , "modp/srp/1536" + , "modp/srp/2048" + , "modp/srp/3072" + , "modp/srp/4096" + , "modp/srp/6144" + , "modp/srp/8192" + , "dsa/jce/1024" + , "dsa/botan/2048" + , "dsa/botan/3072" + ] + +-- TODO: Consolidate +privKeyField :: PrivKey -> ByteString -> IO MP +privKeyField privKey field = do + mp <- mpInit + privKeyGetField mp privKey field + return mp + +-- TODO: Consolidate +pubKeyField :: PubKey -> ByteString -> IO MP +pubKeyField pubKey field = do + mp <- mpInit + pubKeyGetField mp pubKey field + return mp + +main :: IO () +main = hspec $ testSuite dlGroups chars $ \ dlGroup -> do + it "privKeyLoadELGamal" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "DH" dlGroup rng + p <- privKeyField privKey "p" + q <- privKeyField privKey "q" + g <- privKeyField privKey "g" + x <- privKeyField privKey "x" + loadedKey <- privKeyLoadElGamal p g x + pass + it "pubKeyLoadELGamal" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "DH" dlGroup rng + pubKey <- privKeyExportPubKey privKey + p <- privKeyField privKey "p" + q <- privKeyField privKey "q" + g <- privKeyField privKey "g" + y <- privKeyField privKey "y" + loadedKey <- pubKeyLoadElGamal p g y + pass diff --git a/test/Botan/Low/PubKey/EncryptSpec.hs b/test/Botan/Low/PubKey/EncryptSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/EncryptSpec.hs @@ -0,0 +1,42 @@ +module Main where + +import Test.Prelude + +import Botan.Low.PubKey +import Botan.Low.PubKey.Encrypt +import Botan.Low.RNG + +-- NOTE: SM2 encrypt fails with InsufficientBufferSpace unless sm2p256v1 is used as the +-- curve when creating the key (but creating the key and the encryption context do not fail) + +pks = + [ ("RSA", "2048", "PKCS1v15") + , ("SM2", "sm2p256v1", "SHA-256") -- NOTE: SM2 takes a hash rather than a padding + , ("ElGamal", "modp/ietf/1024", "PKCS1v15") + ] + +pkTestName :: (ByteString, ByteString, ByteString) -> String +pkTestName (pk, param, padding) = chars $ pk <> " " <> param <> " " <> padding + +main :: IO () +main = hspec $ testSuite pks pkTestName $ \ (pk, param, padding) -> do + it "encryptCreate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + ctx <- encryptCreate pubKey padding + pass + it "encryptOutputLength" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + ctx <- encryptCreate pubKey padding + _ <- encryptOutputLength ctx 128 + pass + it "encrypt" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + ctx <- encryptCreate pubKey padding + _ <- encrypt ctx rng "Fee fi fo fum!" + pass diff --git a/test/Botan/Low/PubKey/KeyAgreementSpec.hs b/test/Botan/Low/PubKey/KeyAgreementSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/KeyAgreementSpec.hs @@ -0,0 +1,50 @@ +module Main where + +import Test.Prelude + +import Botan.Low.PubKey +import Botan.Low.PubKey.KeyAgreement +import Botan.Low.RNG + +-- TODO: More thorough test with different KDFs and curves / groups +pks :: [(ByteString, ByteString)] +pks = + [ ("DH", "modp/ietf/1024") + , ("ECDH", "secp256r1") + , ("Curve25519", "") + ] + +pkTestName :: (ByteString, ByteString) -> String +pkTestName (pk, param) = chars $ pk <> " " <> param + +main :: IO () +main = hspec $ testSuite pks pkTestName $ \ (pk, param) -> do + it "keyAgreementCreate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + ka <- keyAgreementCreate privKey "HKDF(SHA-256)" + pass + it "keyAgreementExportPublic" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + ka <- keyAgreementCreate privKey "HKDF(SHA-256)" + pubKey <- keyAgreementExportPublic privKey + pass + it "keyAgreementSize" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + ka <- keyAgreementCreate privKey "HKDF(SHA-256)" + kaSz <- keyAgreementSize ka + pass + it "keyAgreement" $ do + rng <- rngInit "system" + privKeyA <- privKeyCreate pk param rng + pubKeyA <- keyAgreementExportPublic privKeyA + privKeyB <- privKeyCreate pk param rng + pubKeyB <- keyAgreementExportPublic privKeyB + kaA <- keyAgreementCreate privKeyA "HKDF(SHA-256)" + kaB <- keyAgreementCreate privKeyB "HKDF(SHA-256)" + sharedKeyA <- keyAgreement kaA pubKeyB "salt" + sharedKeyB <- keyAgreement kaB pubKeyA "salt" + sharedKeyA `shouldBe` sharedKeyB + pass diff --git a/test/Botan/Low/PubKey/KeyEncapsulationSpec.hs b/test/Botan/Low/PubKey/KeyEncapsulationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/KeyEncapsulationSpec.hs @@ -0,0 +1,67 @@ +module Main where + +import Test.Prelude + +import Botan.Low.PubKey +import Botan.Low.PubKey.KeyEncapsulation +import Botan.Low.RNG + +pks = + [ ( "RSA", "2048", "HKDF(SHA-256)") + , ( "Kyber", "", "HKDF(SHA-256)") + , ( "McEliece", "", "HKDF(SHA-256)") + ] + +pkTestName :: (ByteString, ByteString, ByteString) -> String +pkTestName (pk, param, kdf) = chars $ pk <> " " <> param <> " " <> kdf + +main :: IO () +main = hspec $ testSuite pks pkTestName $ \ (pk, param, kdf) -> do + it "kemEncryptCreate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + kem <- kemEncryptCreate pubKey "HKDF(SHA-256)" + pass + it "kemEncryptSharedKeyLength" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + kem <- kemEncryptCreate pubKey "HKDF(SHA-256)" + sharedKeyLength <- kemEncryptSharedKeyLength kem 256 + pass + it "kemEncryptEncapsulatedKeyLength" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + kem <- kemEncryptCreate pubKey "HKDF(SHA-256)" + encapsulatedKeyLength <- kemEncryptEncapsulatedKeyLength kem + pass + it "kemEncryptCreateSharedKey" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + kem <- kemEncryptCreate pubKey "HKDF(SHA-256)" + (sharedKey, encapsulatedKey) <- kemEncryptCreateSharedKey kem rng "salt" 256 + pass + it "kemDecryptCreate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + kem <- kemDecryptCreate privKey "HKDF(SHA-256)" + pass + it "kemDecryptSharedKeyLength" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + kem <- kemDecryptCreate privKey "HKDF(SHA-256)" + sharedKeyLen <- kemDecryptSharedKeyLength kem 256 + pass + it "kemDecryptSharedKey" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + encryptCtx <- kemEncryptCreate pubKey "HKDF(SHA-256)" + (sharedKey, encapsulatedKey) <- kemEncryptCreateSharedKey encryptCtx rng "salt" 256 + decryptCtx <- kemDecryptCreate privKey "HKDF(SHA-256)" + decryptedSharedKey <- kemDecryptSharedKey decryptCtx "salt" encapsulatedKey 256 + sharedKey `shouldBe` decryptedSharedKey + pass diff --git a/test/Botan/Low/PubKey/RSASpec.hs b/test/Botan/Low/PubKey/RSASpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/RSASpec.hs @@ -0,0 +1,43 @@ +module Main where + +import Test.Prelude + +import Botan.Low.MPI +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.RSA + +rsaSizes = [ "2048" ] + +-- TODO: Consolidate +privKeyField :: PrivKey -> ByteString -> IO MP +privKeyField privKey field = do + mp <- mpInit + privKeyGetField mp privKey field + return mp + +-- TODO: Consolidate +pubKeyField :: PubKey -> ByteString -> IO MP +pubKeyField pubKey field = do + mp <- mpInit + pubKeyGetField mp pubKey field + return mp + +main :: IO () +main = hspec $ testSuite rsaSizes chars $ \ rsaSize -> do + it "privKeyLoadRSA" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "RSA" rsaSize rng + p <- privKeyField privKey "p" + q <- privKeyField privKey "q" + e <- privKeyField privKey "e" + loadedKey <- privKeyLoadRSA p q e + pass + it "pubKeyLoadRSA" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "RSA" rsaSize rng + pubKey <- privKeyExportPubKey privKey + n <- pubKeyField pubKey "n" + e <- pubKeyField pubKey "e" + loadedKey <- pubKeyLoadRSA n e + pass diff --git a/test/Botan/Low/PubKey/SM2Spec.hs b/test/Botan/Low/PubKey/SM2Spec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/SM2Spec.hs @@ -0,0 +1,71 @@ +module Main where + +import Test.Prelude + +import Botan.Low.MPI +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.SM2 + +-- TODO: Consolidate +ecGroups :: [ByteString] +ecGroups = + [ "secp160k1" + , "secp160r1" + , "secp160r2" + , "secp192k1" + , "secp192r1" + , "secp224k1" + , "secp224r1" + , "secp256k1" + , "secp256r1" + , "secp384r1" + , "secp521r1" + , "brainpool160r1" + , "brainpool192r1" + , "brainpool224r1" + , "brainpool256r1" + , "brainpool320r1" + , "brainpool384r1" + , "brainpool512r1" + , "x962_p192v2" + , "x962_p192v3" + , "x962_p239v1" + , "x962_p239v2" + , "x962_p239v3" + , "gost_256A" + , "gost_512A" + , "frp256v1" + , "sm2p256v1" + ] + +-- TODO: Consolidate +privKeyField :: PrivKey -> ByteString -> IO MP +privKeyField privKey field = do + mp <- mpInit + privKeyGetField mp privKey field + return mp + +-- TODO: Consolidate +pubKeyField :: PubKey -> ByteString -> IO MP +pubKeyField pubKey field = do + mp <- mpInit + pubKeyGetField mp pubKey field + return mp + +main :: IO () +main = hspec $ testSuite ecGroups chars $ \ ecGroup -> do + it "privKeyLoadSM2" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "SM2" ecGroup rng + x <- privKeyField privKey "x" + loadedPrivKey <- privKeyLoadSM2 x ecGroup + pass + it "pubKeyLoadSM2" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "SM2" ecGroup rng + pubKey <- privKeyExportPubKey privKey + public_x <- pubKeyField pubKey "public_x" + public_y <- pubKeyField pubKey "public_y" + loadedPubKey <- pubKeyLoadSM2 public_x public_y ecGroup + pass diff --git a/test/Botan/Low/PubKey/SignSpec.hs b/test/Botan/Low/PubKey/SignSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/SignSpec.hs @@ -0,0 +1,67 @@ +module Main where + +import Test.Prelude + +import Botan.Low.PubKey +import Botan.Low.PubKey.Sign +import Botan.Low.RNG + +ecGroup :: ByteString +ecGroup = "secp256r1" + +dlGroup :: ByteString +dlGroup = "modp/ietf/1024" + +sha = "SHA-256" + +-- TODO: More exhaustive testing in botan +-- pks :: [(PKName, PKParams, Padding)] +pks :: [(ByteString, ByteString, ByteString)] +pks = + [ ("RSA", "2048", "EMSA4(SHA-256)") -- NOTE: It is not yet known if any of the others suppport EMSA + , ("SM2", "sm2p256v1", "foo,SHA-256") + , ("DSA", dlGroup, sha) + , ("ECDSA", ecGroup, sha) + , ("ECKCDSA", ecGroup, sha) + , ("ECGDSA", ecGroup, sha) + , ("GOST-34.10", ecGroup, sha) + , ("Ed25519", "", "") + , ("XMSS", "XMSS-SHAKE_10_256", "") + -- TODO: Dilithium-x-y + , ("Dilithium", "", "") + -- TODO: SPHINCS+ + ] + +pkTestName :: (ByteString, ByteString, ByteString) -> String +pkTestName (pk, param, padding) = chars $ pk <> " " <> param <> " " <> padding + +-- NOTE: Some algorithms do not support DER format encoding. +main :: IO () +main = hspec $ testSuite pks pkTestName $ \ (pk, param, algo) -> do + it "signCreate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + ctx <- signCreate privKey algo StandardFormatSignature + -- ctxDER <- signCreate privKey algo DERFormatSignature + pass + it "signOutputLength" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + ctx <- signCreate privKey algo StandardFormatSignature + sigLen <- signOutputLength ctx + -- ctxDER <- signCreate privKey algo DERFormatSignature + -- _ <- signOutputLength ctxDER + pass + it "signUpdate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + ctx <- signCreate privKey algo StandardFormatSignature + signUpdate ctx "Fee fi fo fum!" + pass + it "signFinish" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + ctx <- signCreate privKey algo StandardFormatSignature + signUpdate ctx "Fee fi fo fum!" + sig <- signFinish ctx rng + pass diff --git a/test/Botan/Low/PubKey/VerifySpec.hs b/test/Botan/Low/PubKey/VerifySpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/VerifySpec.hs @@ -0,0 +1,79 @@ +module Main where + +import Test.Prelude + +import qualified Data.ByteString as ByteString + +import Botan.Low.PubKey +import Botan.Low.PubKey.Sign +import Botan.Low.PubKey.Verify +import Botan.Low.RNG + +-- TODO: Consolidate test values with SignSpec + +ecGroup :: ByteString +ecGroup = "secp256r1" + +dlGroup :: ByteString +dlGroup = "modp/ietf/1024" + +sha = "SHA-256" + +pks :: [(ByteString, ByteString, ByteString)] +pks = + [ ("RSA", "2048", "EMSA4(SHA-256)") + , ("SM2", "sm2p256v1", "foo,SHA-256") + , ("DSA", dlGroup, sha) + , ("ECDSA", ecGroup, sha) + , ("ECKCDSA", ecGroup, sha) + , ("ECGDSA", ecGroup, sha) + , ("GOST-34.10", ecGroup, sha) + , ("Ed25519", "", "") + , ("XMSS", "XMSS-SHAKE_10_256", "") + -- TODO: Dilithium-x-y + , ("Dilithium", "", "") + -- TODO: SPHINCS+ + ] + +pkTestName :: (ByteString, ByteString, ByteString) -> String +pkTestName (pk, param, padding) = chars $ pk <> " " <> param <> " " <> padding + +-- SEE: signFinish for more details +-- NOTE: Verified signatures pass for all algorithms in standard format +-- Fails for only 4 in DER format via BadParameterException, but for important algs: +-- RSA, Ed25519, XMSS, Dilithium +-- The context and signatures are created without throwing any errors, +-- compared to earlier which failed to even create a context, but +-- it is possible that I need to figure out correct parameters and I doubt +-- it is coincidence that the EMSA4 / empty params are the ones that are failing. +-- Yet, it works for standard format. + +main :: IO () +main = hspec $ testSuite pks pkTestName $ \ (pk, param, algo) -> do + it "verifyCreate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + ctx <- verifyCreate pubKey algo StandardFormatSignature + pass + it "verifyUpdate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + ctx <- verifyCreate pubKey algo StandardFormatSignature + verifyUpdate ctx "Fee fi fo fum!" + pass + it "verifyFinish" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + signCtx <- signCreate privKey algo StandardFormatSignature + signUpdate signCtx "Fee fi fo fum!" + sig <- signFinish signCtx rng + -- print $ "Siglen is: " <> show (ByteString.length sig) + print sig + pubKey <- privKeyExportPubKey privKey + verifyCtx <- verifyCreate pubKey algo StandardFormatSignature + verifyUpdate verifyCtx "Fee fi fo fum!" + verified <- verifyFinish verifyCtx sig + verified `shouldBe` True + pass diff --git a/test/Botan/Low/PubKey/X25519Spec.hs b/test/Botan/Low/PubKey/X25519Spec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKey/X25519Spec.hs @@ -0,0 +1,34 @@ +module Main where + +import Test.Prelude + +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.PubKey.X25519 + +main :: IO () +main = hspec $ do + it "privKeyX25519GetPrivKey" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "Curve25519" "" rng + exportedPrivKey <- privKeyX25519GetPrivKey privKey + pass + it "pubKeyX25519GetPubKey" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "Curve25519" "" rng + pubKey <- privKeyExportPubKey privKey + exportedPubKey <- pubKeyX25519GetPubKey pubKey + pass + it "privKeyLoadX25519" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "Curve25519" "" rng + exportedPrivKey <- privKeyX25519GetPrivKey privKey + loadedPrivKey <- privKeyLoadX25519 exportedPrivKey + pass + it "pubKeyLoadX25519" $ do + rng <- rngInit "system" + privKey <- privKeyCreate "Curve25519" "" rng + pubKey <- privKeyExportPubKey privKey + exportedPubKey <- pubKeyX25519GetPubKey pubKey + loadedPubKey <- pubKeyLoadX25519 exportedPubKey + pass diff --git a/test/Botan/Low/PubKeySpec.hs b/test/Botan/Low/PubKeySpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PubKeySpec.hs @@ -0,0 +1,188 @@ +module Main where + +import Test.Prelude + +import Botan.Low.MPI +import Botan.Low.RNG +import Botan.Low.PubKey + +ecGroup :: ByteString +ecGroup = "secp256r1" + +dlGroup :: ByteString +dlGroup = "modp/ietf/1024" + +-- TODO: More exhaustive testing in botan +-- pks :: [(PKName, PKParams)] +pks :: [(ByteString, ByteString)] +pks = + [ ("RSA", "2048") + , ("SM2", ecGroup) + , ("ElGamal", dlGroup) + , ("DSA", dlGroup) + , ("ECDSA", ecGroup) + , ("ECKCDSA", ecGroup) + , ("ECGDSA", ecGroup) + , ("GOST-34.10", ecGroup) + , ("Ed25519", "") + , ("XMSS", "XMSS-SHAKE_10_256") -- NOTE: XMSS is noticeably slower than other keys and + -- the _16 and _20 variants are exponentially slower + , ("DH", dlGroup) + , ("ECDH", ecGroup) + , ("Curve25519", "") + -- TODO: Dilithium-x-y + , ("Dilithium", "") + -- TODO: Kyber-x-y + , ("Kyber", "") + -- TODO: SPHINCS+ + -- https://github.com/randombit/botan/blob/a303f4af1504e7ac349dd798190924ea08ead9b7/src/lib/pubkey/sphincsplus/sphincsplus_common/sp_parameters.cpp#L155 + -- , ("SPHINCS+", "sha2-128s-r3.1") -- Not working + , ("McEliece", "") + ] + +pkTestName :: (ByteString, ByteString) -> String +pkTestName (pk, param) = chars $ pk <> " " <> param + +-- NOTE: Known fields are: n, e, p, q, g, a, b +-- ECGroup PrivKey: x plus all in PubKey +-- EGGroup PubKey: public_x, public_y, base_x, base_y, p, a, b, cofactor, order +-- DLGroup PubKey: p, q, g, y (not all groups have all four) +-- DLGroup PrivKey: p, q, g, x, y +-- RSA PubKey: p, q, d, c, d1, d2 +-- RSA PrivKey: n, e, d, p, q, d1, d2, c + +ecGroupPrivFields = [ "x" , "public_x", "public_y", "base_x", "base_y", "p", "a", "b", "cofactor", "order" ] +ecGroupPubFields = [ "public_x", "public_y", "base_x", "base_y", "p", "a", "b", "cofactor", "order" ] + +dlGroupPrivFields = [ "p", "q", "g", "x", "y" ] +dlGroupPubFields = [ "p", "q", "g", "y" ] + +privKeyFields "RSA" = [ "p", "q", "d", "n", "e"] -- TODO: Check +privKeyFields "SM2" = ecGroupPrivFields +privKeyFields "ElGamal" = dlGroupPrivFields +privKeyFields "DSA" = dlGroupPrivFields +privKeyFields "ECDSA" = ecGroupPrivFields +privKeyFields "ECKCDSA" = ecGroupPrivFields +privKeyFields "ECGDSA" = ecGroupPrivFields +privKeyFields "GOST-34.10" = ecGroupPrivFields +privKeyFields "Ed25519" = [] -- TODO +privKeyFields "XMSS" = [] -- TODO +privKeyFields "DH" = dlGroupPrivFields +privKeyFields "ECDH" = ecGroupPrivFields +privKeyFields "Curve25519" = [] -- TODO +privKeyFields "Dilithium" = [] -- TODO +privKeyFields "Kyber" = [] -- TODO +privKeyFields "McEliece" = [] -- TODO + +pubKeyFields "RSA" = [ "n", "e" ] +pubKeyFields "SM2" = ecGroupPubFields +pubKeyFields "ElGamal" = dlGroupPubFields +pubKeyFields "DSA" = dlGroupPubFields +pubKeyFields "ECDSA" = ecGroupPubFields +pubKeyFields "ECKCDSA" = ecGroupPubFields +pubKeyFields "ECGDSA" = ecGroupPubFields +pubKeyFields "GOST-34.10" = ecGroupPubFields +pubKeyFields "Ed25519" = [] -- TODO +pubKeyFields "XMSS" = [] -- TODO +pubKeyFields "DH" = dlGroupPubFields +pubKeyFields "ECDH" = ecGroupPubFields +pubKeyFields "Curve25519" = [] -- TODO +pubKeyFields "Dilithium" = [] -- TODO +pubKeyFields "Kyber" = [] -- TODO +pubKeyFields "McEliece" = [] -- TODO + +-- NOTE: These tests are going to be very slow if we create new keys every time +main :: IO () +main = hspec $ testSuite pks pkTestName $ \ (pk, param) -> do + it "privKeyCreate" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pass + it "privKeyCheckKey" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + privKeyCheckKey privKey rng CheckKeyNormalTests + -- privKeyCheckKey privKey rng CheckKeyExpensiveTests + pass + it "privKeyExport" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + privKeyDER <- privKeyExport privKey PrivKeyExportDER + privKeyPEM <- privKeyExport privKey PrivKeyExportPEM + pass + it "privKeyLoad" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + privKeyDER <- privKeyExport privKey PrivKeyExportDER + privKeyPEM <- privKeyExport privKey PrivKeyExportPEM + privKeyLoad privKeyDER "" + privKeyLoad privKeyPEM "" + pass + it "privKeyAlgoName" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + privKeyAlgoName privKey + pass + it "privKeyExportPubKey" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + pass + it "pubKeyCheckKey" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + pubKeyCheckKey pubKey rng CheckKeyNormalTests + -- pubKeyCheckKey pubKey rng CheckKeyExpensiveTests + pass + it "pubKeyExport" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + pubKeyDER <- pubKeyExport pubKey PrivKeyExportDER + pubKeyPEM <- pubKeyExport pubKey PrivKeyExportPEM + pass + it "pubKeyLoad" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + pubKeyDER <- pubKeyExport pubKey PrivKeyExportDER + pubKeyPEM <- pubKeyExport pubKey PrivKeyExportPEM + pubKeyLoad pubKeyDER + pubKeyLoad pubKeyPEM + pass + it "pubKeyAlgoName" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + pubKeyAlgoName pubKey + pass + it "pubKeyEstimatedStrength" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + pubKeyEstimatedStrength pubKey + pass + it "pubKeyFingerprint" $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + pubKeyFingerprint pubKey "SHA-256" + pass + describe "privKeyGetField" $ do + forM_ (privKeyFields pk) $ \ field -> do + it (chars field) $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + mp <- mpInit + privKeyGetField mp privKey field + pass + describe "pubKeyGetField" $ do + forM_ (pubKeyFields pk) $ \ field -> do + it (chars field) $ do + rng <- rngInit "system" + privKey <- privKeyCreate pk param rng + pubKey <- privKeyExportPubKey privKey + mp <- mpInit + pubKeyGetField mp pubKey field + pass diff --git a/test/Botan/Low/PwdHashSpec.hs b/test/Botan/Low/PwdHashSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/PwdHashSpec.hs @@ -0,0 +1,61 @@ +module Main where + +import Data.ByteString (isPrefixOf) + +import Botan.Low.Hash +import Botan.Low.MAC +import Botan.Low.PwdHash + +import Test.Prelude + +-- NOTE: Needs more exhaustive tests, and to validate parameter order for +-- Scrypt and the Argons. We've got tests that pass, but that doesn't +-- mean that they're being used properly. Need to investigate C++ source. + +-- NOTE: Values generated by "pwdhashTimed pbkdf 200 64 passphrase salt" +pbkdfs :: [(PBKDFName, Int, Int, Int)] +pbkdfs = + [ ("PBKDF2(HMAC(SHA-512))",138000,0,0) + -- NOTE: These results indicate that the parameter result order is inconsistent + -- for pwdhashTimed compared to pwdhash + -- Eg, Scrypt should be n, r, p but n=8192 is clearly last + -- Same for the argons + -- This causes both tests to fail (original generated values) + -- , ("Scrypt",1,81,8192) + -- , ("Argon2d",1,1,262144) + -- , ("Argon2i",1,1,262144) + -- , ("Argon2id",1,1,262144) + -- Note that this still causes four pwdhashTimed tests to still fail because + -- the pwdhashTimed function itself needs to be fixed for these algorithms + -- Fixed values, assuming only x/z are flipped a la (x,y,z) -> (z,y,x) + -- But + , ("Scrypt",8192,81,1) + , ("Argon2d",262144,1,1) + , ("Argon2i",262144,1,1) + , ("Argon2id",262144,1,1) + , ("Bcrypt-PBKDF",26,0,0) + , ("OpenPGP-S2K(SHA-512)",65011712,0,0) + ] + +passphrase :: ByteString +passphrase = "Fee fi fo fum!" + +salt :: ByteString +salt = "salt" + +main :: IO () +main = hspec $ testSuite pbkdfs (\(n,_,_,_) -> chars n) $ \ (pbkdf, i, j, k) -> do + it "pwdhash" $ do + _ <- pwdhash pbkdf i j k 64 passphrase salt + pass + it "pwdhashTimed" $ do + timed@(i',j',k',pwd) <- pwdhashTimed pbkdf 200 64 passphrase salt + -- NOTE: Fails parity for Scrypt and the Argons due to parameter order + -- pwd' <- pwdhash pbkdf i' j' k' 64 passphrase salt + --NOTE: Scrypt still fails parity and flipping j and k doesn't matter. + pwd' <- case pbkdf of + "Scrypt" -> pwdhash pbkdf j' k' i' 64 passphrase salt + _ | "Argon" `isPrefixOf` pbkdf -> pwdhash pbkdf k' j' i' 64 passphrase salt + _ -> pwdhash pbkdf i' j' k' 64 passphrase salt + pwd `shouldBe` pwd' + pass diff --git a/test/Botan/Low/RNGSpec.hs b/test/Botan/Low/RNGSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/RNGSpec.hs @@ -0,0 +1,42 @@ +module Main where + +import Test.Prelude + +import qualified Data.ByteString as ByteString + +import Botan.Low.RNG + +rngs :: [RNGType] +rngs = + [ SystemRNG + , UserRNG + , UserThreadsafeRNG + , RDRandRNG -- NOTES: Not available on all processors + ] + +main :: IO () +main = hspec $ do + it "systemRNGGet" $ do + bs <- systemRNGGet 8 + ByteString.length bs `shouldBe` 8 + testSuite rngs chars $ \ rng -> do + it "rngInit" $ do + ctx <- rngInit rng + pass + it "rngGet" $ do + ctx <- rngInit rng + bs <- rngGet ctx 8 + pass + it "rngReseed" $ do + ctx <- rngInit rng + rngReseed ctx 64 + pass + it "rngReseedFromRNGCtx" $ do + ctx <- rngInit rng + source <- rngInit rng + rngReseedFromRNG ctx source 64 + pass + it "rngAddEntropy" $ do + ctx <- rngInit rng + rngAddEntropy ctx "Fee fi fo fum!" + pass diff --git a/test/Botan/Low/SRP6Spec.hs b/test/Botan/Low/SRP6Spec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/SRP6Spec.hs @@ -0,0 +1,63 @@ +module Main where + +import Test.Prelude + +import Botan.Low.SRP6 +import Botan.Low.RNG +import Botan.Low.PubKey +import Botan.Low.Hash + +username :: ByteString +username = "username" + +password :: ByteString +password = "password" + +salt :: ByteString +salt = "salt" + +-- NOTE: Consolidate with DLGroup +groupIds :: [DLGroupName] +groupIds = + [ "ffdhe/ietf/2048" + , "ffdhe/ietf/3072" + , "ffdhe/ietf/4096" + , "ffdhe/ietf/6144" + , "ffdhe/ietf/8192" + , "modp/ietf/1024" + , "modp/ietf/1536" + , "modp/ietf/2048" + , "modp/ietf/3072" + , "modp/ietf/4096" + , "modp/ietf/6144" + , "modp/ietf/8192" + , "modp/srp/1024" + , "modp/srp/1536" + , "modp/srp/2048" + , "modp/srp/3072" + , "modp/srp/4096" + , "modp/srp/6144" + , "modp/srp/8192" + , "dsa/jce/1024" + , "dsa/botan/2048" + , "dsa/botan/3072" + ] + +groupId :: DLGroupName +groupId = head groupIds + +-- TODO: Test which hashes work +hashId :: HashName +hashId = "SHA-256" + +main :: IO () +main = hspec $ testSuite groupIds chars $ \ groupId -> do + it "can negotiate a shared secret" $ do + rng <- rngInit "system" + verifier <- srp6GenerateVerifier username password salt groupId hashId + ctx <- srp6ServerSessionInit + b <- srp6ServerSessionStep1 ctx verifier groupId hashId rng + (a,sharedSecret) <- srp6ClientAgree username password groupId hashId salt b rng + sharedSecret' <- srp6ServerSessionStep2 ctx a + sharedSecret `shouldBe` sharedSecret' + pass diff --git a/test/Botan/Low/TOTPSpec.hs b/test/Botan/Low/TOTPSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/TOTPSpec.hs @@ -0,0 +1,31 @@ +module Main where + +import Test.Prelude +import Botan.Low.Hash (HashName(..)) + +import Botan.Low.TOTP + +key :: ByteString +key = "Fee fi fo fum" + +timestep :: TOTPTimestep +timestep = 60 + +timestamp :: TOTPTimestamp +timestamp = 1698109812 + +-- TODO: More thorough testing +main :: IO () +main = hspec $ testSuite totpHashes chars $ \ h -> do + it "totpInit" $ do + ctx <- totpInit key h 6 timestep + pass + it "totpGenerate" $ do + ctx <- totpInit key h 6 timestep + code <- totpGenerate ctx timestamp + pass + it "totpCheck" $ do + ctx <- totpInit key h 6 timestep + code <- totpGenerate ctx timestamp + success <- totpCheck ctx code timestamp 0 + success `shouldBe` True diff --git a/test/Botan/Low/UtilitySpec.hs b/test/Botan/Low/UtilitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/UtilitySpec.hs @@ -0,0 +1,41 @@ +module Main where + +import Test.Prelude + +import Botan.Low.Utility + +import qualified Data.ByteString as ByteString + +message = "Fee fi fo fum!" + +hexMessage = "46656520666920666F2066756D21" + +base64Message = "RmVlIGZpIGZvIGZ1bSE=" + +-- hexUpperMessage + +main :: IO () +main = hspec $ do + it "constantTimeCompare" $ do + equal <- constantTimeCompare "compare me" "compare me" (ByteString.length "compare me") + equal `shouldBe` True + pass + -- TODO: + -- it "scrubMem" $ do + -- pass + it "hexEncode" $ do + hex <- hexEncode message HexUpperCase + hex `shouldBe` hexMessage + pass + it "hexDecode" $ do + msg <- hexDecode hexMessage + msg `shouldBe` message + pass + it "base64Encode" $ do + base64 <- base64Encode message + base64 `shouldBe` base64Message + pass + it "base64Decode" $ do + msg <- base64Decode base64Message + msg `shouldBe` message + pass diff --git a/test/Botan/Low/X509Spec.hs b/test/Botan/Low/X509Spec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/X509Spec.hs @@ -0,0 +1,171 @@ +module Main where + +import Test.Prelude + +import Botan.Low.X509 + +import Paths_botan_low + +-- NOTE: Taken from https://fm4dd.com/openssl/certexamples.shtm +testCert :: ByteString +testCert = "-----BEGIN CERTIFICATE-----\ +\MIID2jCCA0MCAg39MA0GCSqGSIb3DQEBBQUAMIGbMQswCQYDVQQGEwJKUDEOMAwG\ +\A1UECBMFVG9reW8xEDAOBgNVBAcTB0NodW8ta3UxETAPBgNVBAoTCEZyYW5rNERE\ +\MRgwFgYDVQQLEw9XZWJDZXJ0IFN1cHBvcnQxGDAWBgNVBAMTD0ZyYW5rNEREIFdl\ +\YiBDQTEjMCEGCSqGSIb3DQEJARYUc3VwcG9ydEBmcmFuazRkZC5jb20wHhcNMTIw\ +\ODIyMDUyODAwWhcNMTcwODIxMDUyODAwWjBKMQswCQYDVQQGEwJKUDEOMAwGA1UE\ +\CAwFVG9reW8xETAPBgNVBAoMCEZyYW5rNEREMRgwFgYDVQQDDA93d3cuZXhhbXBs\ +\ZS5jb20wggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQCwvWITOLeyTbS1\ +\Q/UacqeILIK16UHLvSymIlbbiT7mpD4SMwB343xpIlXN64fC0Y1ylT6LLeX4St7A\ +\cJrGIV3AMmJcsDsNzgo577LqtNvnOkLH0GojisFEKQiREX6gOgq9tWSqwaENccTE\ +\sAXuV6AQ1ST+G16s00iN92hjX9V/V66snRwTsJ/p4WRpLSdAj4272hiM19qIg9zr\ +\h92e2rQy7E/UShW4gpOrhg2f6fcCBm+aXIga+qxaSLchcDUvPXrpIxTd/OWQ23Qh\ +\vIEzkGbPlBA8J7Nw9KCyaxbYMBFb1i0lBjwKLjmcoihiI7PVthAOu/B71D2hKcFj\ +\Kpfv4D1Uam/0VumKwhwuhZVNjLq1BR1FKRJ1CioLG4wCTr0LVgtvvUyhFrS+3PdU\ +\R0T5HlAQWPMyQDHgCpbOHW0wc0hbuNeO/lS82LjieGNFxKmMBFF9lsN2zsA6Qw32\ +\Xkb2/EFltXCtpuOwVztdk4MDrnaDXy9zMZuqFHpv5lWTbDVwDdyEQNclYlbAEbDe\ +\vEQo/rAOZFl94Mu63rAgLiPeZN4IdS/48or5KaQaCOe0DuAb4GWNIQ42cYQ5TsEH\ +\Wt+FIOAMSpf9hNPjDeu1uff40DOtsiyGeX9NViqKtttaHpvd7rb2zsasbcAGUl+f\ +\NQJj4qImPSB9ThqZqPTukEcM/NtbeQIDAQABMA0GCSqGSIb3DQEBBQUAA4GBAIAi\ +\gU3My8kYYniDuKEXSJmbVB+K1upHxWDA8R6KMZGXfbe5BRd8s40cY6JBYL52Tgqd\ +\l8z5Ek8dC4NNpfpcZc/teT1WqiO2wnpGHjgMDuDL1mxCZNL422jHpiPWkWp3AuDI\ +\c7tL1QjbfAUHAQYwmHkWgPP+T2wAv0pOt36GgMCM\ +\-----END CERTIFICATE-----\ +\" + +-- NOTE: Taken from https://fm4dd.com/openssl/certexamples.shtm +testCertFile :: FilePath +testCertFile = "test-data/4096b-rsa-example-cert.pem" + +{- +Version: 1 +Subject: C="JP",X520.State="Tokyo",O="Frank4DD",CN="www.example.com" +Issuer: C="JP",X520.State="Tokyo",X520.Locality="Chuo-ku",O="Frank4DD",OU="WebCert Support",CN="Frank4DD Web CA",PKCS9.EmailAddress="support@frank4dd.com" +Issued: 2012/08/22 05:28:00 UTC +Expires: 2017/08/21 05:28:00 UTC +Constraints: + None +Signature algorithm: RSA/EMSA3(SHA-1) +Serial number: 0DFD +Public Key [RSA-4096] + +-----BEGIN PUBLIC KEY----- +MIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEAsL1iEzi3sk20tUP1GnKn +iCyCtelBy70spiJW24k+5qQ+EjMAd+N8aSJVzeuHwtGNcpU+iy3l+ErewHCaxiFd +wDJiXLA7Dc4KOe+y6rTb5zpCx9BqI4rBRCkIkRF+oDoKvbVkqsGhDXHExLAF7leg +ENUk/hterNNIjfdoY1/Vf1eurJ0cE7Cf6eFkaS0nQI+Nu9oYjNfaiIPc64fdntq0 +MuxP1EoVuIKTq4YNn+n3AgZvmlyIGvqsWki3IXA1Lz166SMU3fzlkNt0IbyBM5Bm +z5QQPCezcPSgsmsW2DARW9YtJQY8Ci45nKIoYiOz1bYQDrvwe9Q9oSnBYyqX7+A9 +VGpv9FbpisIcLoWVTYy6tQUdRSkSdQoqCxuMAk69C1YLb71MoRa0vtz3VEdE+R5Q +EFjzMkAx4AqWzh1tMHNIW7jXjv5UvNi44nhjRcSpjARRfZbDds7AOkMN9l5G9vxB +ZbVwrabjsFc7XZODA652g18vczGbqhR6b+ZVk2w1cA3chEDXJWJWwBGw3rxEKP6w +DmRZfeDLut6wIC4j3mTeCHUv+PKK+SmkGgjntA7gG+BljSEONnGEOU7BB1rfhSDg +DEqX/YTT4w3rtbn3+NAzrbIshnl/TVYqirbbWh6b3e629s7GrG3ABlJfnzUCY+Ki +Jj0gfU4amaj07pBHDPzbW3kCAwEAAQ== +-----END PUBLIC KEY----- + +-} + +testCertHostname :: ByteString +testCertHostname = "www.example.com" + +testCertValidTimestamp = 1420092000 + +main :: IO () +main = hspec $ do + it "x509CertLoad" $ do + cert <- x509CertLoad testCert + pass + it "x509CertLoadFile" $ do + cert <- x509CertLoadFile =<< getDataFileName testCertFile + pass + it "x509CertDup" $ do + cert <- x509CertLoad testCert + dup <- x509CertDup cert + -- TODO: parity check, eg: x509CertGetPublicKey cert == x509CertGetPublicKey dup + pass + it "x509CertGetTimeStarts" $ do + cert <- x509CertLoad testCert + ts <- x509CertGetTimeStarts cert + pass + it "x509CertGetTimeExpires" $ do + cert <- x509CertLoad testCert + te <- x509CertGetTimeExpires cert + pass + it "x509CertNotBefore" $ do + cert <- x509CertLoad testCert + nb <- x509CertNotBefore cert + pass + it "x509CertNotAfter" $ do + cert <- x509CertLoad testCert + na <- x509CertNotAfter cert + pass + it "x509CertGetPubKeyFingerprint" $ do + cert <- x509CertLoad testCert + fp <- x509CertGetPubKeyFingerprint cert "SHA-256" -- TODO: HashName + pass + it "x509CertGetSerialNumber" $ do + cert <- x509CertLoad testCert + sn <- x509CertGetSerialNumber cert + pass + it "x509CertGetAuthorityKeyId" $ do + cert <- x509CertLoad testCert + akid <- x509CertGetAuthorityKeyId cert + pass + it "x509CertGetSubjectKeyId" $ do + cert <- x509CertLoad testCert + sid <- x509CertGetSubjectKeyId cert + pass + it "x509CertGetPublicKeyBits" $ do + cert <- x509CertLoad testCert + pkbits <- x509CertGetPublicKeyBits cert + pass + it "x509CertGetPublicKey" $ do + cert <- x509CertLoad testCert + pk <- x509CertGetPublicKey cert + pass + it "x509CertGetIssuerDN" $ do + cert <- x509CertLoad testCert + _ <- x509CertGetIssuerDN cert "CN" 0 -- TODO: Distinguished names, etc + pass + it "x509CertGetSubjectDN" $ do + cert <- x509CertLoad testCert + _ <- x509CertGetSubjectDN cert "CN" 0 -- TODO: Distinguished names, etc + pass + it "x509CertToString" $ do + cert <- x509CertLoad testCert + pass + it "x509CertAllowedUsage" $ do + cert <- x509CertLoad testCert + allowed <- x509CertAllowedUsage cert NoConstraints + pass + it "x509CertHostnameMatch" $ do + cert <- x509CertLoad testCert + matched <- x509CertHostnameMatch cert testCertHostname + pass + it "x509CertVerify" $ do + cert <- x509CertLoad testCert + (success, status) <- x509CertVerify cert [] [] Nothing 0 testCertHostname testCertValidTimestamp + pass + it "x509CertValidationStatus" $ do + cert <- x509CertLoad testCert + _ <- x509CertValidationStatus 0 + pending + -- NOTE: May need to generate a proper test cert with CA and CRL + it "x509CRLLoad" $ do + cert <- x509CertLoad testCert + -- x509CRLLoad cert + pending + it "x509CRLLoadFile" $ do + cert <- x509CertLoad testCert + -- x509CRLLoadFile cert + pending + it "x509IsRevoked" $ do + cert <- x509CertLoad testCert + -- x509IsRevoked cert + pending + it "x509CertVerifyWithCLR" $ do + cert <- x509CertLoad testCert + -- x509CertVerifyWithCLR cert + pending + diff --git a/test/Botan/Low/ZFECSpec.hs b/test/Botan/Low/ZFECSpec.hs new file mode 100644 --- /dev/null +++ b/test/Botan/Low/ZFECSpec.hs @@ -0,0 +1,27 @@ +module Main where + +import Test.Prelude + +import Botan.Low.ZFEC + +k :: Int +k = 5 + +n :: Int +n = 7 + +message :: ByteString +message = "Fee fi fo fum! I smell the blood of an Englishman!" + +main :: IO () +main = hspec $ do + describe "zfecEncode" $ do + it "encodes a message into shares" $ do + shares <- zfecEncode k n message + length shares `shouldBe` n + describe "zfecDecode" $ do + it "recovers a message from enough shares" $ do + shares <- zfecEncode k n message + someShares <- take k <$> generate (shuffle shares) + recoveredMessage <- zfecDecode k n someShares + recoveredMessage `shouldBe` message diff --git a/test/Test/Prelude.hs b/test/Test/Prelude.hs new file mode 100644 --- /dev/null +++ b/test/Test/Prelude.hs @@ -0,0 +1,50 @@ +module Test.Prelude +( module Prelude +, module Test.Hspec +, module Test.QuickCheck +, module Control.Monad +, module Data.ByteString +, chars +, splitBlocks +, testSuite +, ftestSuite +, pass +, anyBotanException +) where + +import Prelude + +import Test.Hspec +import Test.QuickCheck + +import Control.Monad + +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Char8 + +import Botan.Low.Error + +chars :: ByteString -> [Char] +chars = Char8.unpack + +splitBlocks :: Int -> ByteString -> [ByteString] +splitBlocks blockSize = go where + go bytes = case ByteString.splitAt blockSize bytes of + (block,"") -> [block] + (block,rest) -> block : go rest + +testSuite :: [t] -> (t -> String) -> (t -> SpecWith a) -> SpecWith a +testSuite tests testName runTest = forM_ tests $ \ test -> describe (testName test) (runTest test) + +ftestSuite :: [t] -> (t -> String) -> (t -> SpecWith a) -> SpecWith a +ftestSuite tests testName runTest = focus (testSuite tests testName runTest) + +-- An alternative to void? +-- _ <- performSomeAction +-- pass +pass :: (Monad m) => m () +pass = return () + +anyBotanException :: Selector SomeBotanException +anyBotanException = const True