├── .gitignore ├── pack.toml ├── src ├── Utils │ ├── Show.idr │ ├── Num.idr │ ├── ConstantTable.idr │ ├── Handle │ │ └── C.idr │ ├── Handle.idr │ ├── Base64.idr │ ├── IPAddr.idr │ ├── Bytes.idr │ ├── Parser.idr │ └── Misc.idr ├── Network │ ├── TLS.idr │ └── TLS │ │ ├── Wrapper.idr │ │ ├── Parse │ │ ├── PEM.idr │ │ └── DER.idr │ │ ├── Certificate │ │ └── System.idr │ │ ├── Record.idr │ │ ├── Parsing.idr │ │ ├── AEAD.idr │ │ ├── HKDF.idr │ │ ├── Signature.idr │ │ ├── HelloExtension.idr │ │ └── Handle.idr └── Crypto │ ├── Hash │ ├── Interfaces.idr │ ├── HMAC.idr │ ├── OID.idr │ ├── SHA1.idr │ ├── MD5.idr │ ├── GHash.idr │ ├── Poly1305.idr │ ├── MerkleDamgard.idr │ └── SHA2.idr │ ├── Random │ ├── C.idr │ └── JS.idr │ ├── Hash.idr │ ├── Curve.idr │ ├── ECDH.idr │ ├── Random.idr │ ├── ChaCha.idr │ ├── Curve │ ├── XCurves.idr │ └── Weierstrass.idr │ ├── RSA.idr │ └── AES │ ├── Big.idr │ └── Common.idr ├── tests ├── src │ ├── CertTest.idr │ ├── Test.idr │ ├── RandomTest.idr │ ├── Crypto.idr │ └── LTLS.idr └── tlstest.ipkg ├── LICENSE ├── support ├── Makefile └── idristls.c ├── tls.ipkg ├── README.md └── .github └── workflows └── ci-lib.yml /.gitignore: -------------------------------------------------------------------------------- 1 | build/ 2 | *.sw? 3 | *.so 4 | *.d 5 | *.o 6 | *.dll 7 | *.dylib 8 | /lib/ 9 | /support/libidristls 10 | -------------------------------------------------------------------------------- /pack.toml: -------------------------------------------------------------------------------- 1 | [custom.all.tls] 2 | type = "local" 3 | path = "." 4 | ipkg = "tls.ipkg" 5 | 6 | [custom.all.tls-tests] 7 | type = "local" 8 | path = "tests" 9 | ipkg = "tlstest.ipkg" -------------------------------------------------------------------------------- /src/Utils/Show.idr: -------------------------------------------------------------------------------- 1 | module Utils.Show 2 | 3 | import Data.List 4 | 5 | export 6 | show_record : String -> List (String, String) -> String 7 | show_record adt_name fields = adt_name <+> " { " <+> (concat $ intersperse "; " $ map (\(a,b) => a <+> " = " <+> b) $ fields) <+> " }" 8 | -------------------------------------------------------------------------------- /src/Network/TLS.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS 2 | 3 | import public Network.TLS.Core 4 | import public Network.TLS.Certificate 5 | import public Network.TLS.Handle 6 | import public Network.TLS.Parse.DER 7 | import public Network.TLS.Parse.PEM 8 | import public Network.TLS.Verify 9 | import public Network.TLS.Magic 10 | -------------------------------------------------------------------------------- /tests/src/CertTest.idr: -------------------------------------------------------------------------------- 1 | module CertTest 2 | 3 | import Network.TLS.Certificate.System 4 | import Network.TLS.Certificate 5 | import Control.Monad.Error.Either 6 | 7 | export 8 | test_cert : EitherT String IO () 9 | test_cert = do 10 | certs <- MkEitherT get_system_trusted_certs 11 | putStrLn "\{show (length certs)} certificates found" 12 | -------------------------------------------------------------------------------- /src/Crypto/Hash/Interfaces.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Hash.Interfaces 2 | 3 | import Data.Vect 4 | 5 | public export 6 | interface Digest (0 algo : Type) where 7 | digest_nbyte : Nat 8 | update : List Bits8 -> algo -> algo 9 | finalize : algo -> Vect digest_nbyte Bits8 10 | 11 | public export 12 | interface Digest algo => Hash algo where 13 | block_nbyte : Nat 14 | initialize : algo 15 | 16 | public export 17 | interface Digest algo => MAC (0 key : Type) algo where 18 | initialize_mac : key -> algo 19 | -------------------------------------------------------------------------------- /src/Crypto/Random/C.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Random.C 2 | 3 | import Crypto.Random 4 | import System.FFI 5 | import Data.Vect 6 | import Utils.Misc 7 | import Data.Buffer 8 | import Data.List 9 | import System.Info 10 | 11 | %foreign "C:random_buf,libidristls" 12 | prim_io__random_buf : Buffer -> Int -> PrimIO Int 13 | 14 | public export 15 | HasIO io => MonadRandom io where 16 | random_bytes Z = pure [] 17 | random_bytes n = do 18 | let n' = cast n 19 | Just buf <- newBuffer n' 20 | | Nothing => assert_total $ idris_crash "somehow newBuffer failed" 21 | 0 <- primIO $ prim_io__random_buf buf n' 22 | | _ => assert_total $ idris_crash "random_buf failed" 23 | traverse (getBits8 buf) (map (cast . finToNat) Fin.range) 24 | -------------------------------------------------------------------------------- /tests/tlstest.ipkg: -------------------------------------------------------------------------------- 1 | package tlstest 2 | 3 | version = 0.0.1 4 | 5 | authors = "octeep" 6 | 7 | readme = "README.md" 8 | 9 | homepage = "https://github.com/octeep/idris2-tls" 10 | sourceloc = "https://github.com/octeep/idris2-tls.git" 11 | bugtracker = "https://github.com/octeep/idris2-tls/issues" 12 | 13 | license = "ISC (refer to LICENSE file)" 14 | brief = "A portable idris2 implementation of TLS" 15 | 16 | depends = base >= 0.5.1 17 | , contrib >= 0.5.1 18 | , network >= 0.5.1 19 | , sop >= 0.5.0 20 | , elab-util >= 0.5.0 21 | , tls >= 0.0.1 22 | 23 | -- modules = 24 | 25 | main = Test 26 | executable = runtests 27 | 28 | opts = "-Wno-shadowing" 29 | sourcedir = "src" 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2024 octeep , tensorknower69 2 | 3 | Permission to use, copy, modify, and distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /support/Makefile: -------------------------------------------------------------------------------- 1 | TARGET = libidristls 2 | TARGET_VERSION ?= 0.0.1 3 | 4 | INSTALLDIR = ../lib 5 | 6 | LDFLAGS = 7 | CPPFLAGS = 8 | 9 | CC_VERSION = $(shell $(CC) --version) 10 | 11 | ifeq ($(findstring clang,$(CC_VERSION)),clang) 12 | DYLIB_WORKAROUND = cp "${INSTALLDIR}/${TARGET}" "${INSTALLDIR}/${TARGET}.dylib" 13 | else 14 | DYLIB_WORKAROUND = cp "${INSTALLDIR}/${TARGET}" "${INSTALLDIR}/${TARGET}.so" 15 | LDFLAGS += -fuse-ld=gold 16 | endif 17 | 18 | SRCS = $(wildcard *.c) 19 | OBJS = $(SRCS:.c=.o) 20 | 21 | all: $(TARGET) 22 | 23 | $(TARGET): $(OBJS) 24 | $(CC) -shared $(LDFLAGS) -o $@ $^ 25 | 26 | .PHONY: clean 27 | 28 | clean : 29 | rm -f $(OBJS) $(TARGET) 30 | rm -rf $(INSTALLDIR) 31 | 32 | .PHONY: install 33 | 34 | install: 35 | mkdir -p $(INSTALLDIR) 36 | install $(TARGET) $(wildcard *.h) $(INSTALLDIR) 37 | $(DYLIB_WORKAROUND) 38 | -------------------------------------------------------------------------------- /tests/src/Test.idr: -------------------------------------------------------------------------------- 1 | module Test 2 | 3 | import Data.List 4 | import System 5 | 6 | import RandomTest 7 | import CertTest 8 | import LTLS 9 | import Control.Monad.Error.Either 10 | 11 | %default partial 12 | 13 | run_test : String -> EitherT String IO () -> IO Bool 14 | run_test name test = do 15 | Right () <- runEitherT test 16 | | Left err => putStrLn "\{name}: failed \{err}" $> False 17 | putStrLn "\{name}: success" $> True 18 | 19 | run : List (IO Bool) -> IO () 20 | run tests = do 21 | results <- sequence tests 22 | let [] = filter not results 23 | | xs => putStrLn "\{show (length xs)} tests failed" *> exitFailure 24 | putStrLn "all tests passed" 25 | 26 | export 27 | main : IO () 28 | main = run 29 | [ (run_test "csprng" test_random) 30 | , (run_test "certstore" test_cert) 31 | , (run_test "tls connection" tls_test_unit) 32 | ] 33 | -------------------------------------------------------------------------------- /src/Crypto/Random/JS.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Random.JS 2 | 3 | import Crypto.Random 4 | import System.FFI 5 | import Data.Vect 6 | import Utils.Misc 7 | import Data.Buffer 8 | import System.Info 9 | 10 | %foreign "node:lambda:n => require('crypto').randomBytes(n)" 11 | prim_io__randomBytes : Int -> PrimIO Buffer 12 | 13 | -- Test this 14 | %foreign "javascript:lambda:n => crypto.getRandomValues(new Uint8Array(n))" 15 | prim_io__getRandomValues : Int -> PrimIO Buffer 16 | 17 | buffer_content : HasIO io => (Int -> PrimIO Buffer) -> (n : Nat) -> io (Vect n Bits8) 18 | buffer_content f n = do 19 | buffer <- primIO $ f (cast n) 20 | traverse (getBits8 buffer) $ map (cast . finToNat) range 21 | 22 | public export 23 | HasIO io => MonadRandom io where 24 | random_bytes Z = pure [] 25 | random_bytes n = 26 | case codegen of 27 | "node" => buffer_content prim_io__randomBytes n 28 | "javascript" => buffer_content prim_io__getRandomValues n 29 | _ => assert_total $ idris_crash "no random backend availible" 30 | -------------------------------------------------------------------------------- /src/Utils/Num.idr: -------------------------------------------------------------------------------- 1 | module Utils.Num 2 | 3 | import Data.Vect 4 | 5 | alphabets : Vect 36 Char 6 | alphabets = fromList $ unpack "0123456789abcdefghijklmnopqrstuvwxyz" 7 | 8 | -- Use integer for performance reason 9 | export 10 | stringToNat' : Fin 36 -> String -> Maybe Integer 11 | stringToNat' base str = if str == "" then Nothing else go (finToInteger base) 1 0 $ reverse $ unpack str 12 | where 13 | go : Integer -> Integer -> Integer -> List Char -> Maybe Integer 14 | go base' yoyo acc [] = Just acc 15 | go base' yoyo acc (chr :: xs) = do 16 | i <- elemIndex chr alphabets 17 | if i < base then go base' (base' * yoyo) (acc + finToInteger i * yoyo) xs else Nothing 18 | 19 | export 20 | stringToNat : Fin 36 -> String -> Maybe Nat 21 | stringToNat base string = integerToNat <$> stringToNat' base string 22 | 23 | export 24 | stringToInteger : Fin 36 -> String -> Maybe Integer 25 | stringToInteger base str = 26 | case strUncons str of 27 | Just ('-', num) => negate <$> stringToNat' base num 28 | Just ('+', num) => stringToNat' base num 29 | _ => stringToNat' base str 30 | -------------------------------------------------------------------------------- /src/Utils/ConstantTable.idr: -------------------------------------------------------------------------------- 1 | module Utils.ConstantTable 2 | 3 | import Data.Vect 4 | import Data.Fin 5 | import Data.IOArray.Prims 6 | import PrimIO 7 | 8 | ||| A constant table that can be read in O(1) time 9 | export 10 | data ConstantTable : Nat -> Type -> Type where 11 | MkFromArray : ArrayData e -> ConstantTable (S n) e 12 | 13 | export 14 | length : {n : Nat} -> ConstantTable n e -> Nat 15 | length _ = n 16 | 17 | export 18 | index : Fin (S n) -> ConstantTable (S n) a -> a 19 | index n (MkFromArray array) = unsafePerformIO $ primIO $ prim__arrayGet array (cast $ finToInteger n) 20 | 21 | export 22 | index_bits8 : Bits8 -> ConstantTable 256 a -> a 23 | index_bits8 n (MkFromArray array) = unsafePerformIO $ primIO $ prim__arrayGet array (cast n) 24 | 25 | export 26 | from_vect : {n : Nat} -> Vect (S n) a -> ConstantTable (S n) a 27 | from_vect (x :: xs) = unsafePerformIO $ do 28 | array <- primIO $ prim__newArray (cast (S n)) x 29 | let indexed_array = zip (drop 1 Fin.range) xs 30 | traverse_ (\(i,v) => primIO $ prim__arraySet array (cast $ finToInteger i) v) indexed_array 31 | pure $ MkFromArray array 32 | -------------------------------------------------------------------------------- /src/Crypto/Hash.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Hash 2 | 3 | import Data.Bits 4 | import Data.List 5 | import Data.Nat 6 | import Data.Vect 7 | import public Crypto.Hash.Interfaces 8 | import public Crypto.Hash.SHA2 9 | import public Crypto.Hash.SHA1 10 | import public Crypto.Hash.MD5 11 | 12 | ||| basically `Hash.initialize` but with explicit type argument 13 | public export 14 | init : (0 algo : Type) -> Hash algo => algo 15 | init algo = initialize 16 | 17 | ||| hash a sequence of bytes and produce a digest 18 | public export 19 | hash : (0 algo : Type) -> Hash algo => (message : List Bits8) -> Vect (digest_nbyte {algo}) Bits8 20 | hash algo xs = finalize $ update xs $ Hash.init algo 21 | 22 | ||| basically `MAC.initialize` but with explicit type argument 23 | public export 24 | init_mac : (0 algo : Type) -> MAC key algo => key -> algo 25 | init_mac algo key = initialize_mac key 26 | 27 | ||| hash a sequence of bytes with key and produce a digest 28 | public export 29 | mac : (0 algo : Type) -> MAC key algo => key -> (message : List Bits8) -> Vect (digest_nbyte {algo}) Bits8 30 | mac algo key xs = finalize $ update xs $ Hash.init_mac algo key 31 | -------------------------------------------------------------------------------- /src/Crypto/Hash/HMAC.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Hash.HMAC 2 | 3 | import Crypto.Hash 4 | import Data.Bits 5 | import Data.List 6 | import Data.Vect 7 | 8 | export 9 | data HMAC : Type -> Type where 10 | MkHMAC : (o_key_pad : List Bits8) -> algo -> HMAC algo 11 | 12 | process_key : (0 algo : Type) -> Hash algo => List Bits8 -> List Bits8 13 | process_key algo key = 14 | if length key > block_nbyte {algo} 15 | then toList $ hash algo key 16 | else key <+> (List.replicate (minus (block_nbyte {algo}) $ length key) 0) 17 | 18 | export 19 | Hash algo => Digest (HMAC algo) where 20 | digest_nbyte = digest_nbyte {algo} 21 | finalize (MkHMAC o_key_pad underlying) = hash algo $ o_key_pad <+> toList (finalize underlying) 22 | update message (MkHMAC o_key_pad underlying) = MkHMAC o_key_pad $ update message underlying 23 | 24 | export 25 | Hash algo => MAC (List Bits8) (HMAC algo) where 26 | initialize_mac key = 27 | let key = HMAC.process_key algo key 28 | o_key_pad = zipWith xor key $ replicate (block_nbyte {algo}) 0x5c 29 | i_key_pad = zipWith xor key $ replicate (block_nbyte {algo}) 0x36 30 | in MkHMAC o_key_pad (update i_key_pad initialize) 31 | -------------------------------------------------------------------------------- /tests/src/RandomTest.idr: -------------------------------------------------------------------------------- 1 | module RandomTest 2 | 3 | import Crypto.Random 4 | import Crypto.Random.C 5 | import Data.Vect 6 | import Data.Fin 7 | import Control.Monad.Error.Either 8 | 9 | %default partial 10 | 11 | b8_to_fin : Bits8 -> Fin 256 12 | b8_to_fin b = case natToFin (cast b) 256 of Just x => x 13 | 14 | incr : Vect 256 Bits32 -> Bits8 -> Vect 256 Bits32 15 | incr vect byte = updateAt (b8_to_fin byte) (+1) vect 16 | 17 | mean : (Cast a Double, Num a) => {n : Nat} -> Vect n a -> Double 18 | mean vect = (sum $ map cast vect) / (cast n) 19 | 20 | export 21 | test_random : EitherT String IO () 22 | test_random = do 23 | let random_bytes_size = 262144.0 24 | data' <- random_bytes (cast random_bytes_size) 25 | let distribution = foldl incr (replicate _ 0) data' 26 | let delta_mean = abs (mean data' - 128) 27 | let True = delta_mean < 2 28 | | False => throwE "random generated bytes mean deviates too far from 128: \{show delta_mean}" 29 | 30 | let expected_mean = random_bytes_size / 256.0 31 | let delta_distri_mean = abs (mean distribution - expected_mean) 32 | let True = delta_distri_mean < 1.5 33 | | False => throwE "random generated bytes distribution mean deviates too far from \{show expected_mean}: \{show delta_mean}" 34 | 35 | pure () 36 | -------------------------------------------------------------------------------- /support/idristls.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #if defined(_WIN32) || defined(_WIN64) 4 | #define __WINDOWS__ 1 5 | #endif 6 | 7 | #ifdef __linux__ 8 | #include 9 | #endif 10 | 11 | #if __WINDOWS__ 12 | #include 13 | #include 14 | #include 15 | #include 16 | #endif 17 | 18 | int random_buf(void *buf, size_t nbytes) { 19 | #ifdef __linux__ 20 | ssize_t out = getrandom(buf, nbytes, 0); 21 | return out < 0; 22 | #elif __WINDOWS__ 23 | NTSTATUS status = BCryptGenRandom(NULL, buf, nbytes, BCRYPT_USE_SYSTEM_PREFERRED_RNG); 24 | return !BCRYPT_SUCCESS(status); 25 | #else 26 | arc4random_buf(buf, nbytes); 27 | return 0; 28 | #endif 29 | } 30 | 31 | #ifdef __WINDOWS__ 32 | void* openCertStore() { 33 | return CertOpenSystemStoreA(0, "ROOT"); 34 | } 35 | 36 | int closeCertStore(void* hCertStore) { 37 | return CertCloseStore(hCertStore, 0); 38 | } 39 | 40 | const void* nextCertInStore(void* hCertStore, void* prevCert) { 41 | return CertEnumCertificatesInStore(hCertStore, prevCert); 42 | } 43 | 44 | int32_t certLenInfo(PCCERT_CONTEXT cert) { 45 | if (cert->dwCertEncodingType != 1) { 46 | return -1; 47 | } 48 | 49 | return cert->cbCertEncoded; 50 | } 51 | 52 | void certBody(PCCERT_CONTEXT cert, void* buf) { 53 | memcpy(buf, cert->pbCertEncoded, cert->cbCertEncoded); 54 | } 55 | #endif 56 | -------------------------------------------------------------------------------- /src/Utils/Handle/C.idr: -------------------------------------------------------------------------------- 1 | module Utils.Handle.C 2 | 3 | import Control.Linear.LIO 4 | import Control.Monad.Error.Either 5 | import Data.Nat 6 | import Data.Vect 7 | import Network.Socket 8 | import Utils.Handle 9 | 10 | -- Needed for some reason, sometimes the socket does not read enough bytes 11 | recv_n_bytes : HasIO m => Socket -> Nat -> List Bits8 -> m (Either SocketError (List Bits8)) 12 | recv_n_bytes sock Z buf = pure (Right []) 13 | recv_n_bytes sock size buf = do 14 | Right response <- recvBytes sock $ cast $ minus size $ length buf 15 | | error => pure error 16 | let buf = buf <+> response 17 | if (length buf) >= size 18 | then pure $ Right buf 19 | else recv_n_bytes sock size buf 20 | 21 | ||| Turning a non-linear socket from Network.Socket into a Handle tailored for Network.TLS.Handle 22 | export 23 | socket_to_handle : Socket -> Handle' Socket () 24 | socket_to_handle sock = MkHandle 25 | sock 26 | (\(MkSocket _ _ _ _), wanted => do 27 | Right output <- recv_n_bytes sock wanted [] 28 | | Left code => pure1 $ False # ("recv_bytes failed with code " <+> show code # ()) 29 | pure1 $ True # (output # sock) 30 | ) 31 | (\(MkSocket _ _ _ _), input => do 32 | Right _ <- sendBytes sock input 33 | | Left code => pure1 $ False # ("send_bytes failed with code " <+> show code # ()) 34 | pure1 $ True # sock 35 | ) 36 | (\(MkSocket _ _ _ _) => do 37 | Socket.close sock 38 | pure1 () 39 | ) 40 | -------------------------------------------------------------------------------- /src/Crypto/Curve.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Curve 2 | 3 | import Crypto.Random 4 | import Data.Bits 5 | import Utils.Misc 6 | 7 | public export 8 | interface Point p where 9 | to_affine : p -> (Integer, Integer) 10 | generator : p 11 | infinity : p 12 | bits : Nat 13 | modulus : Integer 14 | order : Integer 15 | 16 | point_add : p -> p -> p 17 | mul : Integer -> p -> p 18 | 19 | encode : p -> List Bits8 20 | decode : List Bits8 -> Maybe p 21 | 22 | Point p => Eq p where 23 | (==) a b = (to_affine a) == (to_affine b) 24 | 25 | public export 26 | data ECDSASignature : (p : Type) -> Type where 27 | MkSignature : (Point p) => p -> (Integer, Integer) -> ECDSASignature p 28 | 29 | public export 30 | ecdsa_sign : (Point p, MonadRandom m) => (sk : Integer) -> (msg : Integer) -> m (ECDSASignature p) 31 | ecdsa_sign {p} private_key message = do 32 | k <- uniform_random' 1 (order {p} - 1) 33 | let public_key = mul private_key generator {p} 34 | let (x, y) = to_affine $ mul k generator {p} 35 | let r = x `mod` (order {p}) 36 | let s = mul_mod (inv_mul_mod k $ order {p}) (message + (r * private_key)) (order {p}) 37 | if (r == 0) || (s == 0) 38 | then ecdsa_sign {p} private_key message 39 | else pure $ MkSignature public_key (r, s) 40 | 41 | within_interval : Point p => Integer -> Bool 42 | within_interval n = n > 0 && n < (order {p}) 43 | 44 | public export 45 | ecdsa_verify : Integer -> ECDSASignature p -> Bool 46 | ecdsa_verify message (MkSignature public_key (r, s)) = 47 | let n = order {p} 48 | s_inv = inv_mul_mod s n 49 | u1 = mul_mod message s_inv n 50 | u2 = mul_mod r s_inv n 51 | pt = point_add (mul u1 generator) (mul u2 public_key) 52 | (x, _) = to_affine pt 53 | in within_interval {p} r && within_interval {p} s && (infinity /= pt) && (r `mod'` n) == (x `mod'` n) 54 | -------------------------------------------------------------------------------- /src/Network/TLS/Wrapper.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.Wrapper 2 | 3 | import Data.Nat 4 | import Utils.Misc 5 | import Data.Vect 6 | import Data.List 7 | import Network.TLS.Magic 8 | 9 | public export 10 | record Wrapper (mac_size : Nat) where 11 | constructor MkWrapper 12 | encrypted_data : List Bits8 13 | auth_tag : Vect mac_size Bits8 14 | 15 | public export 16 | to_application_data : Wrapper mac_size -> List Bits8 17 | to_application_data x = x.encrypted_data <+> toList x.auth_tag 18 | 19 | public export 20 | from_application_data : {mac_size : _} -> (application_data : List Bits8) -> Maybe (Wrapper mac_size) 21 | from_application_data xs = 22 | let xs' = fromList xs in 23 | case isLTE mac_size (length xs) of 24 | Yes prf => 25 | let 26 | (encrypted_data, auth_tag) = splitAt (minus (length xs) mac_size) $ replace_vect (sym $ plusMinusLte _ _ prf) xs' 27 | in 28 | Just $ MkWrapper (toList encrypted_data) auth_tag 29 | No contra => Nothing 30 | 31 | public export 32 | record Wrapper2 (iv_size : Nat) (mac_size : Nat) where 33 | constructor MkWrapper2 34 | iv_data : Vect iv_size Bits8 35 | encrypted_data : List Bits8 36 | auth_tag : Vect mac_size Bits8 37 | 38 | public export 39 | to_application_data2 : Wrapper2 iv_size mac_size -> List Bits8 40 | to_application_data2 x = toList x.iv_data <+> x.encrypted_data <+> toList x.auth_tag 41 | 42 | public export 43 | from_application_data2 : {iv_size : _} -> {mac_size : _} -> (application_data : List Bits8) -> Maybe (Wrapper2 iv_size mac_size) 44 | from_application_data2 xs = do 45 | let (iv, ciphertext) = splitAt iv_size xs 46 | iv' <- exactLength iv_size $ fromList iv 47 | w <- from_application_data ciphertext 48 | pure $ MkWrapper2 iv' w.encrypted_data w.auth_tag 49 | 50 | namespace WrappedRecord 51 | public export 52 | record WrappedRecord where 53 | constructor MkWrappedRecord 54 | record_type : RecordType 55 | wrapped_data : List Bits8 56 | 57 | public export 58 | to_application_data : WrappedRecord -> List Bits8 59 | to_application_data x = x.wrapped_data <+> [record_type_to_id x.record_type] 60 | -------------------------------------------------------------------------------- /src/Network/TLS/Parse/PEM.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.Parse.PEM 2 | 3 | import Control.Monad.Trans 4 | import Data.String 5 | import Data.String.Extra 6 | import Data.String.Parser 7 | import Utils.Base64 8 | import Utils.Bytes 9 | import Utils.Misc 10 | 11 | public export 12 | record PEMBlob where 13 | constructor MkPEMBlob 14 | label : String 15 | content : List Bits8 16 | 17 | public export 18 | Show PEMBlob where 19 | show (MkPEMBlob label content) = label <+> ": " <+> xxd content 20 | 21 | is_label_char : Char -> Bool 22 | is_label_char c = (not (isControl c)) && (c /= '-') 23 | 24 | label_char : Applicative m => ParseT m Char 25 | label_char = satisfy is_label_char "expected label character" 26 | 27 | base64_char : Applicative m => ParseT m Char 28 | base64_char = satisfy is_base64_char "expected base64 character" 29 | 30 | takeUntil : Monad m => (stop : String) -> ParseT m () 31 | takeUntil stop = do 32 | let StrCons s top = strM stop 33 | | StrNil => pure () 34 | takeUntil' s top 35 | where 36 | takeUntil' : Monad m' => (s : Char) -> (top : String) -> ParseT m' () 37 | takeUntil' s top = do 38 | init <- takeWhile (/= s) 39 | skip $ char s "end of string reached - \{show stop} not found" 40 | case !(succeeds $ string top) of 41 | False => takeUntil' s top 42 | True => pure () 43 | 44 | export 45 | parse_pem_blob : Parser PEMBlob 46 | parse_pem_blob = do 47 | takeUntil "-----BEGIN " 48 | label' <- many label_char 49 | let label = pack label' 50 | _ <- string "-----" 51 | spaces 52 | content <- many ((some base64_char) <* spaces) 53 | _ <- string "-----END " 54 | _ <- string label 55 | _ <- string "-----" 56 | spaces 57 | case base64_decode $ pack $ concat content of 58 | Right str => pure $ MkPEMBlob label str 59 | Left err => fail $ "failed parsing PEM content: " <+> err 60 | 61 | fold_string : String -> String 62 | fold_string str = pack $ foldl (<+>) [] $ map (<+> ['\n']) $ chunk 64 $ unpack str 63 | 64 | export 65 | encode_pem_blob : PEMBlob -> String 66 | encode_pem_blob blob = 67 | "-----BEGIN " <+> blob.label <+> "-----\n" 68 | <+> (fold_string $ base64_encode blob.content) 69 | <+> "-----END " <+> blob.label <+> "-----" 70 | -------------------------------------------------------------------------------- /src/Crypto/ECDH.idr: -------------------------------------------------------------------------------- 1 | module Crypto.ECDH 2 | 3 | import Crypto.Random 4 | import Crypto.Curve.XCurves 5 | import Crypto.Curve 6 | import Data.Vect 7 | import Utils.Misc 8 | import Utils.Bytes 9 | 10 | public export 11 | interface ECDHCyclicGroup (0 a : Type) where 12 | Scalar : Type 13 | Element : Type 14 | diffie_hellman : Scalar -> Element -> Maybe (List Bits8) 15 | generate_key_pair : MonadRandom m => m (Scalar,Element) 16 | 17 | deserialize_pk : List Bits8 -> Maybe Element 18 | serialize_pk : Element -> List Bits8 19 | 20 | public export 21 | deserialize_then_dh : ECDHCyclicGroup dh => Scalar {a=dh} -> List Bits8 -> Maybe (List Bits8) 22 | deserialize_then_dh sk pk = (deserialize_pk {a=dh} pk) >>= (diffie_hellman sk) 23 | 24 | public export 25 | data X25519_DH : Type where 26 | 27 | public export 28 | ECDHCyclicGroup X25519_DH where 29 | Scalar = Vect 32 Bits8 30 | Element = Vect 32 Bits8 31 | diffie_hellman sk pk = map toList (XCurves.mul x25519 sk pk) 32 | generate_key_pair = do 33 | sk <- random_bytes 32 34 | let Just pk = derive_public_key x25519 sk 35 | | Nothing => generate_key_pair {a=X25519_DH} 36 | pure (sk,pk) 37 | deserialize_pk content = exactLength 32 $ fromList content 38 | serialize_pk = toList 39 | 40 | public export 41 | data X448_DH : Type where 42 | 43 | public export 44 | ECDHCyclicGroup X448_DH where 45 | Scalar = Vect 56 Bits8 46 | Element = Vect 56 Bits8 47 | diffie_hellman sk pk = map toList (XCurves.mul x448 sk pk) 48 | generate_key_pair = do 49 | sk <- random_bytes 56 50 | let Just pk = derive_public_key x448 sk 51 | | Nothing => generate_key_pair {a=X448_DH} 52 | pure (sk,pk) 53 | deserialize_pk content = exactLength 56 $ fromList content 54 | serialize_pk = toList 55 | 56 | public export 57 | {p : _} -> Point p => ECDHCyclicGroup p where 58 | Scalar = Integer 59 | Element = p 60 | diffie_hellman sk pk = 61 | let (x, _) = to_affine $ mul sk pk 62 | bytes = divCeilNZ (bits {p=p}) 8 SIsNonZero 63 | in Just $ toList $ integer_to_be bytes x 64 | generate_key_pair = do 65 | sk <- uniform_random' 2 (order {p=p} - 1) 66 | let pk = mul sk $ generator {p=p} 67 | pure (sk,pk) 68 | deserialize_pk = decode {p=p} 69 | serialize_pk = encode {p=p} 70 | -------------------------------------------------------------------------------- /src/Utils/Handle.idr: -------------------------------------------------------------------------------- 1 | module Utils.Handle 2 | 3 | import Data.Vect 4 | import Data.Nat 5 | import Control.Monad.Error.Either 6 | import Control.Linear.LIO 7 | 8 | public export 9 | ReadHack : (t_ok : Type) -> (t_read_failed : Type) -> Bool -> Type 10 | ReadHack t_ok t_read_failed False = t_read_failed 11 | ReadHack t_ok t_read_failed True = Res (List Bits8) (const t_ok) 12 | 13 | public export 14 | WriteHack : (t_ok : Type) -> (t_write_failed : Type) -> Bool -> Type 15 | WriteHack t_ok t_write_failed False = t_write_failed 16 | WriteHack t_ok t_write_failed True = t_ok 17 | 18 | public export 19 | record Handle (t_ok : Type) (t_closed : Type) (t_read_failed : Type) (t_write_failed : Type) where 20 | constructor MkHandle 21 | 1 underlying : t_ok 22 | do_read : forall m. LinearIO m => (1 _ : t_ok) -> (len : Nat) -> L1 m $ Res Bool $ ReadHack t_ok t_read_failed 23 | do_write : forall m. LinearIO m => (1 _ : t_ok) -> List Bits8 -> L1 m $ Res Bool $ WriteHack t_ok t_write_failed 24 | do_close : forall m. LinearIO m => (1 _ : t_ok) -> L1 m t_closed 25 | 26 | public export 27 | close : LinearIO m => (1 _ : Handle t_ok t_closed t_read_failed t_write_failed) -> L1 m t_closed 28 | close (MkHandle x do_read do_write do_close) = do_close x 29 | 30 | public export 31 | read : LinearIO m => (1 _ : Handle t_ok t_closed t_read_failed t_write_failed) -> (len : Nat) -> L1 m $ Res Bool $ \case 32 | False => t_read_failed 33 | True => Res (List Bits8) (\_ => Handle t_ok t_closed t_read_failed t_write_failed) 34 | read (MkHandle x do_read do_write do_close) len = do 35 | (True # (output # x)) <- do_read x len 36 | | (False # x) => pure1 $ False # x 37 | pure1 $ True # (output # MkHandle x do_read do_write do_close) 38 | 39 | public export 40 | write : LinearIO m => (1 _ : Handle t_ok t_closed t_read_failed t_write_failed) -> (input : List Bits8) -> L1 m $ Res Bool $ \case 41 | False => t_write_failed 42 | True => Handle t_ok t_closed t_read_failed t_write_failed 43 | write (MkHandle x do_read do_write do_close) input = do 44 | (True # x) <- do_write x input 45 | | (False # x) => pure1 $ False # x 46 | pure1 $ True # MkHandle x do_read do_write do_close 47 | 48 | public export 49 | Handle' : Type -> Type -> Type 50 | Handle' t_ok t_closed = Handle t_ok t_closed (Res String $ const t_closed) (Res String $ const t_closed) 51 | -------------------------------------------------------------------------------- /tls.ipkg: -------------------------------------------------------------------------------- 1 | package tls 2 | 3 | version = 0.0.1 4 | 5 | authors = "tensorknower69, octeep" 6 | 7 | readme = "README.md" 8 | 9 | homepage = "https://github.com/octeep/idris2-tls" 10 | sourceloc = "https://github.com/octeep/idris2-tls.git" 11 | bugtracker = "https://github.com/octeep/idris2-tls/issues" 12 | 13 | license = "ISC (refer to LICENSE file)" 14 | brief = "A portable idris2 implementation of TLS" 15 | 16 | depends = base >= 0.6.0 17 | , contrib >= 0.6.0 18 | , network >= 0.6.0 19 | , sop >= 0.6.0 20 | , elab-util >= 0.6.0 21 | 22 | modules = Crypto.RSA, 23 | Crypto.ChaCha, 24 | Crypto.Curve, 25 | Crypto.Curve.Weierstrass, 26 | Crypto.Curve.XCurves, 27 | Crypto.ECDH, 28 | Crypto.Random, 29 | Crypto.Hash, 30 | Crypto.Hash.Interfaces, 31 | Crypto.Hash.SHA2, 32 | Crypto.Hash.OID, 33 | Crypto.Hash.SHA1, 34 | Crypto.Hash.MerkleDamgard, 35 | Crypto.Hash.MD5, 36 | Crypto.Hash.HMAC, 37 | Crypto.Hash.GHash, 38 | Crypto.Hash.Poly1305, 39 | Crypto.AES.Big, 40 | Crypto.AES.Small, 41 | Crypto.AES.Common, 42 | Crypto.Random.C, 43 | Crypto.Random.JS, 44 | Network.TLS, 45 | Network.TLS.Core, 46 | Network.TLS.Handshake, 47 | Network.TLS.HelloExtension, 48 | Network.TLS.Magic, 49 | Network.TLS.Parsing, 50 | Network.TLS.Record, 51 | Network.TLS.Wrapper, 52 | Network.TLS.HKDF, 53 | Network.TLS.Handle, 54 | Network.TLS.AEAD, 55 | Network.TLS.Parse.DER, 56 | Network.TLS.Parse.PEM, 57 | Network.TLS.Signature, 58 | Network.TLS.Certificate, 59 | Network.TLS.Certificate.System, 60 | Network.TLS.Verify, 61 | Utils.Base64, 62 | Utils.Bytes, 63 | Utils.Misc, 64 | Utils.Handle, 65 | Utils.Parser, 66 | Utils.Num, 67 | Utils.Show, 68 | Utils.Handle.C, 69 | Utils.Time, 70 | Utils.IPAddr, 71 | Utils.ConstantTable 72 | 73 | opts = "-Wno-shadowing" 74 | 75 | sourcedir = "src" 76 | 77 | prebuild = "make -C support all" 78 | 79 | preinstall = "make -C support install" -------------------------------------------------------------------------------- /src/Crypto/Hash/OID.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Hash.OID 2 | 3 | import Crypto.Hash.Interfaces 4 | import Crypto.Hash 5 | import Data.Vect 6 | 7 | {- 8 | For the nine hash functions mentioned in Appendix B.1, the DER 9 | encoding T of the DigestInfo value is equal to the following: 10 | 11 | MD2: (0x)30 20 30 0c 06 08 2a 86 48 86 f7 0d 02 02 05 00 04 12 | 10 || H. 13 | MD5: (0x)30 20 30 0c 06 08 2a 86 48 86 f7 0d 02 05 05 00 04 14 | 10 || H. 15 | SHA-1: (0x)30 21 30 09 06 05 2b 0e 03 02 1a 05 00 04 14 || H. 16 | SHA-224: (0x)30 2d 30 0d 06 09 60 86 48 01 65 03 04 02 04 17 | 05 00 04 1c || H. 18 | SHA-256: (0x)30 31 30 0d 06 09 60 86 48 01 65 03 04 02 01 05 00 19 | 04 20 || H. 20 | SHA-384: (0x)30 41 30 0d 06 09 60 86 48 01 65 03 04 02 02 05 00 21 | 04 30 || H. 22 | SHA-512: (0x)30 51 30 0d 06 09 60 86 48 01 65 03 04 02 03 05 00 23 | 04 40 || H. 24 | SHA-512/224: (0x)30 2d 30 0d 06 09 60 86 48 01 65 03 04 02 05 25 | 05 00 04 1c || H. 26 | SHA-512/256: (0x)30 31 30 0d 06 09 60 86 48 01 65 03 04 02 06 27 | 05 00 04 20 || H. 28 | -} 29 | 30 | public export 31 | interface Hash algo => RegisteredHash algo where 32 | header_n_byte : Nat 33 | header : Vect header_n_byte Bits8 34 | 35 | public export 36 | der_digest_n_byte : {algo : _} -> RegisteredHash algo => Nat 37 | der_digest_n_byte = header_n_byte {algo} + digest_nbyte {algo} 38 | 39 | export 40 | hashWithHeader : {algo : _} -> RegisteredHash algo => List Bits8 -> Vect (der_digest_n_byte {algo}) Bits8 41 | hashWithHeader plaintext = header {algo} ++ hash algo plaintext 42 | 43 | public export 44 | RegisteredHash Sha1 where 45 | header_n_byte = 15 46 | header = [ 0x30, 0x21, 0x30, 0x09, 0x06, 0x05, 0x2b, 0x0e, 0x03, 0x02, 0x1a, 0x05, 0x00, 0x04, 0x14 ] 47 | 48 | public export 49 | RegisteredHash Sha256 where 50 | header_n_byte = 19 51 | header = [ 0x30, 0x31, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x01, 0x05, 0x00, 0x04, 0x20 ] 52 | 53 | public export 54 | RegisteredHash Sha384 where 55 | header_n_byte = 19 56 | header = [ 0x30, 0x41, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x02, 0x05, 0x00, 0x04, 0x30 ] 57 | 58 | public export 59 | RegisteredHash Sha512 where 60 | header_n_byte = 19 61 | header = [ 0x30, 0x51, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x03, 0x05, 0x00, 0x04, 0x40 ] 62 | -------------------------------------------------------------------------------- /src/Utils/Base64.idr: -------------------------------------------------------------------------------- 1 | module Utils.Base64 2 | 3 | import Data.Bits 4 | import Data.List 5 | import Data.Vect 6 | import Utils.Bytes 7 | import Utils.Misc 8 | 9 | %default total 10 | 11 | alphabets : Vect 64 Char 12 | alphabets = fromList $ unpack "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" 13 | 14 | padding : Char 15 | padding = '=' 16 | 17 | export 18 | is_base64_char : Char -> Bool 19 | is_base64_char c = isAlphaNum c || c == '+' || c == '/' || c == '=' 20 | 21 | lookup_base64_char : Char -> Maybe Bits8 22 | lookup_base64_char = map (cast . finToInteger) . flip elemIndex alphabets 23 | 24 | many_to_bits8 : List Bits8 -> Either String (List Bits8) 25 | many_to_bits8 [] = Right [] 26 | many_to_bits8 [x] = Left "underfed, not enough base64 chars" 27 | many_to_bits8 [a, b] = Right [ (shiftL a 2) .|. (shiftR b 4) ] 28 | many_to_bits8 [a, b, c] = Right [ (shiftL a 2) .|. (shiftR b 4), (shiftL b 4) .|. (shiftR c 2) ] 29 | many_to_bits8 (a :: b :: c :: d :: xs) = map (four_to_three a b c d <+>) (many_to_bits8 xs) 30 | where 31 | four_to_three : Bits8 -> Bits8 -> Bits8 -> Bits8 -> List Bits8 32 | four_to_three a b c d = [(shiftL a 2) .|. (shiftR b 4), (shiftL b 4) .|. (shiftR c 2), (shiftL (c .&. 0b11) 6) .|. d] 33 | 34 | parse_base64 : List Char -> Either String (List Bits8) 35 | parse_base64 [] = pure [] 36 | parse_base64 ['='] = pure [] 37 | parse_base64 ['=', '='] = pure [] 38 | parse_base64 (c :: cs) = case lookup_base64_char c of 39 | Just b => [| pure b :: parse_base64 cs |] 40 | Nothing => Left $ "invalid base64 character: " <+> show c 41 | 42 | three_to_four : Bits8 -> Bits8 -> Bits8 -> List Char 43 | three_to_four a b c = 44 | let i = shiftR a 2 45 | j = (shiftL (a .&. 0b11) 4) .|. (shiftR b 4) 46 | k = (shiftL (b .&. 0b1111) 2) .|. (shiftR c 6) 47 | l = c .&. 0b111111 48 | ijkl = 49 | [ modFinNZ (cast i) 64 SIsNonZero 50 | , modFinNZ (cast j) 64 SIsNonZero 51 | , modFinNZ (cast k) 64 SIsNonZero 52 | , modFinNZ (cast l) 64 SIsNonZero 53 | ] 54 | in (\x => index x alphabets) <$> ijkl 55 | 56 | bits8_to_many : List Bits8 -> List Char 57 | bits8_to_many [] = [] 58 | bits8_to_many [a] = (take 2 $ three_to_four a 0 0) <+> [padding, padding] 59 | bits8_to_many [a, b] = (take 3 $ three_to_four a b 0) <+> [padding] 60 | bits8_to_many (a :: b :: c :: xs) = three_to_four a b c <+> bits8_to_many xs 61 | 62 | export 63 | base64_decode : String -> Either String (List Bits8) 64 | base64_decode = many_to_bits8 <=< parse_base64 . unpack 65 | 66 | export 67 | base64_encode : List Bits8 -> String 68 | base64_encode = pack . bits8_to_many 69 | -------------------------------------------------------------------------------- /src/Crypto/Random.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Random 2 | 3 | import Control.Monad.Error.Either 4 | import Control.Monad.State 5 | import Crypto.ChaCha 6 | import Data.Bits 7 | import Data.Fin 8 | import Data.List 9 | import Data.Nat 10 | import Data.Stream 11 | import Data.Vect 12 | import Utils.Bytes 13 | import Utils.Misc 14 | 15 | public export 16 | interface DRG (0 a : Type) where 17 | next_bytes : (n : Nat) -> a -> (a, Vect n Bits8) 18 | 19 | public export 20 | interface Monad m => MonadRandom (0 m : Type -> Type) where 21 | random_bytes : (n : Nat) -> m (Vect n Bits8) 22 | 23 | public export 24 | {s : _} -> DRG s => MonadRandom (State s) where 25 | random_bytes n = state (next_bytes n) 26 | 27 | public export 28 | next_integer : MonadRandom m => Nat -> m Integer 29 | next_integer bytes = do 30 | randoms <- random_bytes bytes 31 | pure $ foldr (\(i,x),a => (shiftL {a=Integer} x i) .|. a) 0 $ zip ((*8) <$> [0..bytes]) (cast <$> toList randoms) 32 | 33 | bytes_needed : Integer -> Nat 34 | bytes_needed = (`div` 8) . cast . go 0 35 | where 36 | go : Nat -> Integer -> Nat 37 | go x n = if (n .&. ((bit x) - 1)) == n then x else go (x+8) n 38 | 39 | random_num_uniform : MonadRandom m => Nat -> Integer -> m Integer 40 | random_num_uniform bytes min = next_integer bytes >>= (\r => if r >= min then pure r else random_num_uniform bytes min) 41 | 42 | public export 43 | uniform_random : MonadRandom m => Integer -> m Integer 44 | uniform_random {m} upper_bound = 45 | if upper_bound < 0 then negate <$> (uniform_random {m=m} $ abs upper_bound) 46 | else if upper_bound < 2 then pure 0 47 | else 48 | let bytes = bytes_needed upper_bound 49 | in (`mod` upper_bound) <$> random_num_uniform bytes ((bit bytes) `mod` upper_bound) 50 | 51 | public export 52 | uniform_random' : MonadRandom m => Integer -> Integer -> m Integer 53 | uniform_random' {m} lower_bound upper_bound = do 54 | r <- uniform_random (upper_bound - lower_bound) 55 | pure (r + lower_bound) 56 | 57 | public export 58 | data ChaCha12DRG : Type where 59 | MkChaCha12DRG : (key : Vect 8 Bits32) -> ChaCha12DRG 60 | 61 | public export 62 | new_chacha12_drg : MonadRandom m => m ChaCha12DRG 63 | new_chacha12_drg {m} = (\r => MkChaCha12DRG (from_le <$> group 8 4 r)) <$> (random_bytes {m=m} 32) 64 | 65 | chacha12_stream : Vect 8 Bits32 -> Stream Bits8 66 | chacha12_stream key = stream_concat $ map go nats 67 | where 68 | go : Nat -> List Bits8 69 | go iv = toList $ chacha_rfc8439_block 6 (cast iv) key (map (cast . finToNat) range) 70 | 71 | public export 72 | DRG ChaCha12DRG where 73 | next_bytes Z state = (state, []) 74 | next_bytes bytes (MkChaCha12DRG key) = 75 | let stream = chacha12_stream key 76 | key = map (from_le {n=4}) $ group 8 4 $ take 32 stream 77 | stream = drop 32 stream 78 | in (MkChaCha12DRG key, take bytes stream) 79 | -------------------------------------------------------------------------------- /src/Crypto/ChaCha.idr: -------------------------------------------------------------------------------- 1 | module Crypto.ChaCha 2 | 3 | import Control.Monad.State 4 | import Data.Bits 5 | import Data.DPair 6 | import Data.Fin 7 | import Data.Fin.Extra 8 | import Data.Nat.Order.Properties 9 | import Data.Vect 10 | import Utils.Bytes 11 | import Utils.Misc 12 | 13 | public export 14 | Key : Type 15 | Key = Vect 8 Bits32 -- 32 * 8 = 256 16 | 17 | public export 18 | ChaChaState : Type 19 | ChaChaState = Vect 16 Bits32 20 | 21 | -- The first four words (0-3) are constants 22 | public export 23 | constants : Vect 4 Bits32 24 | constants = [0x61707865, 0x3320646e, 0x79622d32, 0x6b206574] -- ['expa', 'nd 3', '2-by', 'te k'] 25 | 26 | public export 27 | quarter_rotate : Fin 16 -> Fin 16 -> Fin 16 -> Fin 16 -> State ChaChaState () 28 | quarter_rotate a b c d = do 29 | modify (\s => updateAt a (+ index b s) s) 30 | modify (\s => updateAt d (`xor` index a s) s) 31 | modify (\s => updateAt d (rotl 16) s) 32 | 33 | modify (\s => updateAt c (+ index d s) s) 34 | modify (\s => updateAt b (`xor` index c s) s) 35 | modify (\s => updateAt b (rotl 12) s) 36 | 37 | modify (\s => updateAt a (+ index b s) s) 38 | modify (\s => updateAt d (`xor` index a s) s) 39 | modify (\s => updateAt d (rotl 8) s) 40 | 41 | modify (\s => updateAt c (+ index d s) s) 42 | modify (\s => updateAt b (`xor` index c s) s) 43 | modify (\s => updateAt b (rotl 7) s) 44 | 45 | public export 46 | double_rotate : State ChaChaState () 47 | double_rotate = do 48 | quarter_rotate 0 4 8 12 49 | quarter_rotate 1 5 9 13 50 | quarter_rotate 2 6 10 14 51 | quarter_rotate 3 7 11 15 52 | ------------------------ 53 | quarter_rotate 0 5 10 15 54 | quarter_rotate 1 6 11 12 55 | quarter_rotate 2 7 8 13 56 | quarter_rotate 3 4 9 14 57 | 58 | public export 59 | run2x : (n_double_rounds : Nat) -> ChaChaState -> ChaChaState 60 | run2x n_double_rounds s = 61 | execState s $ do 62 | original <- get 63 | go last 64 | modify (zipWith (+) original) 65 | where 66 | go : Fin (S n_double_rounds) -> State ChaChaState () 67 | go FZ = pure () 68 | go (FS wit) = double_rotate *> go (weaken wit) 69 | 70 | ||| ChaCha construction with 4 octets counter and 12 octets nonce as per RFC8439 71 | public export 72 | chacha_rfc8439_block : Nat -> (counter : Bits32) -> Key -> Vect 3 Bits32 -> Vect 64 Bits8 73 | chacha_rfc8439_block rounds counter key nonce = concat $ map (to_le {n = 4}) $ run2x rounds $ constants ++ key ++ [counter] ++ nonce 74 | 75 | ||| ChaCha construction with 8 octets counter and 8 octets nonce as per the original ChaCha specification 76 | public export 77 | chacha_original_block : Nat -> (counter : Bits64) -> Key -> Vect 2 Bits32 -> Vect 64 Bits8 78 | chacha_original_block rounds counter key nonce = concat $ map (to_le {n = 4}) $ run2x rounds $ constants ++ key ++ split_word counter ++ nonce 79 | where 80 | split_word : Bits64 -> Vect 2 Bits32 81 | split_word a = [ cast a, cast (shiftR a 32) ] 82 | -------------------------------------------------------------------------------- /src/Crypto/Curve/XCurves.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Curve.XCurves 2 | 3 | -- This doesn't implement the Point interface because I can't be bothered will implementing 4 | -- point addition. This module is for DH strictly. 5 | 6 | import Data.Bits 7 | import Data.Bool.Xor 8 | import Data.Vect 9 | import Utils.Bytes 10 | import Utils.Misc 11 | 12 | data XCurvesParameter : (n : Nat) -> Type where 13 | XCParam : {n : Nat} -> 14 | (bits : Nat) -> 15 | (u : Integer) -> 16 | (a24 : Integer) -> 17 | (scalar_decoder : Vect n Bits8 -> Integer) -> 18 | (prime : Integer) -> 19 | XCurvesParameter n 20 | 21 | cswap : Integer -> Integer -> Integer -> (Integer, Integer) 22 | cswap swap x2 x3 = 23 | let dummy = (0 - swap) .&. (x2 `xor` x3) 24 | in (x2 `xor` dummy, x3 `xor` dummy) 25 | 26 | mul_go : {n : Nat} -> XCurvesParameter n -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Integer -> Nat -> 27 | (Integer, Integer, Integer, Integer, Integer) 28 | mul_go param@(XCParam _ _ a24 _ prime) x1 x2 z2 x3 z3 swap k t = 29 | let mul = (\a,b => mul_mod a b prime) 30 | pow = (\a,b => pow_mod a b prime) 31 | k_t = (shiftR k t) .&. 1 32 | swap' = xor swap k_t 33 | (x2, x3) = cswap swap' x2 x3 34 | (z2, z3) = cswap swap' z2 z3 35 | a = x2 + z2 36 | aa = a `mul` a 37 | b = x2 - z2 38 | bb = b `mul` b 39 | e = aa - bb 40 | c = x3 + z3 41 | d = x3 - z3 42 | da = d `mul` a 43 | cb = c `mul` b 44 | x3 = pow (da + cb) 2 45 | z3 = x1 `mul` (pow (da - cb) 2) 46 | x2 = aa `mul` bb 47 | z2 = e `mul` (aa + (a24 `mul` e)) 48 | in case t of 49 | Z => (x2, x3, z2, z3, k_t) 50 | S t' => mul_go param x1 x2 z2 x3 z3 k_t k t' 51 | 52 | public export 53 | mul : {n : Nat} -> XCurvesParameter n -> Vect n Bits8 -> Vect n Bits8 -> Maybe (Vect n Bits8) 54 | mul {n} param@(XCParam bits _ a24 decode prime) k u = 55 | let u' = le_to_integer u 56 | k' = decode k 57 | (x2, x3, z2, z3, swap) = mul_go param u' 1 0 u' 1 0 k' (minus bits 1) 58 | (x2', x3') = cswap swap x2 x3 59 | (z2', z3') = cswap swap z2 z3 60 | beta = pow_mod z2' (prime-2) prime 61 | secret = mul_mod x2' beta prime 62 | in guard (secret /= 0) *> (pure $ integer_to_le _ secret ) 63 | 64 | generator : {n : Nat} -> XCurvesParameter n -> Vect n Bits8 65 | generator (XCParam _ u _ _ _) = integer_to_le _ u 66 | 67 | public export 68 | derive_public_key : {n : Nat} -> XCurvesParameter n -> Vect n Bits8 -> Maybe (Vect n Bits8) 69 | derive_public_key param k = mul param k $ generator param 70 | 71 | decode_scalar_25519 : Vect 32 Bits8 -> Integer 72 | decode_scalar_25519 = 73 | le_to_integer 74 | . updateAt 0 (.&. 248) 75 | . updateAt 31 (.&. 127) 76 | . updateAt 31 (.|. 64) 77 | 78 | decode_scalar_448 : Vect 56 Bits8 -> Integer 79 | decode_scalar_448 = 80 | le_to_integer 81 | . updateAt 0 (.&. 252) 82 | . updateAt 55 (.|. 128) 83 | 84 | public export 85 | x25519 : XCurvesParameter 32 86 | x25519 = XCParam 255 9 121665 decode_scalar_25519 $ (bit 255) - 19 87 | 88 | public export 89 | x448 : XCurvesParameter 56 90 | x448 = XCParam 448 5 39081 decode_scalar_448 $ (bit 448) - (bit 224) - 1 91 | -------------------------------------------------------------------------------- /src/Crypto/Hash/SHA1.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Hash.SHA1 2 | 3 | import Crypto.Hash.Interfaces 4 | import Data.Bits 5 | import Data.DPair 6 | import Data.Fin 7 | import Data.Fin.Extra 8 | import Data.List 9 | import Data.Nat 10 | import Data.Nat.Factor 11 | import Data.Vect 12 | import Utils.Misc 13 | import Utils.Bytes 14 | import Data.Stream 15 | import Crypto.Hash.MerkleDamgard 16 | 17 | export 18 | data Sha1 : Type where 19 | MkSha1 : MerkleDamgard 5 64 Bits32 -> Sha1 20 | 21 | sha1_init_hash_values : Vect 5 Bits32 22 | sha1_init_hash_values = 23 | [ 0x67452301, 0xEFCDAB89, 0x98BADCFE, 0x10325476, 0xC3D2E1F0 ] 24 | 25 | sha1_extend_message : Vect 16 Bits32 -> Stream Bits32 26 | sha1_extend_message xs = prepend (toList xs) $ go xs 27 | where 28 | go : Vect 16 Bits32 -> Stream Bits32 29 | go xs = 30 | let 31 | [wi_16, wi_14, wi_8, wi_3] = the (Vect 4 _) $ map (flip index xs) [0, 2, 8, 13] 32 | w = rotl 1 (wi_16 `xor` wi_14 `xor` wi_8 `xor` wi_3) 33 | in 34 | w :: go (tail xs `snoc` w) 35 | 36 | sha1_compress : (block : Vect 64 Bits8) -> (h : Vect 5 Bits32) -> Vect 5 Bits32 37 | sha1_compress block hash_values = zipWith (+) hash_values $ go Z (sha1_extend_message $ map (from_be {a = Bits32} {n = 4}) $ group 16 4 block) hash_values 38 | where 39 | loop : Bits32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Vect 5 Bits32 40 | loop f k wi a b c d e = 41 | let temp = (rotl 5 a) + f + e + k + wi 42 | e = d 43 | d = c 44 | c = rotl 30 b 45 | b = a 46 | a = temp 47 | in [a, b, c, d, e] 48 | go : Nat -> Stream Bits32 -> Vect 5 Bits32 -> Vect 5 Bits32 49 | go n (wi :: ws) abc@[a, b, c, d, e] = 50 | case n `div` 20 of 51 | 0 => go (S n) ws $ loop ((b .&. c) .|. ((complement b) .&. d)) 0x5A827999 wi a b c d e 52 | 1 => go (S n) ws $ loop (b `xor` c `xor` d) 0x6ED9EBA1 wi a b c d e 53 | 2 => go (S n) ws $ loop ((b .&. c) .|. (b .&. d) .|. (c .&. d)) 0x8F1BBCDC wi a b c d e 54 | 3 => go (S n) ws $ loop (b `xor` c `xor` d) 0xCA62C1D6 wi a b c d e 55 | _ => abc 56 | 57 | sha1_update : List Bits8 -> Sha1 -> Sha1 58 | sha1_update input (MkSha1 s) = 59 | let 60 | Fraction _ 64 nblocks residue_nbyte prf = divMod (s.buffer_nbyte + length input) 64 61 | (blocks, residue) = splitAt (mult nblocks 64) (replace_vect (sym prf) (s.buffer ++ fromList input)) 62 | in 63 | MkSha1 $ {buffer := residue, buffer_nbyte := _, buffer_nbyte_constraint := elemSmallerThanBound residue_nbyte } 64 | ( foldl (\s_, block_ => {hash_values $= sha1_compress block_, npassed_blocks $= S} s_) s (group nblocks 64 blocks) ) 65 | 66 | sha1_finalize : Sha1 -> Vect 20 Bits8 67 | sha1_finalize (MkSha1 s) = 68 | concat $ map (to_be {n = 4}) $ 69 | case pad_theorem {block_nbyte = 64} {residue_max_nbyte = 55} {length_nbyte = 8} (LTESucc LTEZero) Refl s.buffer_nbyte_constraint s.buffer (integer_to_be _ $ 8 * (cast s.npassed_blocks * 64 + cast s.buffer_nbyte)) of 70 | Left block => sha1_compress block s.hash_values 71 | Right blocks => let (x1, x2) = splitAt 64 blocks in sha1_compress x2 $ sha1_compress x1 s.hash_values 72 | 73 | export 74 | Digest Sha1 where 75 | digest_nbyte = 20 76 | update = sha1_update 77 | finalize = sha1_finalize 78 | 79 | export 80 | Hash Sha1 where 81 | block_nbyte = 64 82 | initialize = MkSha1 $ mk_merkle_damgard sha1_init_hash_values 83 | -------------------------------------------------------------------------------- /src/Utils/IPAddr.idr: -------------------------------------------------------------------------------- 1 | module Utils.IPAddr 2 | 3 | import Data.String.Parser 4 | import Data.Vect 5 | import Data.Fin 6 | import Data.String.Extra 7 | import Data.String 8 | import Utils.Num 9 | import Utils.Misc 10 | import Data.List 11 | import Data.List1 12 | import Data.Bits 13 | import Utils.Bytes 14 | 15 | public export 16 | record IPv4Addr where 17 | constructor MkIPv4Addr 18 | body : Vect 4 Bits8 19 | 20 | public export 21 | Show IPv4Addr where 22 | show x = join "." $ map show x.body 23 | 24 | public export 25 | Eq IPv4Addr where 26 | x == y = x.body == y.body 27 | 28 | public export 29 | record IPv6Addr where 30 | constructor MkIPv6Addr 31 | body : Vect 16 Bits8 32 | 33 | bits16_show : Bits16 -> String 34 | bits16_show x = (show_hex (cast $ shiftR x 8)) <+> (show_hex $ cast x) 35 | 36 | to_hextets : IPv6Addr -> Vect 8 Bits16 37 | to_hextets addr = map from_be $ group 8 2 addr.body 38 | 39 | public export 40 | Show IPv6Addr where 41 | show x = assert_total $ join ":" $ map bits16_show (to_hextets x) 42 | 43 | public export 44 | Eq IPv6Addr where 45 | x == y = x.body == y.body 46 | 47 | read_decimal_byte : Monad m => ParseT m Bits8 48 | read_decimal_byte = do 49 | n <- natural 50 | if n < 256 51 | then pure $ cast n 52 | else fail "number out of bound" 53 | 54 | parse_ipv4' : Monad m => ParseT m IPv4Addr 55 | parse_ipv4' = do 56 | a <- read_decimal_byte 57 | _ <- char '.' 58 | b <- read_decimal_byte 59 | _ <- char '.' 60 | c <- read_decimal_byte 61 | _ <- char '.' 62 | d <- read_decimal_byte 63 | pure $ MkIPv4Addr [a, b, c, d] 64 | 65 | export 66 | parse_ipv4 : String -> Either String IPv4Addr 67 | parse_ipv4 = map fst . parse parse_ipv4' 68 | 69 | data IPv6R : Type -> Type where 70 | One : a -> IPv6R a 71 | Two : a -> a -> IPv6R a 72 | 73 | splitDoubleColon : String -> Either String (IPv6R String) 74 | splitDoubleColon str = do 75 | let (a ::: [b]) = split ((':', ':') ==) (f $ unpack str) 76 | | (a ::: []) => pure (One str) 77 | | _ => Left "too many double colons" 78 | pure $ Two (pack $ map fst a) (pack $ map snd b) 79 | where 80 | f : List Char -> List (Char, Char) 81 | f [] = [] 82 | f (x :: xs) = zip (x :: xs) xs 83 | 84 | parse_ipv6_to_octets : String -> Either String (IPv6R (List Bits16)) 85 | parse_ipv6_to_octets string = do 86 | Two a b <- splitDoubleColon string 87 | | One a => One <$> to a 88 | a <- to a 89 | b <- to b 90 | pure $ Two a b 91 | where 92 | go : String -> Either String Bits16 93 | go x = do 94 | let Just hex = stringToNat' 16 x 95 | | Nothing => Left $ "invalid hextet: " <+> x 96 | if hex < 65536 97 | then Right $ cast hex 98 | else Left "number out of bound" 99 | to : String -> Either String (List Bits16) 100 | to "" = Right [] 101 | to x = traverse go $ toList $ split (':' ==) x 102 | 103 | parse_ipv6_expand_columns : IPv6R (List Bits16) -> Either String (Vect 8 Bits16) 104 | parse_ipv6_expand_columns (One a) = maybe_to_either (exactLength _ $ fromList a) "invalid length" 105 | parse_ipv6_expand_columns (Two a b) = do 106 | let plen = minus 8 (length a + length b) 107 | let apb = a <+> replicate plen 0 <+> b 108 | maybe_to_either (exactLength _ $ fromList apb) "invalid length" 109 | 110 | export 111 | parse_ipv6 : String -> Either String IPv6Addr 112 | parse_ipv6 x = do 113 | y <- (parse_ipv6_to_octets x >>= parse_ipv6_expand_columns) 114 | pure $ MkIPv6Addr $ concat $ map (to_be {n=2}) y 115 | -------------------------------------------------------------------------------- /src/Crypto/Hash/MD5.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Hash.MD5 2 | 3 | import Crypto.Hash.Interfaces 4 | import Data.Bits 5 | import Data.DPair 6 | import Data.Fin 7 | import Data.Fin.Extra 8 | import Data.List 9 | import Data.Nat 10 | import Data.Nat.Factor 11 | import Data.Vect 12 | import Utils.Misc 13 | import Utils.Bytes 14 | import Data.Stream 15 | import Crypto.Hash.MerkleDamgard 16 | 17 | export 18 | data MD5 : Type where 19 | MkMD5 : MerkleDamgard 4 64 Bits32 -> MD5 20 | 21 | k_table : Vect 64 Bits32 22 | k_table = 23 | [ 0xd76aa478, 0xe8c7b756, 0x242070db, 0xc1bdceee 24 | , 0xf57c0faf, 0x4787c62a, 0xa8304613, 0xfd469501 25 | , 0x698098d8, 0x8b44f7af, 0xffff5bb1, 0x895cd7be 26 | , 0x6b901122, 0xfd987193, 0xa679438e, 0x49b40821 27 | , 0xf61e2562, 0xc040b340, 0x265e5a51, 0xe9b6c7aa 28 | , 0xd62f105d, 0x02441453, 0xd8a1e681, 0xe7d3fbc8 29 | , 0x21e1cde6, 0xc33707d6, 0xf4d50d87, 0x455a14ed 30 | , 0xa9e3e905, 0xfcefa3f8, 0x676f02d9, 0x8d2a4c8a 31 | , 0xfffa3942, 0x8771f681, 0x6d9d6122, 0xfde5380c 32 | , 0xa4beea44, 0x4bdecfa9, 0xf6bb4b60, 0xbebfbc70 33 | , 0x289b7ec6, 0xeaa127fa, 0xd4ef3085, 0x04881d05 34 | , 0xd9d4d039, 0xe6db99e5, 0x1fa27cf8, 0xc4ac5665 35 | , 0xf4292244, 0x432aff97, 0xab9423a7, 0xfc93a039 36 | , 0x655b59c3, 0x8f0ccc92, 0xffeff47d, 0x85845dd1 37 | , 0x6fa87e4f, 0xfe2ce6e0, 0xa3014314, 0x4e0811a1 38 | , 0xf7537e82, 0xbd3af235, 0x2ad7d2bb, 0xeb86d391 ] 39 | 40 | s_table : Vect 64 (Fin 32) 41 | s_table = 42 | [ 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22 43 | , 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20 44 | , 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23 45 | , 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21 ] 46 | 47 | i_table : Vect 64 (Fin 16) 48 | i_table = 49 | [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 50 | , 1, 6, 11, 0, 5, 10, 15, 4, 9, 14, 3, 8, 13, 2, 7, 12 51 | , 5, 8, 11, 14, 1, 4, 7, 10, 13, 0, 3, 6, 9, 12, 15, 2 52 | , 0, 7, 14, 5, 12, 3, 10, 1, 8, 15, 6, 13, 4, 11, 2, 9 ] 53 | 54 | s_k_table : Vect 64 (Fin 32, Bits32) 55 | s_k_table = zip s_table k_table 56 | 57 | md5_init_hash_values : Vect 4 Bits32 58 | md5_init_hash_values = [ 0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476 ] 59 | 60 | md5_compress : (block : Vect 64 Bits8) -> (h : Vect 4 Bits32) -> Vect 4 Bits32 61 | md5_compress block hash_values = zipWith (+) hash_values $ go (_ ** zip calc_m_g s_k_table) hash_values 62 | where 63 | calc_m_g : Vect 64 Bits32 64 | calc_m_g = 65 | let block' = map (from_le {a = Bits32} {n = 4}) $ group 16 4 block 66 | in map (\i => index i block') i_table 67 | loop : Bits32 -> Bits32 -> Bits32 -> Fin 32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 -> Vect 4 Bits32 68 | loop f m_g k_i s_i a b c d = 69 | let f = f + a + k_i + m_g 70 | a = d 71 | d = c 72 | c = b 73 | b = b + rotl s_i f 74 | in [a, b, c, d] 75 | go : (n ** Vect n (Bits32, Fin 32, Bits32)) -> Vect 4 Bits32 -> Vect 4 Bits32 76 | go (Z ** []) abcd = abcd 77 | go ((S n) ** ((i, s_i, k_i) :: xs)) [a, b, c, d] = 78 | case n `div` 16 of 79 | 3 => go (n ** xs) $ loop (d `xor` (b .&. (c `xor` d))) i k_i s_i a b c d 80 | 2 => go (n ** xs) $ loop (c `xor` (d .&. (b `xor` c))) i k_i s_i a b c d 81 | 1 => go (n ** xs) $ loop (b `xor` c `xor` d) i k_i s_i a b c d 82 | _ => go (n ** xs) $ loop (c `xor` (b .|. (complement d))) i k_i s_i a b c d 83 | 84 | md5_update : List Bits8 -> MD5 -> MD5 85 | md5_update input (MkMD5 s) = 86 | let 87 | Fraction _ 64 nblocks residue_nbyte prf = divMod (s.buffer_nbyte + length input) 64 88 | (blocks, residue) = splitAt (mult nblocks 64) (replace_vect (sym prf) (s.buffer ++ fromList input)) 89 | in 90 | MkMD5 $ {buffer := residue, buffer_nbyte := _, buffer_nbyte_constraint := elemSmallerThanBound residue_nbyte } 91 | ( foldl (\s_, block_ => {hash_values $= md5_compress block_, npassed_blocks $= S} s_) s (group nblocks 64 blocks) ) 92 | 93 | md5_finalize : MD5 -> Vect 16 Bits8 94 | md5_finalize (MkMD5 s) = 95 | concat $ map (to_le {n = 4}) $ 96 | case pad_theorem {block_nbyte = 64} {residue_max_nbyte = 55} {length_nbyte = 8} (LTESucc LTEZero) Refl s.buffer_nbyte_constraint s.buffer (integer_to_le _ $ 8 * (cast s.npassed_blocks * 64 + cast s.buffer_nbyte)) of 97 | Left block => md5_compress block s.hash_values 98 | Right blocks => let (x1, x2) = splitAt 64 blocks in md5_compress x2 $ md5_compress x1 s.hash_values 99 | 100 | export 101 | Digest MD5 where 102 | digest_nbyte = 16 103 | update = md5_update 104 | finalize = md5_finalize 105 | 106 | export 107 | Hash MD5 where 108 | block_nbyte = 64 109 | initialize = MkMD5 $ mk_merkle_damgard md5_init_hash_values 110 | -------------------------------------------------------------------------------- /src/Crypto/RSA.idr: -------------------------------------------------------------------------------- 1 | module Crypto.RSA 2 | 3 | import Data.List 4 | import Data.Vect 5 | import Data.Bits 6 | import Utils.Misc 7 | import Utils.Bytes 8 | import Crypto.Random 9 | import Data.Nat 10 | import Crypto.Hash 11 | import Data.List1 12 | import Data.Fin 13 | import Data.Stream 14 | import Data.Fin.Extra 15 | import Crypto.Hash.OID 16 | 17 | export 18 | data RSAPublicKey : Type where 19 | MkRSAPublicKey : (n : Integer) -> (e : Integer) -> RSAPublicKey 20 | 21 | -- TODO: check if there are more constraints needed between n and e 22 | -- also maybe use a proof instead of masking the constructor in the future 23 | export 24 | mk_rsa_publickey : Integer -> Integer -> Maybe RSAPublicKey 25 | mk_rsa_publickey n e = guard (1 == gcd' n e) $> MkRSAPublicKey n e 26 | 27 | export 28 | rsa_encrypt : RSAPublicKey -> Integer -> Integer 29 | rsa_encrypt (MkRSAPublicKey n e) m = pow_mod m e n 30 | 31 | -- RFC 8017 32 | 33 | export 34 | os2ip : Foldable t => t Bits8 -> Integer 35 | os2ip = be_to_integer 36 | 37 | export 38 | i2osp : Nat -> Integer -> Maybe (List Bits8) 39 | i2osp b_len x = 40 | let mask = (shiftL 1 (8 * b_len)) - 1 41 | x' = x .&. mask 42 | in (guard $ x == x') $> (toList $ integer_to_be b_len x) 43 | 44 | export 45 | rsavp1 : RSAPublicKey -> Integer -> Maybe Integer 46 | rsavp1 pk@(MkRSAPublicKey n e) s = guard (s > 0 && s < (n - 1)) $> rsa_encrypt pk s 47 | 48 | record PSSEncodedMessage n where 49 | hash_digest : Vect n Bits8 50 | db : List Bits8 51 | 52 | public export 53 | MaskGenerationFunction : Type 54 | MaskGenerationFunction = (n : Nat) -> List Bits8 -> Vect n Bits8 55 | 56 | export 57 | mgf1 : {algo : _} -> (h : Hash algo) => MaskGenerationFunction 58 | mgf1 n seed = take n $ stream_concat $ map (\x => hash algo (seed <+> (toList $ integer_to_be 4 $ cast x))) nats 59 | 60 | export 61 | modulus_bits : RSAPublicKey -> Nat 62 | modulus_bits (MkRSAPublicKey n _) = if n > 0 then go Z n else 0 63 | where 64 | go : Nat -> Integer -> Nat 65 | go n x = if x == 0 then n else go (S n) (shiftR x 1) 66 | 67 | export 68 | emsa_pss_verify : {algo : _} -> (h : Hash algo) => MaskGenerationFunction -> Nat -> List Bits8 -> List1 Bits8 -> Nat -> Maybe () 69 | emsa_pss_verify mgf sLen message em emBits = do 70 | let mHash = hash algo message 71 | let emLen = divCeilNZ emBits 8 SIsNonZero 72 | let (em, 0xbc) = uncons1 em 73 | | _ => Nothing -- Invalid padding 74 | (maskedDB, digest) <- splitLastAt1 (digest_nbyte {algo}) em 75 | -- check padding 76 | guard $ check_padding (modFinNZ emBits 8 SIsNonZero) (head maskedDB) 77 | let db = zipWith xor (toList maskedDB) (toList $ mgf (length maskedDB) (toList digest)) 78 | (padding, salt) <- splitLastAt1 sLen db 79 | -- unset padding bits 80 | bits_to_be_cleared <- natToFin (minus (8 * emLen) emBits) _ 81 | let mask = shiftR (the Bits8 oneBits) bits_to_be_cleared 82 | let (pxs, px) = uncons1 $ (mask .&. head padding) ::: (tail padding) 83 | -- check padding 84 | guard (0 == (foldr (.|.) 0 pxs)) 85 | guard (1 == px) 86 | -- check salt length 87 | guard $ digest `s_eq` hash algo (replicate 8 0 <+> toList mHash <+> toList salt) 88 | where 89 | check_padding : Fin 8 -> Bits8 -> Bool 90 | check_padding FZ _ = True 91 | check_padding n b = 0 == shiftR b n 92 | 93 | export 94 | rsassa_pss_verify' : {algo : _} -> (h : Hash algo) => MaskGenerationFunction -> Nat -> RSAPublicKey -> List Bits8 -> List Bits8 -> Bool 95 | rsassa_pss_verify' mask_gen salt_len pk message signature = isJust $ do 96 | let modBits = modulus_bits pk 97 | let s = os2ip signature 98 | m <- rsavp1 pk s 99 | let emLen = divCeilNZ (pred modBits) 8 SIsNonZero 100 | em <- i2osp emLen m >>= fromList 101 | emsa_pss_verify {algo} mask_gen salt_len message em (pred modBits) 102 | 103 | export 104 | rsassa_pss_verify : {algo : _} -> Hash algo => RSAPublicKey -> List Bits8 -> List Bits8 -> Bool 105 | rsassa_pss_verify = rsassa_pss_verify' {algo} (mgf1 {algo}) (digest_nbyte {algo}) 106 | 107 | export 108 | emsa_pkcs1_v15_encode : {algo : _} -> RegisteredHash algo => List Bits8 -> Nat -> Maybe (List Bits8) 109 | emsa_pkcs1_v15_encode message emLen = do 110 | let h = hashWithHeader {algo} message 111 | let paddingLen = (emLen `minus` der_digest_n_byte {algo}) `minus` 3 112 | guard (paddingLen >= 8) 113 | let padding = replicate paddingLen 0xff 114 | pure $ [ 0x00, 0x01 ] <+> padding <+> [ 0x00 ] <+> toList h 115 | 116 | export 117 | rsassa_pkcs1_v15_verify : {algo : _} -> RegisteredHash algo => RSAPublicKey -> List Bits8 -> List Bits8 -> Bool 118 | rsassa_pkcs1_v15_verify pk message signature = isJust $ do 119 | let k = divCeilNZ (modulus_bits pk) 8 SIsNonZero 120 | guard (k == length signature) 121 | 122 | let s = os2ip signature 123 | m <- rsavp1 pk s 124 | em <- i2osp k m 125 | 126 | em' <- emsa_pkcs1_v15_encode {algo} message k 127 | guard (em `s_eq'` em') 128 | -------------------------------------------------------------------------------- /src/Crypto/Hash/GHash.idr: -------------------------------------------------------------------------------- 1 | -- BearSSL's "adding holes" algorithm for XOR multiplication 2 | -- Based on BearSSL ghash_ctmul64.c 3 | 4 | module Crypto.Hash.GHash 5 | 6 | import Utils.Bytes 7 | import Data.Bits 8 | import Data.List 9 | import Data.Vect 10 | import Data.DPair 11 | import Data.Fin 12 | import Data.Fin.Extra 13 | import Data.Nat 14 | import Data.Nat.Order.Properties 15 | import Utils.Misc 16 | import Crypto.Hash 17 | 18 | HValues : Type 19 | HValues = (Bits64, Bits64, Bits64, Bits64, Bits64, Bits64) 20 | 21 | -- Carryless multiplication with "holes" 22 | bmul : Bits64 -> Bits64 -> Bits64 23 | bmul x y = 24 | let x0 = x .&. 0x1111111111111111 25 | x1 = x .&. 0x2222222222222222 26 | x2 = x .&. 0x4444444444444444 27 | x3 = x .&. 0x8888888888888888 28 | y0 = y .&. 0x1111111111111111 29 | y1 = y .&. 0x2222222222222222 30 | y2 = y .&. 0x4444444444444444 31 | y3 = y .&. 0x8888888888888888 32 | z0 = (x0 * y0) `xor` (x1 * y3) `xor` (x2 * y2) `xor` (x3 * y1) 33 | z1 = (x0 * y1) `xor` (x1 * y0) `xor` (x2 * y3) `xor` (x3 * y2) 34 | z2 = (x0 * y2) `xor` (x1 * y1) `xor` (x2 * y0) `xor` (x3 * y3) 35 | z3 = (x0 * y3) `xor` (x1 * y2) `xor` (x2 * y1) `xor` (x3 * y0) 36 | in (z0 .&. 0x1111111111111111) .|. 37 | (z1 .&. 0x2222222222222222) .|. 38 | (z2 .&. 0x4444444444444444) .|. 39 | (z3 .&. 0x8888888888888888) 40 | 41 | rms : Bits64 -> Index {a=Bits64} -> Bits64 -> Bits64 42 | rms m s x = (shiftL (x .&. m) s) .|. ((shiftR x s) .&. m) 43 | 44 | rev64 : Bits64 -> Bits64 45 | rev64 x = 46 | let x' = 47 | (rms 0x0000FFFF0000FFFF 16) $ 48 | (rms 0x00FF00FF00FF00FF 8 ) $ 49 | (rms 0x0F0F0F0F0F0F0F0F 4 ) $ 50 | (rms 0x3333333333333333 2 ) $ 51 | (rms 0x5555555555555555 1 ) x 52 | in (shiftL x' 32) .|. (shiftR x' 32) 53 | 54 | gmult_core : Bits64 -> Bits64 -> HValues -> (Bits64, Bits64) 55 | gmult_core y1 y0 (h0, h0r, h1, h1r, h2, h2r) = 56 | let y1r = rev64 y1 57 | y0r = rev64 y0 58 | y2 = xor y0 y1 59 | y2r = xor y0r y1r 60 | -- Karatsuba decomposition 61 | -- Here we decompose the 128 bit multiplication into 62 | -- 3 64-bits multiplication 63 | -- The h-suffixed variables are just multiplication for 64 | -- reversed bits, which is necessary because we want the 65 | -- high bits 66 | z0 = bmul y0 h0 67 | z1 = bmul y1 h1 68 | z2 = bmul y2 h2 69 | z0h = bmul y0r h0r 70 | z1h = bmul y1r h1r 71 | z2h = bmul y2r h2r 72 | z2 = xor (xor z0 z1) z2 73 | z2h = xor (xor z0h z1h) z2h 74 | z0h = shiftR (rev64 z0h) 1 75 | z1h = shiftR (rev64 z1h) 1 76 | z2h = shiftR (rev64 z2h) 1 77 | -- Since the operation is done in big-endian, but GHASH spec 78 | -- needs small endian, we flip the bits 79 | v0 = z0 80 | v1 = xor z0h z2 81 | v2 = xor z1 z2h 82 | v3 = z1h 83 | v3 = (shiftL v3 1) .|. (shiftR v2 63) 84 | v2 = (shiftL v2 1) .|. (shiftR v1 63) 85 | v1 = (shiftL v1 1) .|. (shiftR v0 63) 86 | v0 = (shiftL v0 1) 87 | -- Modular reduction to GF[128] 88 | v2 = v2 `xor` v0 `xor` (shiftR v0 1) `xor` (shiftR v0 2) `xor` (shiftR v0 7) 89 | v1 = v1 `xor` (shiftL v0 63) `xor` (shiftL v0 62) `xor` (shiftL v0 57) 90 | v3 = v3 `xor` v1 `xor` (shiftR v1 1) `xor` (shiftR v1 2) `xor` (shiftR v1 7) 91 | v2 = v2 `xor` (shiftL v1 63) `xor` (shiftL v1 62) `xor` (shiftL v1 57) 92 | in (v3, v2) 93 | 94 | gcm_mult : HValues -> Vect 16 Bits8 -> Vect 16 Bits8 95 | gcm_mult h y = 96 | let y1 = from_be $ take 8 y 97 | y0 = from_be $ drop 8 y 98 | (y1', y0') = gmult_core y1 y0 h 99 | in to_be {n=8} y1' ++ to_be y0' 100 | 101 | mk_h_values : Vect 16 Bits8 -> HValues 102 | mk_h_values h = 103 | let h1 = from_be $ take 8 h 104 | h0 = from_be $ drop 8 h 105 | h0r = rev64 h0 106 | h1r = rev64 h1 107 | h2 = xor h0 h1 108 | h2r = xor h0r h1r 109 | in (h0, h0r, h1, h1r, h2, h2r) 110 | 111 | export 112 | data GHash : Type where 113 | MkGHash : List Bits8 -> HValues -> Vect 16 Bits8 -> GHash 114 | 115 | hash_until_done : GHash -> GHash 116 | hash_until_done ghash@(MkGHash buffer hval state) = 117 | case splitAtExact 16 buffer of 118 | Just (a, b) => hash_until_done $ MkGHash b hval (gcm_mult hval (zipWith xor a state)) 119 | Nothing => ghash 120 | 121 | export 122 | Digest GHash where 123 | digest_nbyte = 16 124 | update message (MkGHash buffer hval state) = 125 | hash_until_done (MkGHash (buffer <+> message) hval state) 126 | finalize (MkGHash buffer hval state) = 127 | let (MkGHash _ _ state) = hash_until_done (MkGHash (pad_zero 16 buffer) hval state) 128 | in state 129 | 130 | export 131 | MAC (Vect 16 Bits8) GHash where 132 | initialize_mac key = MkGHash [] (mk_h_values key) (replicate _ 0) 133 | -------------------------------------------------------------------------------- /src/Network/TLS/Certificate/System.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.Certificate.System 2 | 3 | import Data.Vect 4 | import Data.Fin 5 | import Control.Monad.Error.Either 6 | import Control.Monad.Error.Interface 7 | import System.Info 8 | import System.FFI 9 | import Data.Buffer 10 | import Data.List 11 | import Network.TLS.Certificate 12 | import Network.TLS.Parse.PEM 13 | import Data.String.Parser 14 | import Data.Either 15 | import System.File.Process 16 | import System.File.ReadWrite 17 | import System.Directory 18 | import System 19 | 20 | pem_to_certificate : PEMBlob -> Either String Certificate 21 | pem_to_certificate (MkPEMBlob "CERTIFICATE" content) = 22 | bimap (\err => "error: \{err}, content:\n") id (parse_certificate content) 23 | pem_to_certificate _ = Left "PEM is not a certificate" 24 | 25 | --- START WINDOWS --- 26 | 27 | %foreign "C:openCertStore,libidristls" 28 | prim__open_cert_store : PrimIO AnyPtr 29 | 30 | %foreign "C:closeCertStore,libidristls" 31 | prim__close_cert_store : AnyPtr -> PrimIO Int 32 | 33 | %foreign "C:nextCertInStore,libidristls" 34 | prim__next_cert_in_store : AnyPtr -> AnyPtr -> PrimIO AnyPtr 35 | 36 | %foreign "C:isNull, libidris2_support, idris_support.h" 37 | prim__idrnet_isNull : (ptr : AnyPtr) -> PrimIO Int 38 | 39 | %foreign "C:certLenInfo,libidristls" 40 | prim__cert_len_info : AnyPtr -> PrimIO Int 41 | 42 | %foreign "C:certBody,libidristls" 43 | prim__cert_body : AnyPtr -> Buffer -> PrimIO () 44 | 45 | nullPtr : HasIO io => AnyPtr -> io Bool 46 | nullPtr p = do 47 | i <- primIO $ prim__idrnet_isNull p 48 | pure (i /= 0) 49 | 50 | buffer_to_list : HasIO io => Buffer -> io (List Bits8) 51 | buffer_to_list buffer = rawSize buffer >>= \cap => traverse (getBits8 buffer) [0..(cap-1)] 52 | 53 | test_windows_cert : EitherT String IO (List Certificate) 54 | test_windows_cert = do 55 | cert_store <- primIO prim__open_cert_store 56 | certs <- loop [] cert_store prim__getNullAnyPtr 57 | 58 | let certs_parsed = mapMaybe (getRight . parse_certificate) certs 59 | 60 | b <- primIO $ prim__close_cert_store cert_store 61 | if b == 0 62 | then throwE "error occured while closing certificate store" 63 | else pure certs_parsed 64 | where 65 | loop : HasIO io => List (List Bits8) -> AnyPtr -> AnyPtr -> io (List (List Bits8)) 66 | loop acc cert_store prev_cert = do 67 | ctxptr <- primIO $ prim__next_cert_in_store cert_store prev_cert 68 | False <- nullPtr ctxptr 69 | | True => pure acc 70 | len <- primIO $ prim__cert_len_info ctxptr 71 | Just buffer <- newBuffer len 72 | | Nothing => loop acc cert_store ctxptr 73 | primIO $ prim__cert_body ctxptr buffer 74 | buffer_to_list buffer >>= \cert => loop (cert :: acc) cert_store ctxptr 75 | 76 | --- END WINDOWS --- 77 | 78 | --- START MACOS --- 79 | 80 | rootCAKeyChain : String 81 | rootCAKeyChain = "/System/Library/Keychains/SystemRootCertificates.keychain" 82 | 83 | systemKeyChain : String 84 | systemKeyChain = "/Library/Keychains/System.keychain" 85 | 86 | command : List String 87 | command = ["security", "find-certificate", "-pa", rootCAKeyChain, systemKeyChain] 88 | 89 | read_pems : EitherT FileError IO String 90 | read_pems = do 91 | file <- MkEitherT (popen command Read) 92 | MkEitherT (fRead file) 93 | 94 | test_macos_cert : EitherT String IO (List Certificate) 95 | test_macos_cert = do 96 | pems <- bimapEitherT (\err => "popen security failed: \{show err}") id read_pems 97 | (pemblobs, _) <- MkEitherT $ pure $ parse (many parse_pem_blob) pems 98 | pure (mapMaybe (getRight . pem_to_certificate) pemblobs) 99 | 100 | --- END MACOS --- 101 | 102 | --- START UNIX --- 103 | 104 | default_paths : List String 105 | default_paths = 106 | [ "/etc/ssl/certs/" -- linux 107 | , "/system/etc/security/cacerts/" -- android 108 | , "/usr/local/share/certs/" -- freebsd 109 | , "/etc/ssl/cert.pem" -- openbsd 110 | ] 111 | 112 | to_files : HasIO io => List String -> io (List String) 113 | to_files folders = join <$> traverse go folders where 114 | go : String -> io (List String) 115 | go folder = case !(listDir folder) of 116 | Left _ => pure [folder] 117 | Right files => pure (map (folder <+> "/" <+>) files) 118 | 119 | test_unix_certs : EitherT String IO (List Certificate) 120 | test_unix_certs = do 121 | folder <- maybe default_paths (::[]) <$> getEnv "SYSTEM_CERTIFICATE_PATH" 122 | certpaths <- to_files folder 123 | pemtxts <- mapMaybe getRight <$> traverse readFile certpaths 124 | let pems = pemtxts >>= parse_pems_ignore_error 125 | pure (mapMaybe (getRight . pem_to_certificate) pems) 126 | where 127 | parse_pems_ignore_error : String -> List PEMBlob 128 | parse_pems_ignore_error = either (const []) fst . parse (many parse_pem_blob) 129 | 130 | --- END UNIX 131 | 132 | export 133 | get_system_trusted_certs : IO (Either String (List Certificate)) 134 | get_system_trusted_certs = 135 | runEitherT $ if isWindows 136 | then test_windows_cert 137 | else (if os == "darwin" then test_macos_cert else test_unix_certs) 138 | -------------------------------------------------------------------------------- /src/Crypto/Hash/Poly1305.idr: -------------------------------------------------------------------------------- 1 | -- Implementation based on https://www.newspipe.org/article/public/309714 2 | 3 | module Crypto.Hash.Poly1305 4 | 5 | import Data.Vect 6 | import Utils.Misc 7 | import Utils.Bytes 8 | import Data.Bits 9 | import Crypto.Hash 10 | 11 | export 12 | record Poly1305 where 13 | constructor MkPoly1305 14 | buffer : List Bits8 15 | h : Vect 3 Bits64 16 | r : Vect 2 Bits64 17 | s : Vect 2 Bits64 18 | 19 | record Bits128 where 20 | constructor MkBits128 21 | lo : Bits64 22 | hi : Bits64 23 | 24 | mask_low_2_bits : Bits64 25 | mask_low_2_bits = 0x0000000000000003 26 | 27 | mask_not_low_2_bits : Bits64 28 | mask_not_low_2_bits = complement mask_low_2_bits 29 | 30 | p0 : Bits64 31 | p0 = 0xFFFFFFFFFFFFFFFB 32 | 33 | p1 : Bits64 34 | p1 = 0xFFFFFFFFFFFFFFFF 35 | 36 | p2 : Bits64 37 | p2 = 0x0000000000000003 38 | 39 | add64 : Bits64 -> Bits64 -> Bits64 -> (Bits64, Bits64) 40 | add64 x y carry = 41 | let sum = x + y + carry 42 | carry = shiftR ((x .&. y) .|. ((x .|. y) .&. (complement sum))) 63 43 | in (sum, carry) 44 | 45 | sub64 : Bits64 -> Bits64 -> Bits64 -> (Bits64, Bits64) 46 | sub64 x y borrow = 47 | let diff = x - y - borrow 48 | borrow_out = shiftR ((complement x .&. y) .|. (diff .&. complement (x `xor` y))) 63 49 | in (diff, borrow_out) 50 | 51 | mul64_mask32 : Bits64 52 | mul64_mask32 = cast (the Bits32 oneBits) 53 | 54 | mul64 : Bits64 -> Bits64 -> Bits128 55 | mul64 x y = 56 | let x0 = x .&. mul64_mask32 57 | x1 = shiftR x 32 58 | y0 = y .&. mul64_mask32 59 | y1 = shiftR y 32 60 | w0 = x0 * y0 61 | t = (x1 * y0) + (shiftR w0 32) 62 | w1 = t .&. mul64_mask32 63 | w2 = shiftR t 32 64 | w1 = w1 + (x0 * y1) 65 | in MkBits128 (x * y) (x1 * y1 + w2 + (shiftR w1 32)) 66 | 67 | add128 : Bits128 -> Bits128 -> Bits128 68 | add128 a b = 69 | let (lo, c) = add64 a.lo b.lo 0 70 | (hi, _) = add64 a.hi b.hi c 71 | in MkBits128 lo hi 72 | 73 | shiftr2 : Bits128 -> Bits128 74 | shiftr2 a = MkBits128 ((shiftR a.lo 2) .|. (shiftL (a.hi .&. 3) 62)) (shiftR a.hi 2) 75 | 76 | -- select64 returns x if v == 1 and y if v == 0, in constant time 77 | select64 : Bits64 -> Bits64 -> Bits64 -> Bits64 78 | select64 v x y = (x .&. complement (v - 1)) .|. (y .&. (v - 1)) 79 | 80 | core : Poly1305 -> Bits64 -> Bits64 -> Bits64 -> (Bits64, Bits64, Bits64) 81 | core state h0 h1 h2 = 82 | let [r0, r1] = state.r 83 | 84 | h0r0 = mul64 h0 r0 85 | h1r0 = mul64 h1 r0 86 | h2r0 = mul64 h2 r0 87 | h0r1 = mul64 h0 r1 88 | h1r1 = mul64 h1 r1 89 | h2r1 = mul64 h2 r1 90 | 91 | m0 = h0r0 92 | m1 = add128 h1r0 h0r1 93 | m2 = add128 h2r0 h1r1 94 | m3 = h2r1 95 | 96 | t0 = m0.lo 97 | (t1, c) = add64 m1.lo m0.hi 0 98 | (t2, c) = add64 m2.lo m1.hi c 99 | (t3, _) = add64 m3.lo m2.hi c 100 | 101 | h0 = t0 102 | h1 = t1 103 | h2 = t2 .&. mask_low_2_bits 104 | cc = MkBits128 (t2 .&. mask_not_low_2_bits) t3 105 | 106 | (h0, c) = add64 h0 cc.lo 0 107 | (h1, c) = add64 h1 cc.hi c 108 | h2 = h2 + c 109 | 110 | cc = shiftr2 cc 111 | 112 | (h0, c) = add64 h0 cc.lo 0 113 | (h1, c) = add64 h1 cc.hi c 114 | h2 = h2 + c 115 | in (h0, h1, h2) 116 | 117 | update' : Poly1305 -> Poly1305 118 | update' state = 119 | case splitAtExact 16 state.buffer of 120 | Just (buf, rest) => 121 | let (a, b) = bimap from_le from_le (splitAt 8 buf) 122 | [h0, h1, h2] = state.h 123 | (h0, c) = add64 h0 a 0 124 | (h1, c) = add64 h1 b c 125 | h2 = h2 + c + 1 126 | (h0, h1, h2) = core state h0 h1 h2 127 | in {h := [h0, h1, h2]} state 128 | Nothing => state 129 | 130 | finalize' : Poly1305 -> Vect 16 Bits8 131 | finalize' state = 132 | case exactLength 16 (fromList state.buffer) of 133 | Just buf => 134 | let (a, b) = bimap from_le from_le (splitAt 8 buf) 135 | [h0, h1, h2] = state.h 136 | (h0, c) = add64 h0 a 0 137 | (h1, c) = add64 h1 b c 138 | h2 = h2 + c 139 | (h0, h1, h2) = core state h0 h1 h2 140 | 141 | (t0, b) = sub64 h0 p0 0 142 | (t1, b) = sub64 h1 p1 b 143 | (_ , b) = sub64 h2 p2 b 144 | 145 | h0 = select64 b h0 t0 146 | h1 = select64 b h1 t1 147 | 148 | [s0, s1] = state.s 149 | (h0, c) = add64 h0 s0 0 150 | (h1, _) = add64 h1 s1 c 151 | in to_le {n=8} h0 ++ to_le {n=8} h1 152 | Nothing => 153 | finalize' $ { buffer := pad_zero 16 (state.buffer <+> [ 0x01 ]) } (update' state) 154 | 155 | export 156 | Digest Poly1305 where 157 | digest_nbyte = 16 158 | update message state = update' $ {buffer := state.buffer <+> message} state 159 | finalize = finalize' 160 | 161 | export 162 | MAC (Vect 32 Bits8) Poly1305 where 163 | initialize_mac key = 164 | let ([r0, r1], s) = splitAt 2 $ map from_le $ group 4 8 key 165 | r0 = r0 .&. 0x0FFFFFFC0FFFFFFF 166 | r1 = r1 .&. 0x0FFFFFFC0FFFFFFC 167 | in MkPoly1305 [] [0,0,0] [r0, r1] s 168 | -------------------------------------------------------------------------------- /tests/src/Crypto.idr: -------------------------------------------------------------------------------- 1 | module Crypto 2 | 3 | import Control.Monad.State 4 | import Crypto.RSA 5 | import Crypto.Random 6 | import Crypto.Random.C 7 | import Crypto.AES.Common 8 | import Crypto.AES.Small 9 | import Crypto.AES.Big 10 | import Crypto.Hash 11 | import Crypto.Hash.HMAC 12 | import Data.Vect 13 | import Data.List1 14 | import Utils.Bytes 15 | import Utils.Misc 16 | 17 | test_chacha : HasIO m => m () 18 | test_chacha = do 19 | drg <- new_chacha12_drg 20 | let a = evalState drg (random_bytes 1024) 21 | putStrLn $ show a 22 | 23 | test_rsa : HasIO m => m Integer 24 | test_rsa = do 25 | (pk, sk) <- generate_key_pair 1024 26 | let m = 42069 27 | let c = rsa_encrypt pk m 28 | rsa_decrypt_blinded sk c 29 | 30 | test_aes_128_key : Vect 16 Bits8 31 | test_aes_128_key = 32 | [ 0x2b, 0x7e, 0x15, 0x16, 0x28, 0xae, 0xd2, 0xa6, 0xab, 0xf7, 0x15, 0x88, 0x09, 0xcf, 0x4f, 0x3c ] 33 | 34 | test_aes_192_key : Vect 24 Bits8 35 | test_aes_192_key = 36 | [ 0x8e, 0x73, 0xb0, 0xf7, 0xda, 0x0e, 0x64, 0x52, 0xc8, 0x10, 0xf3, 0x2b, 0x80, 0x90, 0x79, 0xe5 37 | , 0x62, 0xf8, 0xea, 0xd2, 0x52, 0x2c, 0x6b, 0x7b ] 38 | 39 | test_aes_256_key : Vect 32 Bits8 40 | test_aes_256_key = 41 | [ 0x60, 0x3d, 0xeb, 0x10, 0x15, 0xca, 0x71, 0xbe, 0x2b, 0x73, 0xae, 0xf0, 0x85, 0x7d, 0x77, 0x81 42 | , 0x1f, 0x35, 0x2c, 0x07, 0x3b, 0x61, 0x08, 0xd7, 0x2d, 0x98, 0x10, 0xa3, 0x09, 0x14, 0xdf, 0xf4 ] 43 | 44 | test_aes_plaintext : Vect 16 Bits8 45 | test_aes_plaintext = 46 | [ 0x6b, 0xc1, 0xbe, 0xe2, 0x2e, 0x40, 0x9f, 0x96, 0xe9, 0x3d, 0x7e, 0x11, 0x73, 0x93, 0x17, 0x2a ] 47 | 48 | test_aes_128_ciphertext : Vect 16 Bits8 49 | test_aes_128_ciphertext = 50 | Small.encrypt_block AES128 test_aes_128_key test_aes_plaintext 51 | 52 | test_aes_192_ciphertext : Vect 16 Bits8 53 | test_aes_192_ciphertext = 54 | Small.encrypt_block AES192 test_aes_192_key test_aes_plaintext 55 | 56 | test_aes_256_ciphertext : Vect 16 Bits8 57 | test_aes_256_ciphertext = 58 | Small.encrypt_block AES256 test_aes_256_key test_aes_plaintext 59 | 60 | test_aes_big_128_ciphertext : Vect 16 Bits8 61 | test_aes_big_128_ciphertext = 62 | Big.encrypt_block AES128 test_aes_128_key test_aes_plaintext 63 | 64 | test_aes_big_192_ciphertext : Vect 16 Bits8 65 | test_aes_big_192_ciphertext = 66 | Big.encrypt_block AES192 test_aes_192_key test_aes_plaintext 67 | 68 | test_aes_big_256_ciphertext : Vect 16 Bits8 69 | test_aes_big_256_ciphertext = 70 | Big.encrypt_block AES256 test_aes_256_key test_aes_plaintext 71 | 72 | ||| test case where padding first bit would be set 73 | test_rsa_pss : Maybe () 74 | test_rsa_pss = 75 | emsa_pss_verify {algo=Sha256} 76 | (mgf1 {algo=Sha256}) 77 | 32 78 | [ 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20 79 | , 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20 80 | , 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x54, 0x4c 81 | , 0x53, 0x20, 0x31, 0x2e, 0x33, 0x2c, 0x20, 0x73, 0x65, 0x72, 0x76, 0x65, 0x72, 0x20, 0x43, 0x65, 0x72, 0x74, 0x69, 0x66, 0x69, 0x63 82 | , 0x61, 0x74, 0x65, 0x56, 0x65, 0x72, 0x69, 0x66, 0x79, 0x00, 0x8b, 0xea, 0x0f, 0x13, 0xa1, 0xa0, 0xa2, 0x30, 0xfc, 0x94, 0xe4, 0x21 83 | , 0xf1, 0x21, 0x3a, 0x4e, 0x00, 0xed, 0x45, 0x39, 0xe6, 0x49, 0x04, 0xfe, 0x98, 0x55, 0x0c, 0x97, 0xa0, 0xa3, 0xaf, 0x34, 0x64, 0xcf 84 | , 0xa0, 0x35, 0x36, 0xcf, 0x60, 0x0a, 0x2f, 0x1e, 0x04, 0xe7, 0x0d, 0xe6, 0x04, 0x6d ] 85 | (0x18 ::: [ 0xf9, 0x15, 0x8c, 0x76, 0x0d, 0x2d, 0x7f, 0x57, 0x36, 0x01, 0x8e, 0x89, 0x33, 0x92, 0xdc, 0x04, 0xb2, 0x02, 0x46, 0x30, 0x8b 86 | , 0x06, 0xc8, 0x65, 0x94, 0x71, 0xac, 0x3c, 0x6f, 0xe2, 0x71, 0x2b, 0x11, 0xe6, 0x4c, 0x7d, 0x11, 0x1f, 0x5a, 0x82, 0x20, 0x3c, 0x7c 87 | , 0x29, 0x83, 0x43, 0x1a, 0xcf, 0xd8, 0xc4, 0x4c, 0xad, 0xfc, 0x78, 0xf0, 0xef, 0x16, 0x1b, 0x24, 0xbf, 0xa5, 0x16, 0x8a, 0x47, 0xe7 88 | , 0x1d, 0x60, 0xd2, 0x6b, 0x08, 0xfa, 0x37, 0xdc, 0x76, 0x42, 0x88, 0x7c, 0xa5, 0x91, 0x97, 0x69, 0xa7, 0xd5, 0x50, 0x66, 0x09, 0xb6 89 | , 0x8a, 0x12, 0x76, 0x6e, 0xd1, 0xa6, 0xb0, 0x9e, 0x6d, 0xe6, 0xf2, 0x8a, 0x79, 0x4c, 0x68, 0x29, 0x52, 0xdb, 0x53, 0x36, 0x9b, 0x49 90 | , 0xed, 0x21, 0xf2, 0x48, 0x1d, 0x0e, 0x9f, 0x92, 0x23, 0x96, 0x0b, 0xc4, 0x47, 0x94, 0xb5, 0xec, 0x13, 0x40, 0x75, 0xde, 0x14, 0x9c 91 | , 0xa6, 0xa7, 0x2c, 0x9f, 0xbf, 0xe3, 0x94, 0xde, 0xeb, 0x49, 0xdc, 0x6a, 0xdc, 0x30, 0xa3, 0x0c, 0xf5, 0x2e, 0xe6, 0x14, 0x3f, 0xe2 92 | , 0x98, 0x27, 0x14, 0x8d, 0x21, 0x92, 0x20, 0xaa, 0xfb, 0x4e, 0x08, 0xa5, 0xd4, 0x7c, 0x8a, 0xf2, 0xed, 0x75, 0xa7, 0x6c, 0x01, 0xa4 93 | , 0x18, 0x4c, 0x58, 0x12, 0x10, 0xff, 0x2d, 0xc5, 0x0f, 0x8d, 0xe5, 0xab, 0x56, 0xa9, 0x81, 0x7c, 0x87, 0x4d, 0x19, 0xa4, 0x37, 0x96 94 | , 0x5d, 0x82, 0x84, 0xaa, 0x44, 0xc0, 0x7f, 0x4f, 0x39, 0xf4, 0x5d, 0x0d, 0xeb, 0xda, 0x3e, 0x2c, 0xd3, 0xaf, 0xe9, 0xf5, 0x24, 0x1e 95 | , 0x38, 0xb7, 0x35, 0x09, 0xda, 0x62, 0xc1, 0x3b, 0x89, 0x5c, 0xa9, 0xcc, 0x76, 0xe6, 0xed, 0x7f, 0xc6, 0xe0, 0x3a, 0x73, 0x94, 0x33 96 | , 0xca, 0x60, 0xf0, 0x15, 0xc7, 0x79, 0x62, 0x69, 0x68, 0x4d, 0xfd, 0x49, 0x98, 0xbc ]) 97 | 2047 98 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # idris2-tls 2 | A portable idris2 implementation of TLS 1.2 and TLS 1.3 protocol. 3 | 4 | # Goal 5 | This library aims to provide a TLS implementation in Idris that supports communication with most modern websites and provide reasonable performance. 6 | Not meant for production. Read the notes on security. 7 | 8 | # Installation 9 | The latest version of this library can be installed with [pack](https://github.com/stefan-hoeck/idris2-pack). 10 | 11 | # Example 12 | An example that send a HTTP request over TLS to server can be found [here](tests/src/LTLS.idr). 13 | More examples on how to use the internal modules can be found in the [Tests](tests/src/) folder. 14 | 15 | # Support coverage 16 | The library currently supports the following cipher suites: 17 | 18 | TLS 1.3: 19 | - TLS_AES_128_GCM_SHA256 20 | - TLS_AES_256_GCM_SHA384 21 | - TLS_CHACHA20_POLY1305_SHA256 22 | 23 | TLS 1.2: 24 | - TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256 25 | - TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384 26 | - TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 27 | - TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 28 | - TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 29 | - TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256 30 | 31 | The library currently supports the following groups for key exchange during TLS handshake: 32 | - X25519 33 | - SECP256r1 34 | - SECP384r1 35 | 36 | The following groups are implemented, but not used in the linear TLS handle abstraction. 37 | - X448 38 | - SECP521r1 39 | 40 | Since most modern websites support key exchange with elliptic curves (and I can't figure out how RSA parameters are encoded), 41 | RSA key exchange is not supported, nor do we consider implementing it by ourselves anytime soon. 42 | However, we may consider doing so in the future if there is enough demand. 43 | 44 | Other symmetric ciphers such as Camilla, ARIA, DES, RC4 are not implemented, nor do we plan to implement them, because they are either deprecated 45 | or way too obscure. 46 | 47 | Right now only GCM is implemented for AES mode of operation. We may implement other mode of operation such as CBC in the future, but it is not on our timeline 48 | since GCM seems to cover most websites. 49 | 50 | Older TLS versions such as TLS 1.0, TLS 1.1 and SSL will not be implemented since they are way too obscure and insecure. 51 | 52 | Any PRs that implement new ciphers, mode of operations, curves, key exchange schemes (like RSA) are **extremely** welcomed. 53 | 54 | # Note on bindings 55 | While we try to minimize the amount of bindings as much as possible, they are still needed in order to provide cryptographically secure random entropy. 56 | The base Idris library has `System.Random`, but it is not cryptographically random, so we had to resort to using bindings. 57 | 58 | Currently bindings for random entropy are implemented for C, Scheme and JS backends. Note that for some platforms they had not been tested, so any feedback 59 | would be appreciated. A current outline of what bindings are used is as follow: 60 | 61 | C / Scheme: 62 | 63 | A C library is used to provide a unified interface for generating random numbers in [here](c/idristls.c). 64 | 65 | - Windows: `BCryptGenRandom` 66 | - MacOS / BSD: `arc4random_buf` 67 | - Linux: `getrandom` 68 | 69 | On Unix-like systems, `/dev/urandom` and `/dev/random` are decidedly not used because I've encountered blocking problems with them, so I figured that directly 70 | using syscalls would be cleaner. 71 | 72 | Node / Javascript: 73 | - Node: `require('crypto').randomBytes` (tested) 74 | - Other environments: `crypto.getRandomValues` (not tested) 75 | 76 | If you need to write your own implementation of `MonadRandom IO` for whatever reasons, an example of how they are implemented can be found [here](src/Crypto/Random). 77 | 78 | We have also implemented our own bindings and library for C networking. The official network library is decidedly not used because it uses `String` for 79 | payloads. This makes handling NUL bytes extremely difficult since `String` is NUL terminated. Therefore, we made our own bindings which uses `List Bits8` 80 | instead. Other solutions to this problem are welcomed. 81 | 82 | On Windows, C bindings are also used to fetch the system's trusted certificates, in [here](c/idristls.c). 83 | 84 | # Other notes 85 | We have decidedly not use any bytes library and rely heavily on `List Bits8`, `Vect n Bits8` instead. We feel that this approach is more pure and functional 86 | and in general more pleasing to work with. While other bytes library may yield better performance, we feel that our approach performs reasonably well. 87 | 88 | # Notes on security 89 | **This project does not guarantee security**. Our implementations may be flawed with exploitable bugs. 90 | Our cryptographic primitives are most definitely vulnerable to all sorts of side channel attack, 91 | e.g. [timing attack](https://en.wikipedia.org/wiki/Timing_attack). The code has not been audited at all, and the authors 92 | have zero background in cryptography nor cybersecurity. Do not use this under the assumption that it is secure. Use at your own risk. 93 | 94 | # TODO 95 | - Revocation checking 96 | - OCSP stapling 97 | 98 | # License 99 | This project is licensed under the ISC license. See [LICENSE](LICENSE). 100 | -------------------------------------------------------------------------------- /src/Crypto/Hash/MerkleDamgard.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Hash.MerkleDamgard 2 | 3 | import Crypto.Hash.Interfaces 4 | import Data.Bits 5 | import Data.DPair 6 | import Data.Fin 7 | import Data.Fin.Extra 8 | import Data.List 9 | import Data.Nat 10 | import Data.Nat.Factor 11 | import Data.Vect 12 | import Utils.Misc 13 | import Utils.Bytes 14 | import Data.Stream 15 | 16 | public export 17 | record MerkleDamgard (internal_state_nbyte : Nat) (0 block_nbyte : Nat) (0 word_type : Type) where 18 | constructor MkMerkleDamgard 19 | hash_values : Vect internal_state_nbyte word_type 20 | buffer_nbyte : Nat 21 | buffer_nbyte_constraint : LT buffer_nbyte block_nbyte 22 | buffer : Vect buffer_nbyte Bits8 23 | npassed_blocks : Nat 24 | 25 | export 26 | mk_merkle_damgard : (init_hash_values : Vect internal_state_nbyte word_type) -> 27 | {auto 0 prf : LTE 1 block_nbyte} -> 28 | MerkleDamgard internal_state_nbyte block_nbyte word_type 29 | mk_merkle_damgard x {prf = LTESucc prf'} = MkMerkleDamgard x 0 (LTESucc LTEZero) [] 0 30 | 31 | public export 32 | pad_lemma : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : Nat} 33 | -> LTE 1 block_nbyte 34 | -> (residue_max_nbyte + 1 + length_nbyte = block_nbyte) 35 | -> LTE residue_nbyte residue_max_nbyte 36 | -> (plus residue_nbyte (S (plus (minus residue_max_nbyte residue_nbyte) length_nbyte))) = block_nbyte 37 | pad_lemma remilia flandre sakuya = 38 | rewrite sym flandre in 39 | rewrite sym $ plusSuccRightSucc residue_nbyte (plus (minus residue_max_nbyte residue_nbyte) length_nbyte) in 40 | rewrite plusAssociative residue_nbyte (minus residue_max_nbyte residue_nbyte) length_nbyte in 41 | rewrite plusCommutative residue_nbyte (minus residue_max_nbyte residue_nbyte) in 42 | rewrite plusMinusLte residue_nbyte residue_max_nbyte sakuya in 43 | rewrite plusCommutative residue_max_nbyte 1 in 44 | Refl 45 | 46 | public export 47 | pad_over_lemma : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : Nat} 48 | -> (residue_max_nbyte + 1 + length_nbyte = block_nbyte) 49 | -> LT residue_nbyte block_nbyte 50 | -> plus residue_nbyte (S (plus (plus (minus block_nbyte residue_nbyte) residue_max_nbyte) length_nbyte)) = (plus block_nbyte (plus block_nbyte 0)) 51 | pad_over_lemma flandre cirno = 52 | rewrite sym $ plusSuccRightSucc residue_nbyte (plus (plus (minus block_nbyte residue_nbyte) residue_max_nbyte) length_nbyte) in 53 | rewrite plusAssociative residue_nbyte (plus (minus block_nbyte residue_nbyte) residue_max_nbyte) length_nbyte in 54 | rewrite plusAssociative residue_nbyte (minus block_nbyte residue_nbyte) residue_max_nbyte in 55 | rewrite plusCommutative residue_nbyte (minus block_nbyte residue_nbyte) in 56 | rewrite plusMinusLte residue_nbyte block_nbyte (lteSuccLeft cirno) in 57 | rewrite sym $ plusAssociative block_nbyte residue_max_nbyte length_nbyte in 58 | rewrite plusSuccRightSucc block_nbyte (plus residue_max_nbyte length_nbyte) in 59 | rewrite plusZeroRightNeutral block_nbyte in 60 | rewrite flandre' in 61 | Refl 62 | where 63 | flandre' : S (plus residue_max_nbyte length_nbyte) = block_nbyte 64 | flandre' = rewrite sym flandre in rewrite plusCommutative residue_max_nbyte 1 in Refl 65 | 66 | public export 67 | pad_residue : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : _} 68 | -> (0 _ : LTE 1 block_nbyte) 69 | -> (0 _ : (residue_max_nbyte + 1 + length_nbyte = block_nbyte)) 70 | -> (0 _ : LTE residue_nbyte residue_max_nbyte) 71 | -> Vect residue_nbyte Bits8 72 | -> Vect length_nbyte Bits8 73 | -> Vect block_nbyte Bits8 74 | pad_residue remilia flandre sakuya residue b_length = 75 | replace_vect (pad_lemma remilia flandre sakuya) $ 76 | residue 77 | ++ [0b10000000] 78 | ++ replicate (minus residue_max_nbyte residue_nbyte) 0 79 | ++ b_length 80 | 81 | public export 82 | pad_over_residue : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : _} 83 | -> (0 _ : LTE 1 block_nbyte) 84 | -> (0 _ : residue_max_nbyte + 1 + length_nbyte = block_nbyte) 85 | -> (0 _ : LT residue_max_nbyte residue_nbyte) 86 | -> (0 _ : LT residue_nbyte block_nbyte) 87 | -> Vect residue_nbyte Bits8 88 | -> Vect length_nbyte Bits8 89 | -> Vect (2 * block_nbyte) Bits8 90 | pad_over_residue remilia flandre rumia cirno residue b_length = 91 | replace_vect (pad_over_lemma flandre cirno) $ 92 | residue 93 | ++ [0b10000000] 94 | ++ replicate (minus block_nbyte residue_nbyte + residue_max_nbyte) 0 95 | ++ b_length 96 | 97 | public export 98 | pad_theorem : {residue_nbyte, length_nbyte, residue_max_nbyte, block_nbyte : _} 99 | -> (0 _ : LTE 1 block_nbyte) 100 | -> (0 _ : residue_max_nbyte + 1 + length_nbyte = block_nbyte) 101 | -> (0 _ : LT residue_nbyte block_nbyte) 102 | -> Vect residue_nbyte Bits8 103 | -> Vect length_nbyte Bits8 104 | -> Either (Vect block_nbyte Bits8) (Vect (block_nbyte + block_nbyte) Bits8) 105 | pad_theorem remilia flandre cirno input b_length = 106 | case isLTE residue_nbyte residue_max_nbyte of 107 | Yes sakuya => Left $ pad_residue remilia flandre sakuya input b_length 108 | No rumia => Right $ replace_vect (cong (plus block_nbyte) (plusZeroRightNeutral block_nbyte)) $ pad_over_residue remilia flandre (notLTEImpliesGT rumia) cirno input b_length 109 | -------------------------------------------------------------------------------- /src/Utils/Bytes.idr: -------------------------------------------------------------------------------- 1 | module Utils.Bytes 2 | 3 | import Syntax.WithProof 4 | import Data.Bits 5 | import Data.DPair 6 | import Data.Fin 7 | import Data.Fin.Extra 8 | import Data.Nat 9 | import Data.List 10 | import Data.Vect 11 | import Data.Nat.Factor 12 | import Data.Nat.Order.Properties 13 | import Utils.Misc 14 | 15 | weakenN' : {m : Nat} -> (0 n : Nat) -> Fin m -> Fin (n + m) 16 | weakenN' n m' = rewrite plusCommutative n m in weakenN n m' 17 | 18 | fix_fin : (m : Nat) -> (n : Nat) -> (S m) = n -> S (S (S (S (S (S (S (S (mult m 8)))))))) = mult n 8 19 | fix_fin m n prf = rewrite sym prf in Refl 20 | 21 | export 22 | to_le : (FiniteBits a, Cast a Bits8) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> a -> Vect n Bits8 23 | to_le x = let (S m) = n; nmeq = Refl in map (go nmeq x) Fin.range 24 | where 25 | go : {m : Nat} -> ((S m) = n) -> a -> Fin (S m) -> Bits8 26 | go nmeq b i = cast $ shiftR b (bitsToIndex $ coerce prf $ coerce (fix_fin m n nmeq) $ weakenN' 7 $ i * 8) 27 | 28 | export 29 | to_be : (FiniteBits a, Cast a Bits8) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> a -> Vect n Bits8 30 | to_be = reverse . to_le 31 | 32 | export 33 | from_le : (FiniteBits a, Cast Bits8 a) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> Vect n Bits8 -> a 34 | from_le p = let (S m) = n; nmeq = Refl in foldl (.|.) zeroBits $ zipWith (go nmeq) p Fin.range 35 | where 36 | go : {m : Nat} -> ((S m) = n) -> Bits8 -> Fin (S m) -> a 37 | go nmeq b i = shiftL (cast b) (bitsToIndex $ coerce prf $ coerce (fix_fin m n nmeq) $ weakenN' 7 $ i * 8) 38 | 39 | export 40 | from_be : (FiniteBits a, Cast Bits8 a) => {n : _} -> {auto 0 no0 : NonZero n} -> {auto 0 prf : n * 8 = (bitSize {a})} -> Vect n Bits8 -> a 41 | from_be = from_le . reverse 42 | 43 | export 44 | set_bit_to : Bits a => Bool -> Index {a} -> a -> a 45 | set_bit_to False _ x = x 46 | set_bit_to True pos x = setBit x pos 47 | 48 | export 49 | to_bools_be' : FiniteBits a => (n : Fin (S (bitSize {a}))) -> a -> Vect (finToNat n) Bool 50 | to_bools_be' FZ x = [] 51 | to_bools_be' (FS wit) x = testBit x (bitsToIndex wit) :: (replace_vect finToNatWeakenNeutral $ to_bools_be' (weaken wit) x) 52 | 53 | export 54 | to_bools_be : FiniteBits a => a -> Vect (bitSize {a}) Bool 55 | to_bools_be x = replace_vect finToNatLastIsBound $ to_bools_be' {a = a} Fin.last x 56 | 57 | export 58 | le_to_integer : Foldable t => t Bits8 -> Integer 59 | le_to_integer = go . toList 60 | where 61 | go : List Bits8 -> Integer 62 | go v = foldr (.|.) 0 $ zipWith shiftL (cast {to=Integer} <$> v) ((*8) <$> [0..(length v)]) 63 | 64 | export 65 | be_to_integer : Foldable t => t Bits8 -> Integer 66 | be_to_integer = le_to_integer . reverse . toList 67 | 68 | export 69 | integer_to_le : (n : Nat) -> Integer -> Vect n Bits8 70 | integer_to_le n v = (cast . shiftR v) <$> (((*8) . finToNat) <$> Fin.range) 71 | 72 | export 73 | integer_to_be : (n : Nat) -> Integer -> Vect n Bits8 74 | integer_to_be n = reverse . integer_to_le n 75 | 76 | export 77 | to_digit : Bool -> Char 78 | to_digit False = '0' 79 | to_digit True = '1' 80 | 81 | export 82 | show_bin : FiniteBits a => a -> String 83 | show_bin = pack . toList . map to_digit . to_bools_be 84 | 85 | ||| if 0-15, then return the corresponding hex char 86 | ||| otherwise returns a '?' 87 | export 88 | hex_lower : Bits8 -> Char 89 | hex_lower 0 = '0' 90 | hex_lower 1 = '1' 91 | hex_lower 2 = '2' 92 | hex_lower 3 = '3' 93 | hex_lower 4 = '4' 94 | hex_lower 5 = '5' 95 | hex_lower 6 = '6' 96 | hex_lower 7 = '7' 97 | hex_lower 8 = '8' 98 | hex_lower 9 = '9' 99 | hex_lower 10 = 'a' 100 | hex_lower 11 = 'b' 101 | hex_lower 12 = 'c' 102 | hex_lower 13 = 'd' 103 | hex_lower 14 = 'e' 104 | hex_lower 15 = 'f' 105 | hex_lower _ = '?' 106 | 107 | export 108 | show_hex : Bits8 -> String 109 | show_hex x = strCons (hex_lower (div x 16)) $ strCons (hex_lower (mod x 16)) $ "" 110 | 111 | ||| takes a list of bytes and show them using `show_hex` interspersed by a whitespace 112 | export 113 | xxd : Foldable t => t Bits8 -> String 114 | xxd = concat . intersperse " " . map show_hex . toList 115 | 116 | export 117 | string_to_ascii : (x : String) -> List Bits8 118 | string_to_ascii = map (cast . ord) . unpack 119 | 120 | export 121 | ascii_to_string : List Bits8 -> String 122 | ascii_to_string = pack . map cast 123 | 124 | maybe_a_a : Lazy a -> Maybe a -> a 125 | maybe_a_a a Nothing = Force a 126 | maybe_a_a _ (Just a) = a 127 | 128 | export 129 | shiftL' : FiniteBits a => a -> Nat -> a 130 | shiftL' x i = maybe_a_a zeroBits $ do 131 | i' <- natToFin i _ 132 | Just $ shiftL x (bitsToIndex i') 133 | 134 | export 135 | shiftR' : FiniteBits a => a -> Nat -> a 136 | shiftR' x i = maybe_a_a zeroBits $ do 137 | i' <- natToFin i _ 138 | Just $ shiftR x (bitsToIndex i') 139 | 140 | export 141 | rotl : FiniteBits a => {n : Nat} -> {auto prf : ((S n) = bitSize {a})} -> Fin (S n) -> a -> a 142 | rotl FZ x = x 143 | rotl (FS i) x = (shiftL x $ bitsToIndex (coerce prf $ FS i)) .|. (shiftR x $ bitsToIndex $ complement $ coerce prf $ weaken i) 144 | 145 | export 146 | rotr : FiniteBits a => {n : Nat} -> {auto prf : ((S n) = bitSize {a})} -> Fin (S n) -> a -> a 147 | rotr FZ x = x 148 | rotr (FS i) x = (shiftR x $ bitsToIndex (coerce prf $ FS i)) .|. (shiftL x $ bitsToIndex $ complement $ coerce prf $ weaken i) 149 | -------------------------------------------------------------------------------- /src/Utils/Parser.idr: -------------------------------------------------------------------------------- 1 | module Utils.Parser 2 | 3 | import Data.List 4 | import Data.List.Elem 5 | import Data.List1 6 | import Data.Vect 7 | import Data.Void 8 | import Decidable.Equality 9 | import Syntax.WithProof 10 | 11 | public export 12 | interface Cons a s | s where 13 | singleton : a -> s 14 | uncons : s -> Maybe (a, s) 15 | 16 | public export 17 | Cons Char String where 18 | singleton = cast 19 | uncons = strUncons 20 | 21 | public export 22 | Cons a (List a) where 23 | singleton = pure 24 | uncons [] = Nothing 25 | uncons (x :: xs) = Just (x, xs) 26 | 27 | ||| a simple incremental parser 28 | public export 29 | data Parser : (input : Type) -> (error : Type) -> (a : Type) -> Type where 30 | Fail : e -> Parser i e a 31 | Pure : (leftover : i) -> a -> Parser i e a 32 | More : (on_feed : (i -> Parser i e a)) -> Parser i e a 33 | Alt : Parser i e a -> Lazy (Parser i e a) -> Parser i e a 34 | 35 | public export 36 | Functor (Parser i e) where 37 | map f (Fail e) = Fail e 38 | map f (Pure leftover x) = Pure leftover (f x) 39 | map f (More on_feed) = More (map f . on_feed) 40 | map f (Alt p1 p2) = Alt (map f p1) (map f p2) 41 | 42 | ||| maps over the errors of the parser 43 | public export 44 | map_error : (e -> e') -> Parser i e a -> Parser i e' a 45 | map_error f (Fail e) = Fail (f e) 46 | map_error f (Pure leftover x) = Pure leftover x 47 | map_error f (More on_feed) = More (map_error f . on_feed) 48 | map_error f (Alt p1 p2) = Alt (map_error f p1) (map_error f p2) 49 | 50 | public export 51 | (<|>) : Semigroup e => Parser i e a -> Lazy (Parser i e a) -> Parser i e a 52 | Fail e <|> p = map_error (e <+>) p 53 | Pure leftover x <|> p = Pure leftover x 54 | p <|> q = Alt p q 55 | 56 | ||| fail with an error 57 | public export 58 | fail : e -> Parser i e a 59 | fail = Fail 60 | 61 | ||| feed input into the parser incrementally 62 | public export 63 | feed : (Semigroup e, Semigroup i) => i -> Parser i e a -> Parser i e a 64 | feed input (Fail e) = Fail e 65 | feed input (Pure leftover x) = Pure (leftover <+> input) x 66 | feed input (More on_feed) = on_feed input 67 | feed input (Alt p1 p2) = feed input p1 <|> feed input p2 68 | 69 | apply : (Semigroup e, Semigroup i) => (Parser i e a -> Parser i e b) -> Parser i e a -> Parser i e b 70 | apply f (Fail msg) = Fail msg 71 | apply f (Alt p1 p2) = Alt (f p1) (f p2) 72 | apply f (More on_feed) = More (f . on_feed) 73 | apply f parser = More (\input => f $ feed input parser) 74 | 75 | public export 76 | pure : Monoid i => a -> Parser i e a 77 | pure x = Pure neutral x 78 | 79 | public export 80 | (<*>) : (Semigroup e, Monoid i) => Parser i e (a -> b) -> Lazy (Parser i e a) -> Parser i e b 81 | Pure leftover f <*> p = map f $ feed leftover p 82 | p1 <*> p2 = apply (<*> p2) p1 83 | 84 | public export 85 | (<*) : (Semigroup e, Monoid i) => Parser i e a -> Parser i e b -> Parser i e a 86 | x <* y = map const x <*> y 87 | 88 | public export 89 | (*>) : (Semigroup e, Monoid i) => Parser i e a -> Parser i e b -> Parser i e b 90 | x *> y = map (const id) x <*> y 91 | 92 | public export 93 | (>>=) : (Semigroup e, Monoid i) => Parser i e a -> (a -> Parser i e b) -> Parser i e b 94 | (>>=) (Pure leftover x) f = feed leftover $ f x 95 | (>>=) p f = apply (>>= f) p 96 | 97 | public export 98 | more : (i -> Parser i e a) -> Parser i e a 99 | more = More 100 | 101 | ||| peek into the next token without consuming it 102 | public export 103 | peek : Cons c i => Parser i e c 104 | peek = more $ \input => 105 | case uncons input of 106 | Just (x, _) => Pure input x 107 | Nothing => peek 108 | 109 | ||| reads the next token 110 | public export 111 | token : Cons c i => Parser i e c 112 | token = more $ \input => 113 | case uncons input of 114 | Just (x, xs) => Pure xs x 115 | Nothing => token 116 | 117 | ||| run `p` `k` times and collect the results 118 | public export 119 | count : (Semigroup e, Monoid i, Cons c i) => (k : Nat) -> (p : Parser i e a) -> Parser i e (Vect k a) 120 | count Z parser = pure [] 121 | count (S k) parser = pure $ !parser :: !(count k parser) 122 | 123 | ||| return the result of `p` if it succeeds, otherwise return `x` 124 | public export 125 | option : (Semigroup e, Monoid i) => (x : a) -> (p : Parser i e a) -> Parser i e a 126 | option x p = p <|> pure x 127 | 128 | mutual 129 | public export 130 | some : (Semigroup e, Monoid i) => Parser i e a -> Parser i e (List1 a) 131 | some p = pure $ !p ::: !(many p) 132 | 133 | public export 134 | many : (Semigroup e, Monoid i) => Parser i e a -> Parser i e (List a) 135 | many p = option [] (forget <$> some p) 136 | 137 | namespace Error 138 | ||| example: `SimpleError String` 139 | public export 140 | data SimpleError : Type -> Type where 141 | Msg : a -> SimpleError a 142 | Alt : SimpleError a -> SimpleError a -> SimpleError a 143 | Under : a -> SimpleError a -> SimpleError a 144 | 145 | public export 146 | Semigroup (SimpleError a) where 147 | (<+>) = Alt 148 | 149 | public export 150 | Show a => Show (SimpleError a) where 151 | show (Msg x) = show x 152 | show (Alt a b) = "(" <+> show a <+> " <|> " <+> show b <+> ")" 153 | show (Under x a) = "(" <+> show x <+> ": " <+> show a <+> ")" 154 | 155 | public export 156 | msg : e -> SimpleError e 157 | msg = Msg 158 | 159 | public export 160 | under : e -> Parser i (SimpleError e) a -> Parser i (SimpleError e) a 161 | under = map_error . Under 162 | -------------------------------------------------------------------------------- /src/Crypto/AES/Big.idr: -------------------------------------------------------------------------------- 1 | module Crypto.AES.Big 2 | 3 | import Utils.ConstantTable 4 | import Crypto.AES.Common 5 | import Data.Bits 6 | import Utils.Bytes 7 | import Data.List 8 | import Data.Fin 9 | import Data.Fin.Extra 10 | import Data.Vect 11 | import Utils.Misc 12 | 13 | ssm0 : ConstantTable 256 Bits32 14 | ssm0 = from_vect 15 | [ 0xC66363A5, 0xF87C7C84, 0xEE777799, 0xF67B7B8D, 0xFFF2F20D, 0xD66B6BBD 16 | , 0xDE6F6FB1, 0x91C5C554, 0x60303050, 0x02010103, 0xCE6767A9, 0x562B2B7D 17 | , 0xE7FEFE19, 0xB5D7D762, 0x4DABABE6, 0xEC76769A, 0x8FCACA45, 0x1F82829D 18 | , 0x89C9C940, 0xFA7D7D87, 0xEFFAFA15, 0xB25959EB, 0x8E4747C9, 0xFBF0F00B 19 | , 0x41ADADEC, 0xB3D4D467, 0x5FA2A2FD, 0x45AFAFEA, 0x239C9CBF, 0x53A4A4F7 20 | , 0xE4727296, 0x9BC0C05B, 0x75B7B7C2, 0xE1FDFD1C, 0x3D9393AE, 0x4C26266A 21 | , 0x6C36365A, 0x7E3F3F41, 0xF5F7F702, 0x83CCCC4F, 0x6834345C, 0x51A5A5F4 22 | , 0xD1E5E534, 0xF9F1F108, 0xE2717193, 0xABD8D873, 0x62313153, 0x2A15153F 23 | , 0x0804040C, 0x95C7C752, 0x46232365, 0x9DC3C35E, 0x30181828, 0x379696A1 24 | , 0x0A05050F, 0x2F9A9AB5, 0x0E070709, 0x24121236, 0x1B80809B, 0xDFE2E23D 25 | , 0xCDEBEB26, 0x4E272769, 0x7FB2B2CD, 0xEA75759F, 0x1209091B, 0x1D83839E 26 | , 0x582C2C74, 0x341A1A2E, 0x361B1B2D, 0xDC6E6EB2, 0xB45A5AEE, 0x5BA0A0FB 27 | , 0xA45252F6, 0x763B3B4D, 0xB7D6D661, 0x7DB3B3CE, 0x5229297B, 0xDDE3E33E 28 | , 0x5E2F2F71, 0x13848497, 0xA65353F5, 0xB9D1D168, 0x00000000, 0xC1EDED2C 29 | , 0x40202060, 0xE3FCFC1F, 0x79B1B1C8, 0xB65B5BED, 0xD46A6ABE, 0x8DCBCB46 30 | , 0x67BEBED9, 0x7239394B, 0x944A4ADE, 0x984C4CD4, 0xB05858E8, 0x85CFCF4A 31 | , 0xBBD0D06B, 0xC5EFEF2A, 0x4FAAAAE5, 0xEDFBFB16, 0x864343C5, 0x9A4D4DD7 32 | , 0x66333355, 0x11858594, 0x8A4545CF, 0xE9F9F910, 0x04020206, 0xFE7F7F81 33 | , 0xA05050F0, 0x783C3C44, 0x259F9FBA, 0x4BA8A8E3, 0xA25151F3, 0x5DA3A3FE 34 | , 0x804040C0, 0x058F8F8A, 0x3F9292AD, 0x219D9DBC, 0x70383848, 0xF1F5F504 35 | , 0x63BCBCDF, 0x77B6B6C1, 0xAFDADA75, 0x42212163, 0x20101030, 0xE5FFFF1A 36 | , 0xFDF3F30E, 0xBFD2D26D, 0x81CDCD4C, 0x180C0C14, 0x26131335, 0xC3ECEC2F 37 | , 0xBE5F5FE1, 0x359797A2, 0x884444CC, 0x2E171739, 0x93C4C457, 0x55A7A7F2 38 | , 0xFC7E7E82, 0x7A3D3D47, 0xC86464AC, 0xBA5D5DE7, 0x3219192B, 0xE6737395 39 | , 0xC06060A0, 0x19818198, 0x9E4F4FD1, 0xA3DCDC7F, 0x44222266, 0x542A2A7E 40 | , 0x3B9090AB, 0x0B888883, 0x8C4646CA, 0xC7EEEE29, 0x6BB8B8D3, 0x2814143C 41 | , 0xA7DEDE79, 0xBC5E5EE2, 0x160B0B1D, 0xADDBDB76, 0xDBE0E03B, 0x64323256 42 | , 0x743A3A4E, 0x140A0A1E, 0x924949DB, 0x0C06060A, 0x4824246C, 0xB85C5CE4 43 | , 0x9FC2C25D, 0xBDD3D36E, 0x43ACACEF, 0xC46262A6, 0x399191A8, 0x319595A4 44 | , 0xD3E4E437, 0xF279798B, 0xD5E7E732, 0x8BC8C843, 0x6E373759, 0xDA6D6DB7 45 | , 0x018D8D8C, 0xB1D5D564, 0x9C4E4ED2, 0x49A9A9E0, 0xD86C6CB4, 0xAC5656FA 46 | , 0xF3F4F407, 0xCFEAEA25, 0xCA6565AF, 0xF47A7A8E, 0x47AEAEE9, 0x10080818 47 | , 0x6FBABAD5, 0xF0787888, 0x4A25256F, 0x5C2E2E72, 0x381C1C24, 0x57A6A6F1 48 | , 0x73B4B4C7, 0x97C6C651, 0xCBE8E823, 0xA1DDDD7C, 0xE874749C, 0x3E1F1F21 49 | , 0x964B4BDD, 0x61BDBDDC, 0x0D8B8B86, 0x0F8A8A85, 0xE0707090, 0x7C3E3E42 50 | , 0x71B5B5C4, 0xCC6666AA, 0x904848D8, 0x06030305, 0xF7F6F601, 0x1C0E0E12 51 | , 0xC26161A3, 0x6A35355F, 0xAE5757F9, 0x69B9B9D0, 0x17868691, 0x99C1C158 52 | , 0x3A1D1D27, 0x279E9EB9, 0xD9E1E138, 0xEBF8F813, 0x2B9898B3, 0x22111133 53 | , 0xD26969BB, 0xA9D9D970, 0x078E8E89, 0x339494A7, 0x2D9B9BB6, 0x3C1E1E22 54 | , 0x15878792, 0xC9E9E920, 0x87CECE49, 0xAA5555FF, 0x50282878, 0xA5DFDF7A 55 | , 0x038C8C8F, 0x59A1A1F8, 0x09898980, 0x1A0D0D17, 0x65BFBFDA, 0xD7E6E631 56 | , 0x844242C6, 0xD06868B8, 0x824141C3, 0x299999B0, 0x5A2D2D77, 0x1E0F0F11 57 | , 0x7BB0B0CB, 0xA85454FC, 0x6DBBBBD6, 0x2C16163A ] 58 | 59 | lookup_ssm0 : Bits32 -> Bits32 60 | lookup_ssm0 x = index_bits8 (cast x) ssm0 61 | 62 | lookup_sbox : Bits32 -> Bits32 -> Bits32 -> Bits32 -> Bits32 63 | lookup_sbox s0 s1 s2 s3 = 64 | let a = cast $ index_bits8 (cast $ shiftR s0 24) sbox 65 | b = cast $ index_bits8 (cast $ shiftR s1 16) sbox 66 | c = cast $ index_bits8 (cast $ shiftR s2 8) sbox 67 | d = cast $ index_bits8 (cast s3) sbox 68 | in (shiftL a 24) .|. (shiftL b 16) .|. (shiftL c 8) .|. d 69 | 70 | sbox_ext : Fin 32 -> Bits32 -> Bits32 71 | sbox_ext i = rotr i . lookup_ssm0 72 | 73 | expand_key_stream : {n_k : _} -> {auto 0 ok : NonZero n_k} -> Vect n_k (Vect 4 Bits8) -> Stream Bits32 74 | expand_key_stream key = map from_be $ prepend (toList key) $ expand_key key 75 | 76 | encrypt_block' : Nat -> Stream Bits32 -> Vect 4 Bits32 -> Vect 16 Bits8 77 | 78 | encrypt_block' Z skey [s0, s1, s2, s3] = 79 | concat $ map (to_be {n=4}) $ vecxor (Stream.take 4 skey) 80 | [ lookup_sbox s0 s1 s2 s3 81 | , lookup_sbox s1 s2 s3 s0 82 | , lookup_sbox s2 s3 s0 s1 83 | , lookup_sbox s3 s0 s1 s2 ] 84 | 85 | encrypt_block' (S n) skey [s0, s1, s2, s3] = 86 | let (s, skey) = splitAt 4 skey 87 | in encrypt_block' n skey $ vecxor s 88 | [ (sbox_ext 0 $ shiftR s0 24) `xor` (sbox_ext 8 $ shiftR s1 16) `xor` (sbox_ext 16 $ shiftR s2 8) `xor` (sbox_ext 24 s3) 89 | , (sbox_ext 0 $ shiftR s1 24) `xor` (sbox_ext 8 $ shiftR s2 16) `xor` (sbox_ext 16 $ shiftR s3 8) `xor` (sbox_ext 24 s0) 90 | , (sbox_ext 0 $ shiftR s2 24) `xor` (sbox_ext 8 $ shiftR s3 16) `xor` (sbox_ext 16 $ shiftR s0 8) `xor` (sbox_ext 24 s1) 91 | , (sbox_ext 0 $ shiftR s3 24) `xor` (sbox_ext 8 $ shiftR s0 16) `xor` (sbox_ext 16 $ shiftR s1 8) `xor` (sbox_ext 24 s2) 92 | ] 93 | 94 | export 95 | encrypt_block : (mode : Mode) -> (key : Vect ((get_n_k mode) * 4) Bits8) -> Vect 16 Bits8 -> Vect 16 Bits8 96 | encrypt_block mode key plaintext = 97 | let buf = map (from_be {n=4,a=Bits32}) $ group 4 4 plaintext 98 | (s, skey) = splitAt 4 (expand_key_stream {ok = n_k_never_Z mode} $ group _ _ key) 99 | in encrypt_block' (get_main_rounds mode) skey $ vecxor buf s 100 | -------------------------------------------------------------------------------- /.github/workflows/ci-lib.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | on: 3 | push: 4 | branches: 5 | - '**' 6 | pull_request: 7 | branches: 8 | - '**' 9 | 10 | ######################################################################## 11 | ## CONFIGURATION 12 | ######################################################################## 13 | 14 | env: 15 | SCHEME: scheme 16 | jobs: 17 | ubuntu-chez: 18 | runs-on: ubuntu-latest 19 | env: 20 | PACK_DIR: /root/.pack 21 | strategy: 22 | fail-fast: false 23 | container: ghcr.io/stefan-hoeck/idris2-pack:latest 24 | steps: 25 | - name: Checkout idris2-tls 26 | uses: actions/checkout@v2 27 | 28 | - name: Build package 29 | run: pack --no-prompt install tls 30 | 31 | - name: Test package 32 | run: pack --no-prompt run tls-tests 33 | 34 | # windows-chez: 35 | # runs-on: windows-latest 36 | # env: 37 | # MSYSTEM: MINGW64 38 | # MSYS2_PATH_TYPE: inherit 39 | # SCHEME: scheme 40 | # CC: gcc 41 | # steps: 42 | # - name: Init 43 | # run: | 44 | # git config --global core.autocrlf false 45 | # - name: Checkout 46 | # uses: actions/checkout@v2 47 | # # This caching step allows us to save a lot of building time by only 48 | # # rebuilding Idris2 from boostrap if absolutely necessary 49 | # - name: Cache Idris2 50 | # uses: actions/cache@v2 51 | # id: cache-idris2 52 | # with: 53 | # path: | 54 | # ChezScheme 55 | # .idris2 56 | # key: ${{ runner.os }}-${{ env.IDRIS2_COMMIT }} 57 | # - name: Get Chez Scheme 58 | # if: steps.cache-idris2.outputs.cache-hit != 'true' 59 | # run: | 60 | # git clone --depth 1 https://github.com/cisco/ChezScheme 61 | # c:\msys64\usr\bin\bash -l -c "pacman -S --noconfirm tar make mingw-w64-x86_64-gcc" 62 | # echo "PWD=$(c:\msys64\usr\bin\cygpath -u $(pwd))" | Out-File -FilePath $env:GITHUB_ENV -Encoding utf8 -Append 63 | # - name: Configure and Build Chez Scheme 64 | # if: steps.cache-idris2.outputs.cache-hit != 'true' 65 | # run: | 66 | # c:\msys64\usr\bin\bash -l -c "cd $env:PWD && cd ChezScheme && ./configure --threads && make" 67 | # - name: Set Path 68 | # run: | 69 | # $chez="$(pwd)\ChezScheme\ta6nt\bin\ta6nt" 70 | # $idris="$(pwd)\.idris2" 71 | # echo "$chez" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append 72 | # echo "$idris\bin" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append 73 | # echo "IDRIS_PREFIX=$idris" | Out-File -FilePath $env:GITHUB_ENV -Encoding utf8 -Append 74 | # echo "PREFIX=$(c:\msys64\usr\bin\cygpath -u $idris)" | Out-File -FilePath $env:GITHUB_ENV -Encoding utf8 -Append 75 | # - name: Test Scheme 76 | # run: | 77 | # scheme --version 78 | # - name: Install Idris2 79 | # if: steps.cache-idris2.outputs.cache-hit != 'true' 80 | # run: | 81 | # git clone https://github.com/idris-lang/idris2 82 | # cd idris2 83 | # git checkout ${{ env.IDRIS2_COMMIT }} 84 | # c:\msys64\usr\bin\bash -l -c "cd $env:PWD && cd idris2 && make bootstrap && make install" 85 | # - name: Install idris2-elab-util 86 | # run: | 87 | # git clone https://github.com/stefan-hoeck/idris2-elab-util 88 | # cd idris2-elab-util 89 | # git checkout ${{ env.ELAB_COMMIT }} 90 | # make install 91 | 92 | # - name: Checkout idris2-tls 93 | # uses: actions/checkout@v2 94 | # with: 95 | # path: tls 96 | 97 | # - name: Install idris deps 98 | # run: | 99 | # cd tls 100 | 101 | 102 | # - name: Build package 103 | # run: | 104 | # cd tls 105 | # echo "TLS=$(c:\msys64\usr\bin\cygpath -u $(pwd))" | Out-File -FilePath $env:GITHUB_ENV -Encoding utf8 -Append 106 | # make install 107 | 108 | # - name: Test package 109 | # run: c:\msys64\usr\bin\bash -l -c "cd $env:TLS && make test" 110 | 111 | # macos-chez: 112 | # runs-on: macos-latest 113 | # env: 114 | # SCHEME: chez 115 | # steps: 116 | # # This caching step allows us to save a lot of building time by only 117 | # # rebuilding Idris2 from boostrap if absolutely necessary 118 | # - name: Cache Idris2 119 | # uses: actions/cache@v2 120 | # id: cache-idris2 121 | # with: 122 | # path: | 123 | # ~/.idris2 124 | # key: ${{ runner.os }}-${{ env.IDRIS2_COMMIT }} 125 | 126 | # - name: Install Idris2 build dependencies 127 | # run: | 128 | # brew install chezscheme 129 | # brew install coreutils 130 | # echo "$HOME/.idris2/bin" >> "$GITHUB_PATH" 131 | 132 | # - name: Build Idris 2 from bootstrap 133 | # if: steps.cache-idris2.outputs.cache-hit != 'true' 134 | # run: | 135 | # git clone https://github.com/idris-lang/idris2 136 | # cd idris2 137 | # git checkout ${{ env.IDRIS2_COMMIT }} 138 | # chmod -R a-w bootstrap 139 | # make bootstrap && make install 140 | # shell: bash 141 | 142 | # - name: Install idris2-elab-util 143 | # run: | 144 | # git clone https://github.com/stefan-hoeck/idris2-elab-util 145 | # cd idris2-elab-util 146 | # git checkout ${{ env.ELAB_COMMIT }} 147 | # make install 148 | # shell: bash 149 | 150 | # - name: Install idris2-sop 151 | # run: | 152 | # git clone https://github.com/stefan-hoeck/idris2-sop 153 | # cd idris2-sop 154 | # git checkout ${{ env.SOP_COMMIT }} 155 | # idris2 --install sop.ipkg 156 | # shell: bash 157 | 158 | # - name: Checkout idris2-tls 159 | # uses: actions/checkout@v2 160 | # with: 161 | # path: tls 162 | 163 | # - name: Build package 164 | # run: | 165 | # cd tls 166 | # make install 167 | 168 | # - name: Test package 169 | # run: | 170 | # cd tls 171 | # make test 172 | -------------------------------------------------------------------------------- /src/Crypto/AES/Common.idr: -------------------------------------------------------------------------------- 1 | module Crypto.AES.Common 2 | 3 | import Utils.ConstantTable 4 | import Data.Bits 5 | import Data.DPair 6 | import Data.Fin 7 | import Data.List 8 | import Data.Nat 9 | import Data.Stream 10 | import Data.Vect 11 | import Utils.Misc 12 | import Utils.Bytes 13 | 14 | export 15 | matmul : Num a => {p : _} -> (op : Vect m a -> Vect m b -> c) -> Vect n (Vect m a) -> Vect m (Vect p b) -> Vect n (Vect p c) 16 | matmul op [] ys = [] 17 | matmul op (x :: xs) ys = map (op x) (transpose ys) :: matmul op xs ys 18 | 19 | export 20 | vecxor : Bits a => Vect n a -> Vect n a -> Vect n a 21 | vecxor = zipWith xor 22 | 23 | export 24 | matxor : Bits a => Vect n (Vect m a) -> Vect n (Vect m a) -> Vect n (Vect m a) 25 | matxor x y = zipWith vecxor x y 26 | 27 | export 28 | sbox : ConstantTable 256 Bits8 29 | sbox = from_vect 30 | [ 0x63, 0x7c, 0x77, 0x7b, 0xf2, 0x6b, 0x6f, 0xc5, 0x30, 0x01, 0x67, 0x2b, 0xfe, 0xd7, 0xab, 0x76 31 | , 0xca, 0x82, 0xc9, 0x7d, 0xfa, 0x59, 0x47, 0xf0, 0xad, 0xd4, 0xa2, 0xaf, 0x9c, 0xa4, 0x72, 0xc0 32 | , 0xb7, 0xfd, 0x93, 0x26, 0x36, 0x3f, 0xf7, 0xcc, 0x34, 0xa5, 0xe5, 0xf1, 0x71, 0xd8, 0x31, 0x15 33 | , 0x04, 0xc7, 0x23, 0xc3, 0x18, 0x96, 0x05, 0x9a, 0x07, 0x12, 0x80, 0xe2, 0xeb, 0x27, 0xb2, 0x75 34 | , 0x09, 0x83, 0x2c, 0x1a, 0x1b, 0x6e, 0x5a, 0xa0, 0x52, 0x3b, 0xd6, 0xb3, 0x29, 0xe3, 0x2f, 0x84 35 | , 0x53, 0xd1, 0x00, 0xed, 0x20, 0xfc, 0xb1, 0x5b, 0x6a, 0xcb, 0xbe, 0x39, 0x4a, 0x4c, 0x58, 0xcf 36 | , 0xd0, 0xef, 0xaa, 0xfb, 0x43, 0x4d, 0x33, 0x85, 0x45, 0xf9, 0x02, 0x7f, 0x50, 0x3c, 0x9f, 0xa8 37 | , 0x51, 0xa3, 0x40, 0x8f, 0x92, 0x9d, 0x38, 0xf5, 0xbc, 0xb6, 0xda, 0x21, 0x10, 0xff, 0xf3, 0xd2 38 | , 0xcd, 0x0c, 0x13, 0xec, 0x5f, 0x97, 0x44, 0x17, 0xc4, 0xa7, 0x7e, 0x3d, 0x64, 0x5d, 0x19, 0x73 39 | , 0x60, 0x81, 0x4f, 0xdc, 0x22, 0x2a, 0x90, 0x88, 0x46, 0xee, 0xb8, 0x14, 0xde, 0x5e, 0x0b, 0xdb 40 | , 0xe0, 0x32, 0x3a, 0x0a, 0x49, 0x06, 0x24, 0x5c, 0xc2, 0xd3, 0xac, 0x62, 0x91, 0x95, 0xe4, 0x79 41 | , 0xe7, 0xc8, 0x37, 0x6d, 0x8d, 0xd5, 0x4e, 0xa9, 0x6c, 0x56, 0xf4, 0xea, 0x65, 0x7a, 0xae, 0x08 42 | , 0xba, 0x78, 0x25, 0x2e, 0x1c, 0xa6, 0xb4, 0xc6, 0xe8, 0xdd, 0x74, 0x1f, 0x4b, 0xbd, 0x8b, 0x8a 43 | , 0x70, 0x3e, 0xb5, 0x66, 0x48, 0x03, 0xf6, 0x0e, 0x61, 0x35, 0x57, 0xb9, 0x86, 0xc1, 0x1d, 0x9e 44 | , 0xe1, 0xf8, 0x98, 0x11, 0x69, 0xd9, 0x8e, 0x94, 0x9b, 0x1e, 0x87, 0xe9, 0xce, 0x55, 0x28, 0xdf 45 | , 0x8c, 0xa1, 0x89, 0x0d, 0xbf, 0xe6, 0x42, 0x68, 0x41, 0x99, 0x2d, 0x0f, 0xb0, 0x54, 0xbb, 0x16 46 | ] 47 | 48 | export 49 | inv_sbox : ConstantTable 256 Bits8 50 | inv_sbox = from_vect 51 | [ 0x52, 0x09, 0x6a, 0xd5, 0x30, 0x36, 0xa5, 0x38, 0xbf, 0x40, 0xa3, 0x9e, 0x81, 0xf3, 0xd7, 0xfb 52 | , 0x7c, 0xe3, 0x39, 0x82, 0x9b, 0x2f, 0xff, 0x87, 0x34, 0x8e, 0x43, 0x44, 0xc4, 0xde, 0xe9, 0xcb 53 | , 0x54, 0x7b, 0x94, 0x32, 0xa6, 0xc2, 0x23, 0x3d, 0xee, 0x4c, 0x95, 0x0b, 0x42, 0xfa, 0xc3, 0x4e 54 | , 0x08, 0x2e, 0xa1, 0x66, 0x28, 0xd9, 0x24, 0xb2, 0x76, 0x5b, 0xa2, 0x49, 0x6d, 0x8b, 0xd1, 0x25 55 | , 0x72, 0xf8, 0xf6, 0x64, 0x86, 0x68, 0x98, 0x16, 0xd4, 0xa4, 0x5c, 0xcc, 0x5d, 0x65, 0xb6, 0x92 56 | , 0x6c, 0x70, 0x48, 0x50, 0xfd, 0xed, 0xb9, 0xda, 0x5e, 0x15, 0x46, 0x57, 0xa7, 0x8d, 0x9d, 0x84 57 | , 0x90, 0xd8, 0xab, 0x00, 0x8c, 0xbc, 0xd3, 0x0a, 0xf7, 0xe4, 0x58, 0x05, 0xb8, 0xb3, 0x45, 0x06 58 | , 0xd0, 0x2c, 0x1e, 0x8f, 0xca, 0x3f, 0x0f, 0x02, 0xc1, 0xaf, 0xbd, 0x03, 0x01, 0x13, 0x8a, 0x6b 59 | , 0x3a, 0x91, 0x11, 0x41, 0x4f, 0x67, 0xdc, 0xea, 0x97, 0xf2, 0xcf, 0xce, 0xf0, 0xb4, 0xe6, 0x73 60 | , 0x96, 0xac, 0x74, 0x22, 0xe7, 0xad, 0x35, 0x85, 0xe2, 0xf9, 0x37, 0xe8, 0x1c, 0x75, 0xdf, 0x6e 61 | , 0x47, 0xf1, 0x1a, 0x71, 0x1d, 0x29, 0xc5, 0x89, 0x6f, 0xb7, 0x62, 0x0e, 0xaa, 0x18, 0xbe, 0x1b 62 | , 0xfc, 0x56, 0x3e, 0x4b, 0xc6, 0xd2, 0x79, 0x20, 0x9a, 0xdb, 0xc0, 0xfe, 0x78, 0xcd, 0x5a, 0xf4 63 | , 0x1f, 0xdd, 0xa8, 0x33, 0x88, 0x07, 0xc7, 0x31, 0xb1, 0x12, 0x10, 0x59, 0x27, 0x80, 0xec, 0x5f 64 | , 0x60, 0x51, 0x7f, 0xa9, 0x19, 0xb5, 0x4a, 0x0d, 0x2d, 0xe5, 0x7a, 0x9f, 0x93, 0xc9, 0x9c, 0xef 65 | , 0xa0, 0xe0, 0x3b, 0x4d, 0xae, 0x2a, 0xf5, 0xb0, 0xc8, 0xeb, 0xbb, 0x3c, 0x83, 0x53, 0x99, 0x61 66 | , 0x17, 0x2b, 0x04, 0x7e, 0xba, 0x77, 0xd6, 0x26, 0xe1, 0x69, 0x14, 0x63, 0x55, 0x21, 0x0c, 0x7d 67 | ] 68 | 69 | export 70 | sub_byte : Bits8 -> Bits8 71 | sub_byte x = index_bits8 x sbox 72 | 73 | export 74 | inv_sub_byte : Bits8 -> Bits8 75 | inv_sub_byte x = index_bits8 x inv_sbox 76 | 77 | export 78 | sub_word : Vect m Bits8 -> Vect m Bits8 79 | sub_word = map sub_byte 80 | 81 | export 82 | inv_sub_word : Vect m Bits8 -> Vect m Bits8 83 | inv_sub_word = map inv_sub_byte 84 | 85 | export 86 | sub_bytes : Vect n (Vect m Bits8) -> Vect n (Vect m Bits8) 87 | sub_bytes = map sub_word 88 | 89 | export 90 | inv_sub_bytes : Vect n (Vect m Bits8) -> Vect n (Vect m Bits8) 91 | inv_sub_bytes = map inv_sub_word 92 | 93 | export 94 | rot_word : {n : Nat} -> Nat -> Vect (S n) a -> Vect (S n) a 95 | rot_word k = take (S n) . drop k . cycle 96 | 97 | export 98 | inv_rot_word : {n : Nat} -> Nat -> Vect (S n) a -> Vect (S n) a 99 | inv_rot_word k = take (S n) . drop (n * k) . cycle 100 | 101 | export 102 | rcons : Stream Bits8 103 | rcons = go 1 104 | where 105 | go : Bits8 -> Stream Bits8 106 | go x = x :: go ((if x < 0x80 then id else xor (0x1B)) $ 2 * x) 107 | 108 | export 109 | expand_key' : {n_k, n_b : _} -> {auto 0 ok : NonZero n_b} -> Fin n_k -> (rcs : Stream Bits8) -> (prev_block : Vect n_k (Vect n_b Bits8)) -> Stream (Vect n_b Bits8) 110 | expand_key' {n_b = S n_b'} counter (rc :: rcs) (x :: xs) = 111 | let 112 | y = last (x :: xs) 113 | in 114 | case counter of 115 | FZ => let z = (vecxor (rc :: replicate _ 0) $ vecxor x $ sub_word $ rot_word 1 $ y) in z :: expand_key' Data.Fin.last rcs (snoc xs z) 116 | (FS counter') => 117 | let 118 | z = vecxor x $ case isLT 6 n_k of 119 | Yes wit => if finToNat (FS counter') == 4 then sub_word y else y 120 | No contra => y 121 | in 122 | z :: expand_key' (weaken counter') (rc :: rcs) (snoc xs z) 123 | 124 | export 125 | expand_key : {n_k, n_b : _} -> {auto 0 ok : NonZero n_b} -> {auto 0 ok2 : NonZero n_k} -> Vect n_k (Vect n_b Bits8) -> Stream (Vect n_b Bits8) 126 | expand_key {n_k = S n_k'} k = expand_key' FZ rcons k 127 | 128 | public export 129 | data Mode : Type where 130 | AES128 : Mode 131 | AES192 : Mode 132 | AES256 : Mode 133 | 134 | public export 135 | get_n_k : Mode -> Nat 136 | get_n_k AES128 = 4 137 | get_n_k AES192 = 6 138 | get_n_k AES256 = 8 139 | 140 | public export 141 | n_k_never_Z : (mode : _) -> NonZero (get_n_k mode) 142 | n_k_never_Z AES128 = SIsNonZero 143 | n_k_never_Z AES192 = SIsNonZero 144 | n_k_never_Z AES256 = SIsNonZero 145 | 146 | public export 147 | get_main_rounds : Mode -> Nat 148 | get_main_rounds AES128 = 9 149 | get_main_rounds AES192 = 11 150 | get_main_rounds AES256 = 13 151 | -------------------------------------------------------------------------------- /tests/src/LTLS.idr: -------------------------------------------------------------------------------- 1 | module LTLS 2 | 3 | import Control.Monad.Error.Either 4 | import Control.Linear.LIO 5 | import Crypto.Random 6 | import Crypto.Random.C 7 | import Data.Either 8 | import Data.List 9 | import Data.List1 10 | import Data.String 11 | import Data.String.Extra 12 | import Data.String.Parser 13 | import Debug.Trace 14 | import Network.Socket 15 | import Network.TLS 16 | import Network.TLS.Certificate.System 17 | import System 18 | import System.File.ReadWrite 19 | import Utils.Bytes 20 | import Utils.Handle 21 | import Utils.Handle.C 22 | import Utils.IPAddr 23 | import Utils.Misc 24 | 25 | ||| Constructs a HTTP GET request given a hostname 26 | test_http_body : String -> List Bits8 27 | test_http_body hostname = 28 | string_to_ascii 29 | $ join "\r\n" 30 | [ "GET / HTTP/1.1" 31 | , "Host: " <+> hostname 32 | , "Connection: close" 33 | , "User-Agent: curl" 34 | , "Accept: */*" 35 | , "Content-Length: 0" 36 | , "" 37 | , "" 38 | ] 39 | 40 | tls_connect : List Certificate -> String -> Int -> EitherT String IO (List Bits8) 41 | tls_connect certs target_hostname port = do 42 | Right sock <- socket AF_INET Stream 0 43 | | Left err => throwE "unable to create socket: \{show err}" 44 | 0 <- connect sock (Hostname target_hostname) port 45 | | _ => throwE "unable to connect" 46 | 47 | -- Here we begin TLS communication in a linear fasion 48 | MkEitherT $ run $ do 49 | let handle = socket_to_handle sock 50 | -- Perform handshake with the TLS server 51 | -- Here we supply the chosen cipher suites, 52 | -- key exhange groups for TLS handshake 53 | (True # handle) <- 54 | tls_handshake 55 | -- the hostname of the server to be connected to 56 | target_hostname 57 | -- the elliptic curves x25519, secp256r1, secp384r1 58 | -- are chosen for key exchange 59 | -- RFC 8446 specifies that secp256r1 MUST be supported, 60 | -- and x25519 SHOULD be supported as well 61 | -- We put x25519 first because we prefer x25519 over secp256r1 62 | -- since the x25519 implementation is faster and simpler 63 | -- secp384r1 is also added to test with https://ecc384.badssl.com/ 64 | -- note that key generation can take some time, so I prefer to keep 65 | -- this list short 66 | -- more groups such as x448 and secp521r1 are implemented but not used 67 | -- here 68 | (X25519 ::: [SECP256r1, SECP384r1]) 69 | -- here we specify the supported signature algorithms that will be 70 | -- used to verify TLS handshake given the server's certificate 71 | supported_signature_algorithms 72 | -- here we specify the supported cipher suites that will be used 73 | -- to encrypt communication with the server 74 | -- we want to support both TLS 1.3 and TLS 1.2 so we supply both 75 | (tls13_supported_cipher_suites <+> tls12_supported_cipher_suites) 76 | -- handle of the underlying socket 77 | handle 78 | -- the function which will be used to verify the server's certificate 79 | -- more documentation can be found in Network.TLS.Verify 80 | -- if you want to skip certificate verification, you can use certificate_ignore_check 81 | -- or implement your own CertificateCheck function 82 | -- (certificate_ignore_check target_hostname) 83 | (certificate_check certs target_hostname) 84 | | (False # (error # ())) => pure $ Left error 85 | 86 | -- send data to the server 87 | -- here I split the data to two chunks for testing purpose 88 | -- you can just send the data without splitting 89 | let (data1, data2) = splitAt 40 $ test_http_body target_hostname 90 | (True # handle) <- write handle data1 91 | | (False # (error # ())) => pure $ Left error 92 | 93 | (True # handle) <- write handle data2 94 | | (False # (error # ())) => pure $ Left error 95 | 96 | -- I did read twice here for testing purpose 97 | -- read 100 bytes of data from the server 98 | (True # (output1 # handle)) <- read handle 100 99 | | (False # (error # ())) => pure $ Left error 100 | 101 | -- read 100 bytes of data from the server again 102 | (True # (output2 # handle)) <- read handle 100 103 | | (False # (error # ())) => pure $ Left error 104 | 105 | close handle 106 | pure $ Right (output1 <+> output2) 107 | 108 | ||| Given a list of trusted certificates, server hostname, server port, 109 | ||| connect to the server and send a HTTP request. 110 | ||| Arguments: 111 | ||| 112 | ||| target_hostname : String 113 | ||| target_hostname is the hostname of the server to be connected. It can 114 | ||| be a DNS hostname, IPv4 address, or IPv6 address. 115 | ||| 116 | ||| port : Int 117 | ||| port is the port number of the server to be connected. The port number 118 | ||| for https server is 443. 119 | tls_test : String -> Int -> IO () 120 | tls_test target_hostname port = do 121 | putStrLn "reading cert store" 122 | Right certs <- get_system_trusted_certs 123 | | Left err => putStrLn "error while reading: \{show err}" 124 | Right response <- runEitherT $ tls_connect certs target_hostname port 125 | | Left err => putStrLn err 126 | putStrLn (ascii_to_string response) 127 | putStrLn "ok" 128 | 129 | tls_test_targets : List (Bool, String, Int) 130 | tls_test_targets = 131 | [ (True, "sha256.badssl.com", 443) 132 | -- TODO: change back to True when they are fixed 133 | -- https://github.com/chromium/badssl.com/issues/501 134 | , (False, "sha384.badssl.com", 443) 135 | , (False, "sha512.badssl.com", 443) 136 | , (True, "github.com", 443) 137 | , (True, "google.com", 443) 138 | -- TODO: investigate why these 2 are not working 139 | -- , ("ecc256.badssl.com", 443) 140 | -- , ("ecc384.badssl.com", 443) 141 | , (True, "tls-v1-2.badssl.com", 1012) 142 | , (False, "expired.badssl.com", 443) 143 | , (False, "wrong.host.badssl.com", 443) 144 | , (False, "self.signed.badssl.com", 443) 145 | , (False, "untrusted-root.badssl.com", 443) 146 | ] 147 | 148 | export 149 | tls_test_unit : EitherT String IO () 150 | tls_test_unit = do 151 | putStrLn "reading cert store" 152 | certs <- MkEitherT get_system_trusted_certs 153 | results <- liftIO $ traverse (go certs) tls_test_targets 154 | let [] = filter not results 155 | | failed => throwE "\{show $ length failed} tls connections failed" 156 | pure () 157 | where 158 | go : List Certificate -> (Bool, String, Int) -> IO Bool 159 | go certs (should_work, target, port) = do 160 | putStr "testing on \{target} \{show port}: " 161 | Right _ <- runEitherT $ tls_connect certs target port 162 | | Left err => 163 | if should_work 164 | then putStrLn "error: \{err}" $> False 165 | else putStrLn "expected error: \{err}" $> True 166 | if should_work 167 | then putStrLn "ok" $> True 168 | else putStrLn "ok when it should not be ok" $> False 169 | -------------------------------------------------------------------------------- /src/Network/TLS/Record.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.Record 2 | 3 | import Utils.Bytes 4 | import Utils.Misc 5 | import Utils.Show 6 | import Data.Vect 7 | import public Network.TLS.HelloExtension 8 | import public Network.TLS.Handshake 9 | import public Network.TLS.Magic 10 | import public Network.TLS.Parsing 11 | import public Network.TLS.Wrapper 12 | 13 | public export 14 | data Record : RecordType -> Type where 15 | ChangeCipherSpec : (body : List Bits8) -> Record ChangeCipherSpec 16 | Handshake : (handshakes : List (DPair _ Handshake)) -> Record Handshake 17 | ApplicationData : (body : List Bits8) -> Record ApplicationData 18 | Alert : (AlertLevel, AlertDescription) -> Record Alert 19 | 20 | public export 21 | Show (Record type) where 22 | show (ChangeCipherSpec body) = show_record "ChangeCipherSpec" 23 | [ ("body", xxd body) 24 | ] 25 | show (Handshake handshakes) = show_record "Handshake" 26 | [ ("handshakes", show (map (\x => show x.snd) handshakes)) 27 | ] 28 | show (ApplicationData body) = show_record "ApplicationData" 29 | [ ("body", xxd body) 30 | ] 31 | show (Alert (lvl, desc)) = show_record "Alert" 32 | [ ("alert_level", show lvl) 33 | , ("alert", show desc) 34 | ] 35 | 36 | XRecord : Type 37 | XRecord = Eithers [Record ChangeCipherSpec, Record Handshake, Record ApplicationData, Record Alert] 38 | 39 | hack_record : DPair _ Record -> XRecord 40 | hack_record (ChangeCipherSpec ** x) = Left x 41 | hack_record (Handshake ** x) = Right (Left x) 42 | hack_record (ApplicationData ** x) = Right (Right (Left x)) 43 | hack_record (Alert ** x) = Right (Right (Right x)) 44 | 45 | fix_record : XRecord -> DPair _ Record 46 | fix_record (Left x) = (ChangeCipherSpec ** x) 47 | fix_record (Right (Left x)) = (Handshake ** x) 48 | fix_record (Right (Right (Left x))) = (ApplicationData ** x) 49 | fix_record (Right (Right (Right x))) = (Alert ** x) 50 | 51 | XRecordWithVersion : Type 52 | XRecordWithVersion = Eithers 53 | [ (TLSVersion, Record ChangeCipherSpec) 54 | , (TLSVersion, Record Handshake) 55 | , (TLSVersion, Record ApplicationData) 56 | , (TLSVersion, Record Alert) 57 | ] 58 | 59 | hack_record_with_version : (TLSVersion, DPair _ Record) -> XRecordWithVersion 60 | hack_record_with_version (v, (ChangeCipherSpec ** x)) = Left (v, x) 61 | hack_record_with_version (v, (Handshake ** x)) = Right (Left (v, x)) 62 | hack_record_with_version (v, (ApplicationData ** x)) = Right (Right (Left (v, x))) 63 | hack_record_with_version (v, (Alert ** x)) = Right (Right (Right (v, x))) 64 | 65 | fix_record_with_version : XRecordWithVersion -> (TLSVersion, DPair _ Record) 66 | fix_record_with_version (Left (v, x)) = (v, (ChangeCipherSpec ** x)) 67 | fix_record_with_version (Right (Left (v, x))) = (v, (Handshake ** x)) 68 | fix_record_with_version (Right (Right (Left (v, x)))) = (v, (ApplicationData ** x)) 69 | fix_record_with_version (Right (Right (Right (v, x)))) = (v, (Alert ** x)) 70 | 71 | namespace Parsing 72 | export 73 | no_id_change_cipher_spec : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (Record ChangeCipherSpec) 74 | no_id_change_cipher_spec = map (\a => ChangeCipherSpec a) (\(ChangeCipherSpec a) => a) 75 | $ lengthed_list 2 token 76 | 77 | export 78 | no_id_handshake : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (Record Handshake) 79 | no_id_handshake = map (\a => Handshake a) (\(Handshake a) => a) 80 | $ lengthed_list 2 handshake 81 | 82 | export 83 | no_id_handshake2 : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (Record Handshake) 84 | no_id_handshake2 = map (\a => Handshake a) (\(Handshake a) => a) 85 | $ lengthed_list 2 handshake2 86 | 87 | export 88 | no_id_application_data : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (Record ApplicationData) 89 | no_id_application_data = map (\a => ApplicationData a) (\(ApplicationData a) => a) 90 | $ lengthed_list 2 token 91 | 92 | export 93 | record_type_with_version : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (RecordType, TLSVersion) 94 | record_type_with_version = record_type <*>> tls_version 95 | 96 | export 97 | record_type_with_version_with_length : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (RecordType, TLSVersion, Nat) 98 | record_type_with_version_with_length = record_type <*>> tls_version <*>> nat 2 99 | 100 | export 101 | alert : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (AlertLevel, AlertDescription) 102 | alert = under "alert protocol" $ alert_level <*>> alert_description 103 | 104 | export 105 | no_id_alert : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (Record Alert) 106 | no_id_alert = map (\((), a) => Alert a) (\(Alert a) => ((), a)) $ is [0x00, 0x02] <*>> alert 107 | 108 | export 109 | with_id_with_version : (Cons (Posed Bits8) i, Monoid i) => {type : RecordType} -> Parserializer Bits8 i (SimpleError String) (Record type) -> Parserializer Bits8 i (SimpleError String) (TLSVersion, Record type) 110 | with_id_with_version pser = under (show type <+> " record") $ is (to_vect $ record_type_to_id type) *> (tls_version <*>> pser) 111 | 112 | export 113 | arecord : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (TLSVersion, DPair _ Record) 114 | arecord = 115 | map fix_record_with_version hack_record_with_version 116 | $ (with_id_with_version no_id_change_cipher_spec) 117 | <|> (with_id_with_version no_id_handshake) 118 | <|> (with_id_with_version no_id_application_data) 119 | <|> (with_id_with_version no_id_alert) 120 | 121 | export 122 | arecord2 : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (TLSVersion, DPair _ Record) 123 | arecord2 = 124 | map fix_record_with_version hack_record_with_version 125 | $ (with_id_with_version no_id_change_cipher_spec) 126 | <|> (with_id_with_version no_id_handshake2) 127 | <|> (with_id_with_version no_id_application_data) 128 | <|> (with_id_with_version no_id_alert) 129 | 130 | export 131 | alert_or_arecord : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (Either (AlertLevel, AlertDescription) (TLSVersion, DPair _ Record)) 132 | alert_or_arecord = alert <|> arecord 133 | 134 | export 135 | alert_or_arecord2 : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (Either (AlertLevel, AlertDescription) (TLSVersion, DPair _ Record)) 136 | alert_or_arecord2 = alert <|> arecord2 137 | 138 | export 139 | wrapper2 : (Cons (Posed Bits8) i, Monoid i) => {iv_size : Nat} -> {mac_size : Nat} -> Parserializer Bits8 i (SimpleError String) (RecordType, TLSVersion, Wrapper2 iv_size mac_size) 140 | wrapper2 = 141 | record_type 142 | <*>> tls_version 143 | <*>> (mapEither (\x => maybe_to_either (from_application_data2 x) (msg "cannot parse wrapper")) to_application_data2 $ lengthed_list 2 token) 144 | -------------------------------------------------------------------------------- /src/Crypto/Curve/Weierstrass.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Curve.Weierstrass 2 | 3 | import Crypto.Curve 4 | import Data.Bits 5 | import Data.List 6 | import Data.Vect 7 | import Utils.Bytes 8 | import Utils.Misc 9 | 10 | -- Weiserstrass curve y^2 = x^3 + ax + b in Jacobian coordinate 11 | public export 12 | interface WeierstrassPoint p where 13 | a_coefficent : Integer 14 | b_coefficent : Integer 15 | prime : Integer -- If this isn't prime the skinwalker will devour you 16 | to_jacobian : p -> (Integer, Integer, Integer) 17 | from_jacobian : (Integer, Integer, Integer) -> p 18 | g : p 19 | to_from_jacobian : (x : (Integer, Integer, Integer)) -> to_jacobian (from_jacobian x) = x 20 | bits' : Nat 21 | curve_n : Integer 22 | 23 | j_point_double : WeierstrassPoint p => (Integer, Integer, Integer) -> (Integer, Integer, Integer) 24 | j_point_double (x, y, z) = 25 | let modulus = prime {p=p} 26 | s = (4 * x * y * y) `mod'` modulus 27 | z4 = pow_mod z 4 modulus 28 | y4 = pow_mod y 4 modulus 29 | m = (3 * x * x + a_coefficent {p} * z4) `mod'` modulus 30 | x' = (m * m - 2 * s) `mod'` modulus 31 | y' = (m * (s - x') - 8 * y4) `mod'` modulus 32 | z' = (2 * y * z) `mod'` modulus 33 | in (x', y', z') 34 | 35 | j_point_add : WeierstrassPoint p => (Integer, Integer, Integer) -> (Integer, Integer, Integer) -> (Integer, Integer, Integer) 36 | j_point_add (x, y, 0) b = b 37 | j_point_add a (x, y, 0) = a 38 | j_point_add a@(xp, yp, zp) b@(xq, yq, zq) = 39 | let m = prime {p=p} 40 | zq2 = pow_mod zq 2 m 41 | zq3 = pow_mod zq 3 m 42 | zp2 = pow_mod zp 2 m 43 | zp3 = pow_mod zp 3 m 44 | u1 = mul_mod xp zq2 m 45 | u2 = mul_mod xq zp2 m 46 | s1 = mul_mod yp zq3 m 47 | s2 = mul_mod yq zp3 m 48 | h = u2 - u1 49 | r = s2 - s1 50 | h2 = pow_mod h 2 m 51 | h3 = mul_mod h h2 m 52 | u1h2 = mul_mod u1 h2 m 53 | nx = ((r * r) - h3 - 2 * u1h2) `mod'` m 54 | ny = (r * (u1h2 - nx) - s1 * h3) `mod'` m 55 | nz = (h * zp * zq) `mod'` m 56 | in if h == 0 then (if r == 0 then j_point_double {p=p} a else (0, 1, 0)) else (nx, ny, nz) 57 | 58 | point_double : (Point p, WeierstrassPoint p) => p -> p 59 | point_double b = from_jacobian {p=p} (j_point_double {p=p} (to_jacobian b)) 60 | 61 | mul' : (Point p, WeierstrassPoint p) => p -> p -> Nat -> Integer -> p 62 | mul' r0 r1 m d = 63 | let (r0', r1') = if testBit d m then (point_add r0 r1, point_double r1) else (point_double r0, point_add r0 r1) 64 | in case m of 65 | S m' => mul' r0' r1' m' d 66 | Z => r0' 67 | 68 | public export 69 | WeierstrassPoint p => Point p where 70 | infinity = from_jacobian (0, 1, 0) 71 | generator = g 72 | bits = bits' {p=p} 73 | to_affine point = 74 | let (x, y, z) = to_jacobian point 75 | m = prime {p=p} 76 | z' = inv_mul_mod z m 77 | z2 = z' * z' 78 | z3 = z2 * z' 79 | in (mul_mod x z2 m, mul_mod y z3 m) 80 | modulus = prime {p=p} 81 | order = curve_n {p=p} 82 | point_add a b = from_jacobian {p=p} (j_point_add {p=p} (to_jacobian a) (to_jacobian b)) 83 | mul s pt = mul' infinity pt (bits {p=p}) s 84 | 85 | encode point = 86 | let bytes = (7 + bits {p=p}) `div` 8 87 | (x', y') = to_affine point 88 | x = toList $ integer_to_be bytes x' 89 | y = toList $ integer_to_be bytes y' 90 | in 4 :: (x <+> y) 91 | 92 | decode (4 :: body) = do 93 | let bytes = (7 + bits {p=p}) `div` 8 94 | let (x', y') = splitAt bytes body 95 | x <- map be_to_integer $ exactLength bytes $ fromList x' 96 | y <- map be_to_integer $ exactLength bytes $ fromList y' 97 | 98 | -- infinity check 99 | guard $ not $ (x == 0) && (y == 0) 100 | 101 | -- check on curve 102 | let pri = modulus {p=p} 103 | let lhs = pow_mod y 2 pri 104 | let a = a_coefficent {p=p} 105 | let b = b_coefficent {p=p} 106 | let rhs = ((pow_mod x 3 pri) + (mul_mod x a pri) + b) `mod'` pri 107 | guard $ lhs == rhs 108 | 109 | pure $ from_jacobian (x, y, 1) 110 | decode _ = Nothing 111 | 112 | public export 113 | data P256 : Type where 114 | MkP256 : (Integer, Integer, Integer) -> P256 115 | 116 | public export 117 | WeierstrassPoint P256 where 118 | prime = 119 | 0xffffffff00000001000000000000000000000000ffffffffffffffffffffffff 120 | a_coefficent = 121 | 0xffffffff00000001000000000000000000000000fffffffffffffffffffffffc 122 | b_coefficent = 123 | 0x5ac635d8aa3a93e7b3ebbd55769886bc651d06b0cc53b0f63bce3c3e27d2604b 124 | from_jacobian = MkP256 125 | to_jacobian (MkP256 p) = p 126 | g = MkP256 127 | ( 0x6b17d1f2e12c4247f8bce6e563a440f277037d812deb33a0f4a13945d898c296 128 | , 0x4fe342e2fe1a7f9b8ee7eb4a7c0f9e162bce33576b315ececbb6406837bf51f5 129 | , 1 ) 130 | to_from_jacobian x = Refl 131 | bits' = 256 132 | curve_n = 133 | 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551 134 | 135 | public export 136 | data P384 : Type where 137 | MkP384 : (Integer, Integer, Integer) -> P384 138 | 139 | public export 140 | WeierstrassPoint P384 where 141 | prime = 142 | 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000ffffffff 143 | a_coefficent = 144 | 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000fffffffc 145 | b_coefficent = 146 | 0xb3312fa7e23ee7e4988e056be3f82d19181d9c6efe8141120314088f5013875ac656398d8a2ed19d2a85c8edd3ec2aef 147 | from_jacobian = MkP384 148 | to_jacobian (MkP384 p) = p 149 | g = MkP384 150 | ( 0xaa87ca22be8b05378eb1c71ef320ad746e1d3b628ba79b9859f741e082542a385502f25dbf55296c3a545e3872760ab7 151 | , 0x3617de4a96262c6f5d9e98bf9292dc29f8f41dbd289a147ce9da3113b5f0b8c00a60b1ce1d7e819d7a431d7c90ea0e5f 152 | , 1 ) 153 | to_from_jacobian x = Refl 154 | bits' = 384 155 | curve_n = 156 | 0xffffffffffffffffffffffffffffffffffffffffffffffffc7634d81f4372ddf581a0db248b0a77aecec196accc52973 157 | 158 | public export 159 | data P521 : Type where 160 | MkP521 : (Integer, Integer, Integer) -> P521 161 | 162 | public export 163 | WeierstrassPoint P521 where 164 | prime = 165 | 0x01ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff 166 | a_coefficent = 167 | 0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc 168 | b_coefficent = 169 | 0x0051953eb9618e1c9a1f929a21a0b68540eea2da725b99b315f3b8b489918ef109e156193951ec7e937b1652c0bd3bb1bf073573df883d2c34f1ef451fd46b503f00 170 | from_jacobian = MkP521 171 | to_jacobian (MkP521 p) = p 172 | g = MkP521 173 | ( 0x00c6858e06b70404e9cd9e3ecb662395b4429c648139053fb521f828af606b4d3dbaa14b5e77efe75928fe1dc127a2ffa8de3348b3c1856a429bf97e7e31c2e5bd66 174 | , 0x011839296a789a3bc0045c8a5fb42c7d1bd998f54449579b446817afbd17273e662c97ee72995ef42640c550b9013fad0761353c7086a272c24088be94769fd16650 175 | , 1 ) 176 | to_from_jacobian x = Refl 177 | bits' = 521 178 | curve_n = 179 | 0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa51868783bf2f966b7fcc0148f709a5d03bb5c9b8899c47aebb6fb71e91386409 180 | 181 | -------------------------------------------------------------------------------- /src/Network/TLS/Parsing.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.Parsing 2 | 3 | import Data.List1 4 | import Data.Vect 5 | import Utils.Bytes 6 | import public Utils.Parser 7 | 8 | namespace Parserializer 9 | ||| bidirectional serializer 10 | ||| `decode` is assumed to be the inverse of `encode` and vice versa 11 | public export 12 | record Parserializer (c : Type) (i : Type) (e : Type) (a : Type) where 13 | constructor MkParserializer 14 | encode : a -> List c 15 | decode : Parser i e a 16 | 17 | export infixr 5 <*>> 18 | 19 | export 20 | apair : (Semigroup e, Monoid i) => Parserializer c i e a -> Parserializer c i e b -> Parserializer c i e (a, b) 21 | apair ma mb = MkParserializer (\(a, b) => ma.encode a <+> mb.encode b) $ (,) <$> ma.decode <*> mb.decode 22 | 23 | ||| infixr for `apair` 24 | export 25 | (<*>>) : (Semigroup e, Monoid i) => Parserializer c i e a -> Parserializer c i e b -> Parserializer c i e (a, b) 26 | (<*>>) = apair 27 | 28 | export 29 | map : (to : a -> b) -> (from : b -> a) -> Parserializer c i e a -> Parserializer c i e b 30 | map to from pser = MkParserializer (pser.encode . from) (map to pser.decode) 31 | 32 | export 33 | mapEither : (Semigroup e, Monoid i) => (to : a -> Either e b) -> (from : b -> a) -> Parserializer c i e a -> Parserializer c i e b 34 | mapEither to from pser = MkParserializer (pser.encode . from) $ do 35 | a <- pser.decode 36 | case to a of 37 | Right b => pure b 38 | Left e => fail e 39 | 40 | export 41 | (*>) : (Semigroup e, Monoid i) => Parserializer c i e () -> Parserializer c i e a -> Parserializer c i e a 42 | ma *> mb = map snd ((),) (ma <*>> mb) 43 | 44 | export 45 | (<*) : (Semigroup e, Monoid i) => Parserializer c i e a -> Parserializer c i e () -> Parserializer c i e a 46 | ma <* mb = map fst (,()) (ma <*>> mb) 47 | 48 | export 49 | aeither : (Semigroup e, Monoid i) => Parserializer c i e a -> Parserializer c i e b -> Parserializer c i e (Either a b) 50 | aeither ma mb = MkParserializer (either ma.encode mb.encode) $ (map Left ma.decode) <|> (map Right mb.decode) 51 | 52 | export 53 | (<|>) : (Semigroup e, Monoid i) => Parserializer c i e a -> Parserializer c i e b -> Parserializer c i e (Either a b) 54 | (<|>) = aeither 55 | 56 | ||| essentially (Nat, `a`), where Nat denotes the position, usually starts with 0 57 | public export 58 | record Posed (a : Type) where 59 | constructor MkPosed 60 | pos : Nat 61 | get : a 62 | 63 | ||| `Parser.token` but for `Posed` 64 | export 65 | p_get : Cons (Posed c) i => Parser i e c 66 | p_get = map get token 67 | 68 | -- serializer utils 69 | 70 | ||| prepend the length of `body` into `n` bytes in big endian 71 | export 72 | prepend_length : (n : Nat) -> (body : List Bits8) -> List Bits8 73 | prepend_length n body = (toList $ integer_to_be n $ cast $ length body) <+> body 74 | 75 | -- parser utils 76 | 77 | ||| parse the next `n` bytes as a natural number in big endian style 78 | export 79 | p_nat : (Semigroup e, Monoid i, Cons (Posed Bits8) i) => (n : Nat) -> Parser i e Nat 80 | p_nat n = cast {to = Nat} . be_to_integer <$> count n p_get 81 | 82 | ||| make sure that `p` MUST consume at least `n` tokens, fails otherwise 83 | public export 84 | p_exact : (Cons c i, Monoid i) => (n : Nat) -> (p : Parser i (SimpleError String) a) -> Parser i (SimpleError String) a 85 | p_exact Z (Pure leftover x) = pure x 86 | p_exact (S i) (Pure leftover x) = fail $ msg $ "over fed, " <+> show (S i) <+> " bytes more to go" 87 | p_exact i (Fail msg) = fail msg 88 | p_exact Z parser = fail $ msg $ "under fed, wants more" 89 | p_exact (S i) parser = do 90 | b <- token 91 | p_exact i (feed (singleton b) parser) 92 | 93 | --- parserializer utils 94 | 95 | ||| put parser error messages under another message 96 | ||| used for creating a treeish error message 97 | export 98 | under : e -> Parserializer c i (SimpleError e) a -> Parserializer c i (SimpleError e) a 99 | under msg pser = MkParserializer pser.encode (under msg pser.decode) 100 | 101 | ||| parserialize a single posed token 102 | export 103 | token : (Semigroup e, Cons (Posed c) i, Monoid i) => Parserializer c i e c 104 | token = MkParserializer pure p_get 105 | 106 | ||| parserialize `n` posed tokens 107 | export 108 | ntokens : (Semigroup e, Cons (Posed c) i, Monoid i) => (n : Nat) -> Parserializer c i e (Vect n c) 109 | ntokens n = MkParserializer (toList) (count n p_get) 110 | 111 | ||| parserialize the next `n` bytes in big endian style as a length describing the number of bytes of the following data to be fed to `pser` 112 | export 113 | lengthed : (Cons (Posed Bits8) i, Monoid i) => (n : Nat) -> (pser : Parserializer Bits8 i (SimpleError String) a) -> Parserializer Bits8 i (SimpleError String) a 114 | lengthed n pser = MkParserializer (prepend_length n . pser.encode) $ do 115 | len <- p_nat n 116 | p_exact len pser.decode 117 | 118 | ||| parserialize the next `n` bytes in big endian style as a length describing the number of bytes of the following data to be fed to `pser` 119 | ||| when `pser` completes, the result becomes an entry in the resulting list 120 | ||| when there are exactly zero bytes left, the list of results is returned 121 | ||| if under feeding `pser` for the last entry, the parser fails 122 | export 123 | lengthed_list : (Cons (Posed Bits8) i, Monoid i) => (n : Nat) -> (pser : Parserializer Bits8 i (SimpleError String) a) -> Parserializer Bits8 i (SimpleError String) (List a) 124 | lengthed_list youmu pser = MkParserializer (prepend_length youmu . concat . map pser.encode) $ do 125 | S len <- p_nat youmu 126 | | Z => pure [] 127 | go (S len) pser.decode 128 | where 129 | go : Nat -> Parser i (SimpleError String) a -> Parser i (SimpleError String) (List a) 130 | go Z (Pure leftover x) = pure [x] 131 | go (S i) (Pure leftover x) = (x ::) <$> go (S i) pser.decode 132 | go i (Fail msg) = fail msg 133 | go Z parser = fail $ msg $ "under fed, want more" 134 | go (S i) parser = do 135 | b <- token 136 | go i (feed (singleton b) parser) 137 | 138 | ||| `lengthed_list` but `List1` 139 | export 140 | lengthed_list1 : (Cons (Posed Bits8) i, Monoid i) => (youmu : Nat) -> Parserializer Bits8 i (SimpleError String) a -> Parserializer Bits8 i (SimpleError String) (List1 a) 141 | lengthed_list1 youmu pser = 142 | let 143 | pser' = lengthed_list youmu pser 144 | in 145 | MkParserializer (pser'.encode . toList) $ do 146 | (x :: xs) <- pser'.decode 147 | | [] => fail $ msg $ "empty list" 148 | pure (x ::: xs) 149 | 150 | ||| basically the parserializer version of `p_nat` 151 | export 152 | nat : Semigroup e => (Cons (Posed Bits8) i, Monoid i) => (n : Nat) -> Parserializer Bits8 i e Nat 153 | nat n = MkParserializer (toList . integer_to_be n . cast) (p_nat n) 154 | 155 | ||| parserialize a list of bytes with nice error messages specialized for displaying byte sequences 156 | export 157 | is : (Cons (Posed Bits8) i, Monoid i) => {k : Nat} -> Vect (S k) Bits8 -> Parserializer Bits8 i (SimpleError String) () 158 | is cs = MkParserializer (const $ toList cs) $ do 159 | bs <- count (S k) token 160 | let cs' = map get bs 161 | case cs == cs' of 162 | True => pure () 163 | False => 164 | let 165 | (begin, end) = mapHom pos (head bs, last bs) 166 | in 167 | fail $ msg $ "at position " <+> show begin <+> "-" <+> show end <+> ", expected " <+> xxd (toList cs) <+> " but got " <+> xxd (toList cs') 168 | -------------------------------------------------------------------------------- /src/Network/TLS/AEAD.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.AEAD 2 | 3 | import Data.Stream 4 | import Data.Bits 5 | import Data.Vect 6 | import Data.List 7 | import Utils.Misc 8 | import Utils.Bytes 9 | import Crypto.AES.Big 10 | import Crypto.AES.Common 11 | import Crypto.Hash 12 | import Crypto.Hash.GHash 13 | import Crypto.Hash.Poly1305 14 | import Crypto.ChaCha 15 | 16 | public export 17 | interface AEAD (0 a : Type) where 18 | ||| IV generated during key exchange 19 | fixed_iv_length : Nat 20 | enc_key_length : Nat 21 | mac_length : Nat 22 | mac_key_length : Nat 23 | ||| Part of IV that is sent along with the ciphertext, should always be 0 in TLS 1.3 24 | record_iv_length : Nat 25 | 26 | encrypt : Vect enc_key_length Bits8 -> Vect fixed_iv_length Bits8 -> Vect mac_key_length Bits8 -> Nat -> 27 | (plaintext : List Bits8) -> (aad : List Bits8) -> (Vect record_iv_length Bits8, List Bits8, Vect mac_length Bits8) 28 | decrypt : Vect enc_key_length Bits8 -> Vect fixed_iv_length Bits8 -> Vect record_iv_length Bits8 -> Vect mac_key_length Bits8 -> Nat -> 29 | (ciphertext : List Bits8) -> (plaintext_to_aad : List Bits8 -> List Bits8) -> (mac_tag : List Bits8) -> (List Bits8, Bool) 30 | 31 | aes_pad_iv_block : {iv : Nat} -> Vect iv Bits8 -> Stream (Vect (iv+4) Bits8) 32 | aes_pad_iv_block iv = map ((iv ++) . to_be . (cast {to=Bits32})) $ drop 2 nats 33 | 34 | aes_keystream : (mode : Mode) -> Vect ((get_n_k mode) * 4) Bits8 -> Vect 12 Bits8 -> Stream Bits8 35 | aes_keystream mode key iv = 36 | stream_concat $ map (toList . encrypt_block mode key) (aes_pad_iv_block iv) 37 | 38 | aes_gcm_create_aad : (mode : Mode) -> Vect ((get_n_k mode) * 4) Bits8 -> Vect 12 Bits8 -> List Bits8 -> List Bits8 -> Vect 16 Bits8 39 | aes_gcm_create_aad mode key iv aad ciphertext = 40 | let a = toList $ to_be {n=8} $ cast {to=Bits64} $ 8 * (length aad) 41 | c = toList $ to_be {n=8} $ cast {to=Bits64} $ 8 * (length ciphertext) 42 | input = pad_zero 16 aad <+> pad_zero 16 ciphertext <+> a <+> c 43 | h = encrypt_block mode key (replicate _ 0) 44 | output = mac GHash h input 45 | j0 = encrypt_block mode key (iv ++ (to_be $ the Bits32 1)) 46 | in zipWith xor j0 output 47 | 48 | public export 49 | data TLS13_AES_128_GCM : Type where 50 | 51 | public export 52 | AEAD TLS13_AES_128_GCM where 53 | fixed_iv_length = 12 54 | enc_key_length = 16 55 | mac_length = 16 56 | mac_key_length = 0 57 | record_iv_length = 0 58 | 59 | encrypt key iv mac_key seq_no plaintext aad = 60 | let iv' = zipWith xor iv $ integer_to_be _ $ natToInteger seq_no 61 | ciphertext = zipWith xor plaintext (toList $ Stream.take (length plaintext) $ aes_keystream AES128 key iv') 62 | mac_tag = aes_gcm_create_aad AES128 key iv' aad ciphertext 63 | in ([], ciphertext, mac_tag) 64 | 65 | decrypt key iv [] mac_key seq_no ciphertext aadf mac_tag' = 66 | let iv' = zipWith xor iv $ integer_to_be _ $ natToInteger seq_no 67 | plaintext = zipWith xor ciphertext (toList $ Stream.take (length ciphertext) $ aes_keystream AES128 key iv') 68 | mac_tag = aes_gcm_create_aad AES128 key iv' (aadf plaintext) ciphertext 69 | in (plaintext, s_eq' (toList mac_tag) mac_tag') 70 | 71 | public export 72 | data TLS12_AES_128_GCM : Type where 73 | 74 | public export 75 | AEAD TLS12_AES_128_GCM where 76 | fixed_iv_length = 4 77 | enc_key_length = 16 78 | mac_length = 16 79 | mac_key_length = 0 80 | record_iv_length = 8 81 | 82 | encrypt key iv mac_key seq_no plaintext aad = 83 | let explicit_iv = to_be {n=8} $ cast {to=Bits64} seq_no 84 | iv' = iv ++ explicit_iv 85 | ciphertext = zipWith xor plaintext (toList $ Stream.take (length plaintext) $ aes_keystream AES128 key iv') 86 | mac_tag = aes_gcm_create_aad AES128 key iv' aad ciphertext 87 | in (explicit_iv, ciphertext, mac_tag) 88 | 89 | decrypt key iv explicit_iv mac_key seq_no ciphertext aadf mac_tag' = 90 | let iv' = iv ++ explicit_iv 91 | plaintext = zipWith xor ciphertext (toList $ Stream.take (length ciphertext) $ aes_keystream AES128 key iv') 92 | mac_tag = aes_gcm_create_aad AES128 key iv' (aadf plaintext) ciphertext 93 | in (plaintext, s_eq' (toList mac_tag) mac_tag') 94 | 95 | public export 96 | data TLS13_AES_256_GCM : Type where 97 | 98 | public export 99 | AEAD TLS13_AES_256_GCM where 100 | fixed_iv_length = 12 101 | enc_key_length = 32 102 | mac_length = 16 103 | mac_key_length = 0 104 | record_iv_length = 0 105 | 106 | encrypt key iv mac_key seq_no plaintext aad = 107 | let iv' = zipWith xor iv $ integer_to_be _ $ natToInteger seq_no 108 | ciphertext = zipWith xor plaintext (toList $ Stream.take (length plaintext) $ aes_keystream AES256 key iv') 109 | mac_tag = aes_gcm_create_aad AES256 key iv' aad ciphertext 110 | in ([], ciphertext, mac_tag) 111 | 112 | decrypt key iv [] mac_key seq_no ciphertext aadf mac_tag' = 113 | let iv' = zipWith xor iv $ integer_to_be _ $ natToInteger seq_no 114 | plaintext = zipWith xor ciphertext (toList $ Stream.take (length ciphertext) $ aes_keystream AES256 key iv') 115 | mac_tag = aes_gcm_create_aad AES256 key iv' (aadf plaintext) ciphertext 116 | in (plaintext, s_eq' (toList mac_tag) mac_tag') 117 | 118 | public export 119 | data TLS12_AES_256_GCM : Type where 120 | 121 | public export 122 | AEAD TLS12_AES_256_GCM where 123 | fixed_iv_length = 4 124 | enc_key_length = 32 125 | mac_length = 16 126 | mac_key_length = 0 127 | record_iv_length = 8 128 | 129 | encrypt key iv mac_key seq_no plaintext aad = 130 | let explicit_iv = to_be {n=8} $ cast {to=Bits64} seq_no 131 | iv' = iv ++ explicit_iv 132 | ciphertext = zipWith xor plaintext (toList $ Stream.take (length plaintext) $ aes_keystream AES256 key iv') 133 | mac_tag = aes_gcm_create_aad AES256 key iv' aad ciphertext 134 | in (explicit_iv, ciphertext, mac_tag) 135 | 136 | decrypt key iv explicit_iv mac_key seq_no ciphertext aadf mac_tag' = 137 | let iv' = iv ++ explicit_iv 138 | plaintext = zipWith xor ciphertext (toList $ Stream.take (length ciphertext) $ aes_keystream AES256 key iv') 139 | mac_tag = aes_gcm_create_aad AES256 key iv' (aadf plaintext) ciphertext 140 | in (plaintext, s_eq' (toList mac_tag) mac_tag') 141 | 142 | chacha_create_aad : Vect 64 Bits8 -> List Bits8 -> List Bits8 -> Vect 16 Bits8 143 | chacha_create_aad polykey aad ciphertext = 144 | let key = take 32 polykey 145 | length_aad = toList $ to_le {n=8} $ cast {to=Bits64} $ length aad 146 | length_ciphertext = toList $ to_le {n=8} $ cast {to=Bits64} $ length ciphertext 147 | input = pad_zero 16 aad ++ pad_zero 16 ciphertext ++ length_aad ++ length_ciphertext 148 | in mac Poly1305 key input 149 | 150 | public export 151 | data TLS1213_ChaCha20_Poly1305 : Type where 152 | 153 | public export 154 | AEAD TLS1213_ChaCha20_Poly1305 where 155 | fixed_iv_length = 12 156 | enc_key_length = 32 157 | mac_length = 16 158 | mac_key_length = 0 159 | record_iv_length = 0 160 | 161 | encrypt key iv [] seq_no plaintext aad = 162 | let k' = from_le {n=4} <$> group 8 4 key 163 | iv' = zipWith xor iv $ integer_to_be _ $ natToInteger seq_no 164 | i' = from_le {n=4} <$> group 3 4 iv' 165 | (polykey :: keystream) = map (\c => chacha_rfc8439_block 10 (cast c) k' i') nats 166 | ciphertext = zipWith xor plaintext (toList $ Stream.take (length plaintext) $ stream_concat keystream) 167 | auth_tag = chacha_create_aad polykey aad ciphertext 168 | in ([], ciphertext, auth_tag) 169 | 170 | decrypt key iv [] [] seq_no ciphertext aadf mac_tag' = 171 | let k' = from_le {n=4} <$> group 8 4 key 172 | iv' = zipWith xor iv $ integer_to_be _ $ natToInteger seq_no 173 | i' = from_le {n=4} <$> group 3 4 iv' 174 | (polykey :: keystream) = map (\c => chacha_rfc8439_block 10 (cast c) k' i') nats 175 | plaintext = zipWith xor ciphertext (toList $ Stream.take (length ciphertext) $ stream_concat keystream) 176 | auth_tag = chacha_create_aad polykey (aadf plaintext) ciphertext 177 | in (plaintext, toList auth_tag `s_eq'` mac_tag') 178 | -------------------------------------------------------------------------------- /src/Network/TLS/HKDF.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.HKDF 2 | 3 | import Crypto.Hash 4 | import Crypto.Hash.HMAC 5 | import Data.Bits 6 | import Data.List 7 | import Data.Stream 8 | import Data.Stream.Extra 9 | import Data.Vect 10 | import Utils.Bytes 11 | import Utils.Misc 12 | 13 | public export 14 | hkdf_extract : (0 algo : Type) -> Hash algo => List Bits8 -> List Bits8 -> Vect (digest_nbyte {algo}) Bits8 15 | hkdf_extract algo salt ikm = mac (HMAC algo) salt ikm 16 | 17 | hkdf_expand_stream : (0 algo : Type) -> Hash algo => List Bits8 -> List Bits8 -> Stream Bits8 18 | hkdf_expand_stream algo prk info = stream_concat (snd <$> iterate go (Z, [])) 19 | where 20 | go : (Nat, List Bits8) -> (Nat, List Bits8) 21 | go (i, last) = 22 | let i' = cast {to=Bits8} (S i) 23 | body = last ++ info ++ [i'] 24 | in (S i, toList $ mac (HMAC algo) prk body) 25 | 26 | public export 27 | hkdf_expand : (0 algo : Type) -> Hash algo => (l : Nat) -> List Bits8 -> List Bits8 -> Vect l Bits8 28 | hkdf_expand algo l prk info = take l $ hkdf_expand_stream algo prk info 29 | 30 | tls13_constant : List Bits8 31 | tls13_constant = string_to_ascii "tls13 " 32 | 33 | export 34 | tls13_hkdf_expand_label : (0 algo : Type) -> Hash algo => (secret : List Bits8) -> (label : List Bits8) -> (context : List Bits8) -> (length : Nat) -> Vect length Bits8 35 | tls13_hkdf_expand_label algo secret label context lth = 36 | let l = to_be {n=2} $ cast {to=Bits16} lth 37 | l' = cast {to=Bits8} $ (6 + length label) 38 | i' = cast {to=Bits8} $ length context 39 | body = ((toList l) <+> [l'] <+> tls13_constant <+> label <+> [i'] <+> context) 40 | in hkdf_expand algo lth secret body 41 | 42 | public export 43 | record HandshakeKeys (iv : Nat) (key : Nat) where 44 | constructor MkHandshakeKeys 45 | handshake_secret : List Bits8 46 | client_handshake_key : Vect key Bits8 47 | server_handshake_key : Vect key Bits8 48 | client_handshake_iv : Vect iv Bits8 49 | server_handshake_iv : Vect iv Bits8 50 | client_traffic_secret : List Bits8 51 | server_traffic_secret : List Bits8 52 | 53 | public export 54 | record ApplicationKeys (iv : Nat) (key : Nat) where 55 | constructor MkApplicationKeys 56 | client_application_key : Vect key Bits8 57 | server_application_key : Vect key Bits8 58 | client_application_iv : Vect iv Bits8 59 | server_application_iv : Vect iv Bits8 60 | 61 | export 62 | tls13_handshake_derive : (0 algo : Type) -> Hash algo => (iv : Nat) -> (key : Nat) -> List Bits8 -> List Bits8 -> HandshakeKeys iv key 63 | tls13_handshake_derive algo iv key shared_secret hello_hash = 64 | let zeros = List.replicate (digest_nbyte {algo}) (the Bits8 0) 65 | early_secret = toList $ hkdf_extract algo [the Bits8 0] zeros 66 | empty_hash = toList $ hash algo [] 67 | derived_secret = tls13_hkdf_expand_label algo early_secret (string_to_ascii "derived") empty_hash $ digest_nbyte {algo} 68 | handshake_secret = toList $ hkdf_extract algo (toList derived_secret) shared_secret 69 | client_handshake_traffic_secret = toList $ 70 | tls13_hkdf_expand_label algo handshake_secret (string_to_ascii "c hs traffic") hello_hash $ digest_nbyte {algo} 71 | server_handshake_traffic_secret = toList $ 72 | tls13_hkdf_expand_label algo handshake_secret (string_to_ascii "s hs traffic") hello_hash $ digest_nbyte {algo} 73 | client_handshake_key = 74 | tls13_hkdf_expand_label algo client_handshake_traffic_secret (string_to_ascii "key") [] key 75 | client_handshake_iv = 76 | tls13_hkdf_expand_label algo client_handshake_traffic_secret (string_to_ascii "iv") [] iv 77 | server_handshake_key = 78 | tls13_hkdf_expand_label algo server_handshake_traffic_secret (string_to_ascii "key") [] key 79 | server_handshake_iv = 80 | tls13_hkdf_expand_label algo server_handshake_traffic_secret (string_to_ascii "iv") [] iv 81 | in MkHandshakeKeys 82 | handshake_secret 83 | client_handshake_key 84 | server_handshake_key 85 | client_handshake_iv 86 | server_handshake_iv 87 | (toList client_handshake_traffic_secret) 88 | (toList server_handshake_traffic_secret) 89 | 90 | public export 91 | tls13_application_derive : {iv : Nat} -> {key : Nat} -> (0 algo : Type) -> Hash algo => HandshakeKeys iv key -> List Bits8 -> ApplicationKeys iv key 92 | tls13_application_derive algo (MkHandshakeKeys handshake_secret _ _ _ _ _ _) handshake_hash = 93 | let zeros = List.replicate (digest_nbyte {algo}) (the Bits8 0) 94 | empty_hash = toList $ hash algo [] 95 | derived_secret = 96 | tls13_hkdf_expand_label algo handshake_secret (string_to_ascii "derived") empty_hash $ digest_nbyte {algo} 97 | master_secret = toList $ hkdf_extract algo (toList derived_secret) zeros 98 | client_application_traffic_secret = toList $ 99 | tls13_hkdf_expand_label algo master_secret (string_to_ascii "c ap traffic") handshake_hash $ digest_nbyte {algo} 100 | server_application_traffic_secret = toList $ 101 | tls13_hkdf_expand_label algo master_secret (string_to_ascii "s ap traffic") handshake_hash $ digest_nbyte {algo} 102 | client_application_key = 103 | tls13_hkdf_expand_label algo client_application_traffic_secret (string_to_ascii "key") [] key 104 | client_application_iv = 105 | tls13_hkdf_expand_label algo client_application_traffic_secret (string_to_ascii "iv") [] iv 106 | server_application_key = 107 | tls13_hkdf_expand_label algo server_application_traffic_secret (string_to_ascii "key") [] key 108 | server_application_iv = 109 | tls13_hkdf_expand_label algo server_application_traffic_secret (string_to_ascii "iv") [] iv 110 | in MkApplicationKeys client_application_key server_application_key client_application_iv server_application_iv 111 | 112 | public export 113 | tls13_verify_data : (0 algo : Type) -> Hash algo => List Bits8 -> List Bits8 -> List Bits8 114 | tls13_verify_data algo traffic_secret records_hash = 115 | let finished_key = toList $ 116 | tls13_hkdf_expand_label algo traffic_secret (string_to_ascii "finished") [] $ digest_nbyte {algo} 117 | in toList $ hkdf_extract algo finished_key records_hash 118 | 119 | public export 120 | record Application2Keys (iv : Nat) (key : Nat) (mac : Nat) where 121 | constructor MkApplication2Keys 122 | master_secret : Vect 48 Bits8 123 | client_mac_key : Vect mac Bits8 124 | server_mac_key : Vect mac Bits8 125 | client_application_key : Vect key Bits8 126 | server_application_key : Vect key Bits8 127 | client_application_iv : Vect iv Bits8 128 | server_application_iv : Vect iv Bits8 129 | 130 | hmac_stream : Hash algo -> List Bits8 -> List Bits8 -> Stream Bits8 131 | hmac_stream hwit secret seed = 132 | stream_concat 133 | $ map (\ax => toList $ mac (HMAC algo) secret $ ax <+> seed) 134 | $ drop 1 135 | $ iterate (toList . mac (HMAC algo) secret) seed 136 | 137 | public export 138 | tls12_application_derive : Hash algo -> (iv : Nat) -> (key : Nat) -> (mac : Nat) -> List Bits8 -> List Bits8 -> List Bits8 -> 139 | Application2Keys iv key mac 140 | tls12_application_derive hwit iv key mac shared_secret client_random server_random = 141 | let master_secret = 142 | Stream.take 48 143 | $ hmac_stream hwit shared_secret 144 | $ (string_to_ascii "master secret") <+> client_random <+> server_random 145 | secret_material = 146 | hmac_stream hwit 147 | (toList master_secret) 148 | (string_to_ascii "key expansion" <+> server_random <+> client_random) 149 | (client_mac_key, secret_material) = Misc.splitAt mac secret_material 150 | (server_mac_key, secret_material) = Misc.splitAt mac secret_material 151 | (client_application_key, secret_material) = Misc.splitAt key secret_material 152 | (server_application_key, secret_material) = Misc.splitAt key secret_material 153 | (client_application_iv, secret_material) = Misc.splitAt iv secret_material 154 | (server_application_iv, secret_material) = Misc.splitAt iv secret_material 155 | in MkApplication2Keys 156 | master_secret 157 | client_mac_key 158 | server_mac_key 159 | client_application_key 160 | server_application_key 161 | client_application_iv 162 | server_application_iv 163 | 164 | public export 165 | tls12_client_verify_data : Hash algo -> (n : Nat) -> List Bits8 -> List Bits8 -> Vect n Bits8 166 | tls12_client_verify_data algo n master_secret records_hash = 167 | take _ $ hmac_stream algo master_secret (string_to_ascii "client finished" <+> records_hash) 168 | 169 | public export 170 | tls12_server_verify_data : Hash algo -> (n : Nat) -> List Bits8 -> List Bits8 -> Vect n Bits8 171 | tls12_server_verify_data algo n master_secret records_hash = 172 | take _ $ hmac_stream algo master_secret (string_to_ascii "server finished" <+> records_hash) 173 | -------------------------------------------------------------------------------- /src/Network/TLS/Parse/DER.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.Parse.DER 2 | 3 | import Data.List1 4 | import Data.Bits 5 | import Data.Vect 6 | import Utils.Bytes 7 | import Utils.Parser 8 | import Network.TLS.Parsing 9 | import Utils.Misc 10 | import public Utils.Time 11 | 12 | import Debug.Trace 13 | 14 | public export 15 | data TagType : Type where 16 | Universal : TagType 17 | Application : TagType 18 | ContextSpecific : TagType 19 | Private : TagType 20 | 21 | public export 22 | Show TagType where 23 | show Universal = "Universal" 24 | show Application = "Application" 25 | show ContextSpecific = "ContextSpecific" 26 | show Private = "Private" 27 | 28 | public export 29 | record Tag where 30 | constructor MkTag 31 | type : TagType 32 | tag_id : Nat 33 | 34 | public export 35 | Show Tag where 36 | show tag = "(" <+> show tag.type <+> ", " <+> show tag.tag_id <+> ")" 37 | 38 | export 39 | is_constructed : Bits8 -> Bool 40 | is_constructed tag = testBit tag 5 41 | 42 | public export 43 | record BitArray where 44 | constructor MkBitArray 45 | padding : Nat 46 | bytes : List Bits8 47 | 48 | public export 49 | data ASN1 : TagType -> Nat -> Type where 50 | Boolean : Bool -> ASN1 Universal 0x01 51 | IntVal : Integer -> ASN1 Universal 0x02 52 | Bitstring : BitArray -> ASN1 Universal 0x03 53 | OctetString : List Bits8 -> ASN1 Universal 0x04 54 | Null : ASN1 Universal 0x05 55 | OID : List Nat -> ASN1 Universal 0x06 56 | PrintableString : String -> ASN1 Universal 0x13 57 | T61String : String -> ASN1 Universal 0x14 58 | IA5String : String -> ASN1 Universal 0x16 59 | UTF8String : String -> ASN1 Universal 0x0C 60 | Sequence : List (t ** n ** ASN1 t n) -> ASN1 Universal 0x10 -- 0x30 & 31 61 | Set : List (t ** n ** ASN1 t n) -> ASN1 Universal 0x11 -- 0x31 & 31 62 | UTCTime : DateTime -> ASN1 Universal 0x17 63 | GeneralizedTime : DateTime -> ASN1 Universal 0x18 64 | UnknownConstructed : (t : TagType) -> (n : Nat) -> List (t ** n ** ASN1 t n) -> ASN1 t n 65 | UnknownPrimitive : (t : TagType) -> (n : Nat) -> List Bits8 -> ASN1 t n 66 | 67 | public export 68 | Eq BitArray where 69 | (MkBitArray a b) == (MkBitArray c d) = (a == c) && (b == d) 70 | 71 | export 72 | constraint_parse : (Cons (Posed Bits8) i, Monoid i) => (n : Nat) -> 73 | (pser : Parser i (SimpleError String) a) -> 74 | Parser i (SimpleError String) (List a) 75 | constraint_parse Z pser = pure [] 76 | constraint_parse (S len) pser = go (S len) pser 77 | where 78 | go : Nat -> Parser i (SimpleError String) a -> Parser i (SimpleError String) (List a) 79 | go Z (Pure leftover x) = pure [x] 80 | go (S i) (Pure leftover x) = (x ::) <$> go (S i) pser 81 | go i (Fail msg) = fail msg 82 | go Z parser = fail $ msg $ "under fed, want more" 83 | go (S i) parser = do 84 | b <- token 85 | go i (feed (singleton b) parser) 86 | 87 | export 88 | parse_length : (Monoid i, Cons (Posed Bits8) i) => Parser i (SimpleError String) Nat 89 | parse_length = do 90 | b <- p_get 91 | let b' = b .&. 0x7F 92 | if b' == b 93 | then pure $ cast b 94 | else p_nat (cast b') 95 | 96 | extract_tag_type_bits : Bits8 -> TagType 97 | extract_tag_type_bits x = 98 | case get_bits x of 99 | [ False, False ] => Universal 100 | [ False, True ] => Application 101 | [ True, False ] => ContextSpecific 102 | [ True, True ] => Private 103 | where 104 | get_bits : Bits8 -> Vect 2 Bool 105 | get_bits x = [ (testBit x 7), (testBit x 6) ] 106 | 107 | export 108 | parse_tag_id : (Monoid i, Cons (Posed Bits8) i) => Parser i (SimpleError String) (Bool, Tag) 109 | parse_tag_id = do 110 | b <- p_get 111 | let construct = is_constructed b 112 | let type = extract_tag_type_bits b 113 | let id = b .&. 31 114 | if id == 31 115 | then (\x => (construct, MkTag type x)) <$> parse_length 116 | else pure (construct, MkTag type $ cast id) 117 | 118 | export 119 | signed_be_to_integer : List1 Bits8 -> Integer 120 | signed_be_to_integer l@(x ::: xs) = 121 | let is_neg = testBit x 7 122 | v = be_to_integer l 123 | m = (shiftL 1 (8 * (length l))) - 1 -- 2^n - 1 124 | in if is_neg then v .|. (complement m) else v 125 | 126 | export 127 | decode_oid_nodes : Bits8 -> List Bits8 -> List Nat 128 | decode_oid_nodes first_node nodes = 129 | let a = first_node `div` 40 130 | b = first_node `mod` 40 131 | (_, result) = foldl go (0, []) nodes 132 | nodes = cast a :: cast b :: reverse result 133 | in integerToNat <$> nodes 134 | where 135 | go : (Integer, List Integer) -> Bits8 -> (Integer, List Integer) 136 | go (value, result) byte = 137 | let value = (shiftL value 7) .|. cast (byte .&. 0x7F) 138 | in if byte >= 0x80 then (value, result) else (0, value :: result) 139 | 140 | export 141 | parse_boolean : (Cons (Posed Bits8) i, Monoid i) => Nat -> Parser i (SimpleError String) Bool 142 | parse_boolean 1 = map (/= 0) p_get 143 | parse_boolean n = fail $ msg $ "boolean length should be 1, got: " <+> show n 144 | 145 | export 146 | parse_integer : (Cons (Posed Bits8) i, Monoid i) => Nat -> Parser i (SimpleError String) Integer 147 | parse_integer n = do 148 | bits <- count n p_get 149 | case fromList $ toList bits of 150 | Just x => pure $ signed_be_to_integer x 151 | Nothing => fail $ msg "integer length is 0" 152 | 153 | export 154 | parse_bitarray : (Cons (Posed Bits8) i, Monoid i) => Nat -> Parser i (SimpleError String) BitArray 155 | parse_bitarray Z = fail $ msg "bitarray length is 0" 156 | parse_bitarray (S n) = do 157 | pad_len <- p_get 158 | bits <- toList <$> count n p_get 159 | pure $ MkBitArray (cast pad_len) bits 160 | 161 | export 162 | parse_null : (Cons (Posed Bits8) i, Monoid i) => Nat -> Parser i (SimpleError String) () 163 | parse_null Z = pure () 164 | parse_null n = fail $ msg $ "null length should be 0, got: " <+> show n 165 | 166 | export 167 | parse_oid : (Cons (Posed Bits8) i, Monoid i) => Nat -> Parser i (SimpleError String) (List Nat) 168 | parse_oid Z = fail $ msg "oid length is 0" 169 | parse_oid (S n) = do 170 | first_node <- p_get 171 | nodes <- toList <$> count n p_get 172 | pure $ decode_oid_nodes first_node nodes 173 | 174 | export 175 | parse_time : (Cons (Posed Bits8) i, Monoid i) => Nat -> (String -> Either String DateTime) -> Parser i (SimpleError String) DateTime 176 | parse_time len f = do 177 | str <- count len p_get 178 | case f $ ascii_to_string $ toList str of 179 | Right datetime => pure datetime 180 | Left err => fail $ msg err 181 | 182 | export 183 | parse_utf8 : (Cons (Posed Bits8) i, Monoid i) => Nat -> Parser i (SimpleError String) String 184 | parse_utf8 len = do 185 | str <- count len p_get 186 | case utf8_decode $ toList str of 187 | Just str => pure str 188 | Nothing => fail $ msg "invalid utf8 string" 189 | 190 | public export 191 | ASN1Token : Type 192 | ASN1Token = (t ** n ** ASN1 t n) 193 | 194 | export 195 | extract_string : ASN1Token -> Maybe String 196 | extract_string (Universal ** 12 ** UTF8String b) = Just b 197 | extract_string (Universal ** 19 ** PrintableString b) = Just b 198 | extract_string (Universal ** 20 ** T61String b) = Just b 199 | extract_string (Universal ** 22 ** IA5String b) = Just b 200 | extract_string _ = Nothing 201 | 202 | export 203 | extract_epoch : ASN1Token -> Maybe Integer 204 | extract_epoch (Universal ** 23 ** UTCTime time) = Just $ datetime_to_epoch time 205 | extract_epoch (Universal ** 24 ** GeneralizedTime time) = Just $ datetime_to_epoch time 206 | extract_epoch _ = Nothing 207 | 208 | export 209 | parse_asn1 : (Monoid i, Cons (Posed Bits8) i) => Parser i (SimpleError String) ASN1Token 210 | parse_asn1 = do 211 | tag' <- parse_tag_id 212 | len <- parse_length 213 | case tag' of 214 | (False, MkTag Universal 1) => (\b => (Universal ** 1 ** Boolean b)) <$> parse_boolean len 215 | (False, MkTag Universal 2) => (\b => (Universal ** 2 ** IntVal b)) <$> parse_integer len 216 | (False, MkTag Universal 3) => (\b => (Universal ** 3 ** Bitstring b)) <$> parse_bitarray len 217 | (False, MkTag Universal 4) => (\b => (Universal ** 4 ** OctetString $ toList b)) <$> count len p_get 218 | (False, MkTag Universal 5) => (\b => (Universal ** 5 ** Null)) <$> parse_null len 219 | (False, MkTag Universal 6) => (\b => (Universal ** 6 ** OID b)) <$> parse_oid len 220 | (False, MkTag Universal 12) => (\b => (Universal ** 12 ** UTF8String b)) <$> parse_utf8 len 221 | (False, MkTag Universal 19) => (\b => (Universal ** 19 ** PrintableString $ ascii_to_string $ toList b)) <$> count len p_get 222 | (False, MkTag Universal 20) => (\b => (Universal ** 20 ** T61String $ ascii_to_string $ toList b)) <$> count len p_get 223 | (False, MkTag Universal 22) => (\b => (Universal ** 22 ** IA5String $ ascii_to_string $ toList b)) <$> count len p_get 224 | (False, MkTag Universal 23) => (\b => (Universal ** 23 ** UTCTime b)) <$> parse_time len parse_utc_time 225 | (False, MkTag Universal 24) => (\b => (Universal ** 24 ** GeneralizedTime b)) <$> parse_time len parse_generalized_time 226 | (True, MkTag Universal 16) => (\b => (Universal ** 16 ** Sequence b)) <$> constraint_parse len parse_asn1 227 | (True, MkTag Universal 17) => (\b => (Universal ** 17 ** Set b)) <$> constraint_parse len parse_asn1 228 | (True, MkTag t n) => (\b => (t ** n ** UnknownConstructed t n b)) <$> constraint_parse len parse_asn1 229 | (False, MkTag t n) => (\b => (t ** n ** UnknownPrimitive t n $ toList b)) <$> count len p_get 230 | -------------------------------------------------------------------------------- /src/Network/TLS/Signature.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.Signature 2 | 3 | import Data.List 4 | import Data.Vect 5 | import Utils.Misc 6 | import Utils.Bytes 7 | import Utils.Parser 8 | import Network.TLS.Parse.PEM 9 | import Network.TLS.Parse.DER 10 | import Network.TLS.Parsing 11 | import Data.String.Parser 12 | import Crypto.RSA 13 | import Crypto.Curve 14 | import Crypto.Curve.Weierstrass 15 | import Crypto.Hash 16 | import Crypto.Hash.OID 17 | 18 | public export 19 | data PublicKey : Type where 20 | RsaPublicKey : RSAPublicKey -> PublicKey 21 | EcdsaPublicKey : Point p => p -> PublicKey 22 | 23 | public export 24 | data SignatureParameter : Type where 25 | RSA_PKCSv15 : (DPair Type RegisteredHash) -> SignatureParameter 26 | RSA_PSS : (wit : DPair Type Hash) -> (salt_len : Nat) -> MaskGenerationFunction -> SignatureParameter 27 | ECDSA : DPair Type Hash -> SignatureParameter 28 | 29 | export 30 | Show PublicKey where 31 | show (RsaPublicKey _) = "RSA Public Key" 32 | show (EcdsaPublicKey _) = "ECDSA Public Key" 33 | 34 | export 35 | verify_signature : SignatureParameter -> PublicKey -> List Bits8 -> List Bits8 -> Either String () 36 | verify_signature (RSA_PKCSv15 hash_wit) (RsaPublicKey public_key) message signature = 37 | if rsassa_pkcs1_v15_verify @{hash_wit.snd} public_key message signature then pure () else Left "signature does not match message" 38 | verify_signature (RSA_PSS hash_wit salt_len mgf) (RsaPublicKey public_key) message signature = 39 | if rsassa_pss_verify' @{hash_wit.snd} mgf salt_len public_key message signature then pure () else Left "signature does not match message" 40 | verify_signature (ECDSA hash_wit) (EcdsaPublicKey public_key) message signature = do 41 | let (Pure [] ok) = feed (map (uncurry MkPosed) $ enumerate Z signature) parse_asn1 42 | | (Pure leftover _) => Left "parser overfed for ecdsa signature" 43 | | (Fail err) => Left $ "parser error for ecdsa signature: " <+> show err 44 | | _ => Left "parser underfed for ecdsa signature" 45 | let (Universal ** 16 ** Sequence [ (Universal ** 2 ** IntVal x), (Universal ** 2 ** IntVal y) ] ) = ok 46 | | _ => Left "malformed ecdsa signature" 47 | let digest = hash @{hash_wit.snd} hash_wit.fst message 48 | if ecdsa_verify (be_to_integer digest) (MkSignature public_key (x, y)) then pure () else Left "signature does not match message" 49 | 50 | verify_signature _ _ message signature = Left "public key does not match signature scheme" 51 | 52 | export 53 | verify_signature' : SignatureParameter -> PublicKey -> List Bits8 -> BitArray -> Either String () 54 | verify_signature' param public_key message (MkBitArray 0 signature) = verify_signature param public_key message signature 55 | verify_signature' param public_key message (MkBitArray n signature) = Left $ "invalid padding: " <+> show n 56 | 57 | export 58 | extract_algorithm : ASN1Token -> Maybe (List Nat, Maybe ASN1Token) 59 | extract_algorithm (Universal ** 16 ** Sequence [(Universal ** 6 ** OID algorithm)]) = Just (algorithm, Nothing) 60 | extract_algorithm (Universal ** 16 ** Sequence ((Universal ** 6 ** OID algorithm) :: parameter :: [])) = Just (algorithm, Just parameter) 61 | extract_algorithm _ = Nothing 62 | 63 | export 64 | oid_to_hash_algorithm : List Nat -> Maybe (DPair Type Hash) 65 | oid_to_hash_algorithm oid = 66 | case map natToInteger oid of 67 | [ 1, 3, 14, 3, 2, 26 ] => Just (MkDPair Sha1 %search) 68 | [ 2, 16, 840, 1, 101, 3, 4, 2, 1 ] => Just (MkDPair Sha256 %search) 69 | [ 2, 16, 840, 1, 101, 3, 4, 2, 2 ] => Just (MkDPair Sha384 %search) 70 | [ 2, 16, 840, 1, 101, 3, 4, 2, 3 ] => Just (MkDPair Sha512 %search) 71 | _ => Nothing 72 | 73 | export 74 | extract_signature_parameter : List Nat -> Maybe ASN1Token -> Either String SignatureParameter 75 | extract_signature_parameter oid parameter = do 76 | case (map natToInteger oid, parameter) of 77 | ([1, 2, 840, 113549, 1, 1, 5], Just (Universal ** 5 ** Null)) => Right (RSA_PKCSv15 $ MkDPair Sha1 %search) 78 | ([1, 2, 840, 113549, 1, 1, 11], Just (Universal ** 5 ** Null)) => Right (RSA_PKCSv15 $ MkDPair Sha256 %search) 79 | ([1, 2, 840, 113549, 1, 1, 12], Just (Universal ** 5 ** Null)) => Right (RSA_PKCSv15 $ MkDPair Sha384 %search) 80 | ([1, 2, 840, 113549, 1, 1, 13], Just (Universal ** 5 ** Null)) => Right (RSA_PKCSv15 $ MkDPair Sha512 %search) 81 | ([1, 2, 840, 10045, 4, 3, 2], Nothing) => Right (ECDSA $ MkDPair Sha256 %search) 82 | ([1, 2, 840, 10045, 4, 3, 3], Nothing) => Right (ECDSA $ MkDPair Sha384 %search) 83 | ([1, 2, 840, 10045, 4, 3, 4], Nothing) => Right (ECDSA $ MkDPair Sha512 %search) 84 | ([1, 2, 840, 113549, 1, 1, 10], Just (Universal ** 16 ** Sequence params)) => do 85 | (wit, params) <- extract_hash_algo params 86 | (mgf, params) <- extract_mgf params 87 | (salt, params) <- extract_salt_len params 88 | extract_trailer params 89 | pure $ RSA_PSS wit salt mgf 90 | _ => Left "unrecognized signature parameter" 91 | where 92 | extract_hash_algo' : ASN1Token -> Either String (DPair Type Hash) 93 | extract_hash_algo' (Universal ** 16 ** Sequence ((Universal ** 6 ** OID oid) :: _)) = 94 | maybe_to_either (oid_to_hash_algorithm oid) "hash algorithm not recognized" 95 | extract_hash_algo' _ = Left "malformed hash algorithm" 96 | 97 | extract_hash_algo : List ASN1Token -> Either String (DPair Type Hash, List ASN1Token) 98 | extract_hash_algo [] = Right (MkDPair Sha1 %search, []) 99 | extract_hash_algo ((ContextSpecific ** 0 ** UnknownConstructed _ _ [ hash_algo ] ) :: xs) = 100 | (, xs) <$> extract_hash_algo' hash_algo 101 | extract_hash_algo (x :: xs) = Right (MkDPair Sha1 %search, x :: xs) 102 | 103 | extract_mgf : List ASN1Token -> Either String (MaskGenerationFunction, List ASN1Token) 104 | extract_mgf [] = Right (mgf1 {algo=Sha1}, []) 105 | extract_mgf ((ContextSpecific ** 1 ** UnknownConstructed _ _ [ sequence ]) :: xs) = 106 | case sequence of 107 | ((Universal ** 16 ** Sequence ((Universal ** 6 ** OID oid) :: param :: []))) => 108 | case map natToInteger oid of 109 | [ 1, 2, 840, 113549, 1, 1, 8 ] => (\wit => (mgf1 @{wit.snd}, xs)) <$> extract_hash_algo' param 110 | _ => Left "mask generation function not recognized" 111 | _ => Left "malformed mask generation function" 112 | extract_mgf (x :: xs) = Right (mgf1 {algo=Sha1}, x :: xs) 113 | 114 | extract_salt_len : List ASN1Token -> Either String (Nat, List ASN1Token) 115 | extract_salt_len [] = Right (20, []) 116 | extract_salt_len ((ContextSpecific ** 2 ** UnknownConstructed _ _ [ (Universal ** 2 ** IntVal salt_len) ]) :: xs) = 117 | if salt_len < 0 then Left "negative salt len" else pure (integerToNat salt_len, xs) 118 | extract_salt_len (x :: xs) = Right (20, x :: xs) 119 | 120 | extract_trailer : List ASN1Token -> Either String () 121 | extract_trailer [] = Right () 122 | extract_trailer [ (ContextSpecific ** 3 ** UnknownConstructed _ _ [ (Universal ** 2 ** IntVal trailer ) ]) ] = 123 | if trailer /= 1 then Left "invalid trailer field" else pure () 124 | extract_trailer (x :: xs) = Left "unrecognized field after trailer field" 125 | 126 | extract_rsa_key : List Bits8 -> Either String RSAPublicKey 127 | extract_rsa_key pk_content = do 128 | let (Pure [] ok) = feed (map (uncurry MkPosed) $ enumerate Z pk_content) parse_asn1 129 | | (Pure leftover _) => Left "parser overfed for SubjectPublicKey" 130 | | (Fail err) => Left $ "parser error for SubjectPublicKey: " <+> show err 131 | | _ => Left "parser underfed for SubjectPublicKey" 132 | let (Universal ** 16 ** Sequence 133 | [ (Universal ** 2 ** IntVal modulus) 134 | , (Universal ** 2 ** IntVal public_exponent) 135 | ] 136 | ) = ok 137 | | _ => Left "cannot parse SubjectPublicKey" 138 | 139 | maybe_to_either (mk_rsa_publickey modulus public_exponent) "malformed RSA public key" 140 | 141 | extract_ecdsa_key : List Bits8 -> List Integer -> Either String PublicKey 142 | extract_ecdsa_key content [1, 2, 840, 10045, 3, 1, 7] = 143 | EcdsaPublicKey <$> maybe_to_either (decode {p=P256} content) "fail to parse secp256r1 public key" 144 | extract_ecdsa_key content [1, 3, 132, 0, 34] = 145 | EcdsaPublicKey <$> maybe_to_either (decode {p=P384} content) "fail to parse secp384r1 public key" 146 | extract_ecdsa_key content [1, 3, 132, 0, 35] = 147 | EcdsaPublicKey <$> maybe_to_either (decode {p=P521} content) "fail to parse secp521r1 public key" 148 | extract_ecdsa_key _ oid = Left $ "unrecognized elliptic curve group oid: " <+> show oid 149 | 150 | export 151 | extract_key' : ASN1Token -> Either String (Vect 20 Bits8, PublicKey) 152 | extract_key' ok = do 153 | let (Universal ** 16 ** Sequence 154 | [ algorithm 155 | , (Universal ** 3 ** Bitstring bitstring) 156 | ] 157 | ) = ok 158 | | _ => Left "cannot parse SubjectPublicKeyInfo" 159 | 160 | let (MkBitArray 0 content) = bitstring 161 | | _ => Left "incorrect padding for SubjectPublicKey" 162 | 163 | key_info <- maybe_to_either (extract_algorithm algorithm) "cannot parse algorithm in SubjectPublicKeyInfo" 164 | 165 | -- natToInteger is needed because pattern matching list of Nat will kill my cpu big time 166 | public_key <- case mapFst (map natToInteger) key_info of 167 | -- PKCS #1 RSA Encryption 168 | ([1, 2, 840, 113549, 1, 1, 1], Just (Universal ** 5 ** Null)) => 169 | RsaPublicKey <$> extract_rsa_key content 170 | -- RSA PSS 171 | ([1, 2, 840, 113549, 1, 1, 10], Nothing) => 172 | RsaPublicKey <$> extract_rsa_key content 173 | -- Elliptic Curve Public Key (RFC 5480) 174 | ([1, 2, 840, 10045, 2, 1], Just (Universal ** 6 ** OID group_id)) => 175 | extract_ecdsa_key content $ map natToInteger group_id 176 | _ => Left "unrecognized signature algorithm parameter" 177 | 178 | pure (hash Sha1 content, public_key) 179 | 180 | export 181 | extract_key : List Bits8 -> Either String (Vect 20 Bits8, PublicKey) 182 | extract_key der_public_key = do 183 | let (Pure [] ok) = feed (map (uncurry MkPosed) $ enumerate Z der_public_key) parse_asn1 184 | | (Pure leftover _) => Left "parser overfed for SubjectPublicKeyInfo" 185 | | (Fail err) => Left $ "parser error for SubjectPublicKeyInfo: " <+> show err 186 | | _ => Left "parser underfed for SubjectPublicKeyInfo" 187 | extract_key' ok 188 | -------------------------------------------------------------------------------- /src/Crypto/Hash/SHA2.idr: -------------------------------------------------------------------------------- 1 | module Crypto.Hash.SHA2 2 | 3 | import Crypto.Hash.Interfaces 4 | import Data.Bits 5 | import Data.DPair 6 | import Data.Fin 7 | import Data.Fin.Extra 8 | import Data.List 9 | import Data.Nat 10 | import Data.Nat.Factor 11 | import Data.Vect 12 | import Utils.Misc 13 | import Utils.Bytes 14 | import Crypto.Hash.MerkleDamgard 15 | 16 | export 17 | data Sha256 : Type where 18 | MkSha256 : MerkleDamgard 8 64 Bits32 -> Sha256 19 | 20 | export 21 | data Sha224 : Type where 22 | MkSha224 : Sha256 -> Sha224 23 | 24 | export 25 | data Sha512 : Type where 26 | MkSha512 : MerkleDamgard 8 128 Bits64 -> Sha512 27 | 28 | export 29 | data Sha384 : Type where 30 | MkSha384 : Sha512 -> Sha384 31 | 32 | sha256_init_hash_values : Vect 8 Bits32 33 | sha256_init_hash_values = 34 | [ 0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a, 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19 ] 35 | 36 | sha256_round_constants : Vect 64 Bits32 37 | sha256_round_constants = 38 | [ 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5 39 | , 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174 40 | , 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da 41 | , 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967 42 | , 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85 43 | , 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070 44 | , 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3 45 | , 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2 ] 46 | 47 | sha256_extend_message : Vect 16 Bits32 -> Stream Bits32 48 | sha256_extend_message xs = prepend (toList xs) $ go xs 49 | where 50 | go : Vect 16 Bits32 -> Stream Bits32 51 | go xs = 52 | let 53 | [wi_16, wi_15, wi_7, wi_2] = the (Vect 4 _) $ map (flip index xs) [0, 1, 9, 14] 54 | s0 = rotr 7 wi_15 `xor` rotr 18 wi_15 `xor` shiftR wi_15 3 55 | s1 = rotr 17 wi_2 ` xor` rotr 19 wi_2 `xor` shiftR wi_2 10 56 | w = wi_16 + s0 + wi_7 + s1 57 | in 58 | w :: go (tail xs `snoc` w) 59 | 60 | sha256_compress : (block : Vect 64 Bits8) -> (h : Vect 8 Bits32) -> Vect 8 Bits32 61 | sha256_compress block hash_values = zipWith (+) hash_values $ go sha256_round_constants (take _ $ sha256_extend_message $ map (from_be {a = Bits32} {n = 4}) $ group 16 4 block) hash_values 62 | where 63 | go : (ks : Vect kn Bits32) -> (ws : Vect kn Bits32) -> (h : Vect 8 Bits32) -> Vect 8 Bits32 64 | go [] _ h = h 65 | go (k :: ks) (w :: ws) [a,b,c,d,e,f,g,h] = 66 | let 67 | s1 = rotr 6 e `xor` rotr 11 e `xor` rotr 25 e 68 | ch = (e .&. f) `xor` (complement e .&. g) 69 | temp1 = h + s1 + ch + k + w 70 | s0 = rotr 2 a `xor` rotr 13 a `xor` rotr 22 a 71 | maj = (a .&. b) `xor` (a .&. c) `xor` (b .&. c) 72 | temp2 = s0 + maj 73 | in 74 | go ks ws [temp1 + temp2, a, b, c, d + temp1, e, f, g] 75 | 76 | sha256_update : List Bits8 -> Sha256 -> Sha256 77 | sha256_update input (MkSha256 s) = 78 | let 79 | Fraction _ 64 nblocks residue_nbyte prf = divMod (s.buffer_nbyte + length input) 64 80 | (blocks, residue) = splitAt (mult nblocks 64) (replace_vect (sym prf) (s.buffer ++ fromList input)) 81 | in 82 | MkSha256 $ {buffer := residue, buffer_nbyte := _, buffer_nbyte_constraint := elemSmallerThanBound residue_nbyte } 83 | ( foldl (\s_, block_ => {hash_values $= sha256_compress block_, npassed_blocks $= S} s_) s (group nblocks 64 blocks) ) 84 | 85 | sha256_finalize : Sha256 -> Vect 32 Bits8 86 | sha256_finalize (MkSha256 s) = 87 | concat $ map (to_be {n = 4}) $ 88 | case pad_theorem {block_nbyte = 64} {residue_max_nbyte = 55} {length_nbyte = 8} (LTESucc LTEZero) Refl s.buffer_nbyte_constraint s.buffer (integer_to_be _ $ 8 * (cast s.npassed_blocks * 64 + cast s.buffer_nbyte)) of 89 | Left block => sha256_compress block s.hash_values 90 | Right blocks => let (x1, x2) = splitAt 64 blocks in sha256_compress x2 $ sha256_compress x1 s.hash_values 91 | 92 | sha224_init_hash_values : Vect 8 Bits32 93 | sha224_init_hash_values = 94 | [ 0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939, 0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4 ] 95 | 96 | sha512_init_hash_values : Vect 8 Bits64 97 | sha512_init_hash_values = 98 | [ 0x6a09e667f3bcc908, 0xbb67ae8584caa73b, 0x3c6ef372fe94f82b, 0xa54ff53a5f1d36f1 99 | , 0x510e527fade682d1, 0x9b05688c2b3e6c1f, 0x1f83d9abfb41bd6b, 0x5be0cd19137e2179 ] 100 | 101 | sha512_round_constants : Vect 80 Bits64 102 | sha512_round_constants = 103 | [ 0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f, 0xe9b5dba58189dbbc, 0x3956c25bf348b538 104 | , 0x59f111f1b605d019, 0x923f82a4af194f9b, 0xab1c5ed5da6d8118, 0xd807aa98a3030242, 0x12835b0145706fbe 105 | , 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2, 0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235 106 | , 0xc19bf174cf692694, 0xe49b69c19ef14ad2, 0xefbe4786384f25e3, 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65 107 | , 0x2de92c6f592b0275, 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5, 0x983e5152ee66dfab 108 | , 0xa831c66d2db43210, 0xb00327c898fb213f, 0xbf597fc7beef0ee4, 0xc6e00bf33da88fc2, 0xd5a79147930aa725 109 | , 0x06ca6351e003826f, 0x142929670a0e6e70, 0x27b70a8546d22ffc, 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed 110 | , 0x53380d139d95b3df, 0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6, 0x92722c851482353b 111 | , 0xa2bfe8a14cf10364, 0xa81a664bbc423001, 0xc24b8b70d0f89791, 0xc76c51a30654be30, 0xd192e819d6ef5218 112 | , 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8, 0x19a4c116b8d2d0c8, 0x1e376c085141ab53 113 | , 0x2748774cdf8eeb99, 0x34b0bcb5e19b48a8, 0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb, 0x5b9cca4f7763e373 114 | , 0x682e6ff3d6b2b8a3, 0x748f82ee5defb2fc, 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec 115 | , 0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915, 0xc67178f2e372532b, 0xca273eceea26619c 116 | , 0xd186b8c721c0c207, 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178, 0x06f067aa72176fba, 0x0a637dc5a2c898a6 117 | , 0x113f9804bef90dae, 0x1b710b35131c471b, 0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc 118 | , 0x431d67c49c100d4c, 0x4cc5d4becb3e42b6, 0x597f299cfc657e2a, 0x5fcb6fab3ad6faec, 0x6c44198c4a475817 ] 119 | 120 | sha512_extend_message : Vect 16 Bits64 -> Stream Bits64 121 | sha512_extend_message xs = prepend (toList xs) $ go xs 122 | where 123 | public export 124 | go : Vect 16 Bits64 -> Stream Bits64 125 | go xs = 126 | let 127 | [wi_16, wi_15, wi_7, wi_2] = the (Vect 4 _) $ map (flip index xs) [0, 1, 9, 14] 128 | s0 = rotr 1 wi_15 `xor` rotr 8 wi_15 `xor` shiftR wi_15 7 129 | s1 = rotr 19 wi_2 `xor` rotr 61 wi_2 `xor` shiftR wi_2 6 130 | w = wi_16 + s0 + wi_7 + s1 131 | in 132 | w :: go (tail xs `snoc` w) 133 | 134 | sha512_compress : (block : Vect 128 Bits8) -> (h : Vect 8 Bits64) -> Vect 8 Bits64 135 | sha512_compress block hash_values = zipWith (+) hash_values $ go sha512_round_constants (take _ $ sha512_extend_message $ map (from_be {a = Bits64}) $ group 16 8 block) hash_values 136 | where 137 | go : (ks : Vect kn Bits64) -> (ws : Vect kn Bits64) -> (h : Vect 8 Bits64) -> Vect 8 Bits64 138 | go [] _ h = h 139 | go (k :: ks) (w :: ws) [a,b,c,d,e,f,g,h] = 140 | let 141 | s1 = rotr 14 e `xor` rotr 18 e `xor` rotr 41 e 142 | ch = (e .&. f) `xor` (complement e .&. g) 143 | temp1 = h + s1 + ch + k + w 144 | s0 = rotr 28 a `xor` rotr 34 a `xor` rotr 39 a 145 | maj = (a .&. b) `xor` (a .&. c) `xor` (b .&. c) 146 | temp2 = s0 + maj 147 | in 148 | go ks ws [temp1 + temp2, a, b, c, d + temp1, e, f, g] 149 | 150 | sha512_update : List Bits8 -> Sha512 -> Sha512 151 | sha512_update input (MkSha512 s) = 152 | let 153 | Fraction _ 128 nblocks residue_nbyte prf = divMod (s.buffer_nbyte + length input) 128 154 | (blocks, residue) = splitAt (mult nblocks 128) (replace_vect (sym prf) (s.buffer ++ fromList input)) 155 | in 156 | MkSha512 $ {buffer := residue, buffer_nbyte := _, buffer_nbyte_constraint := elemSmallerThanBound residue_nbyte } 157 | ( foldl (\s_, block_ => {hash_values $= sha512_compress block_, npassed_blocks $= S} s_) s (group nblocks 128 blocks) ) 158 | 159 | sha512_finalize : Sha512 -> Vect 64 Bits8 160 | sha512_finalize (MkSha512 s) = 161 | concat $ map (to_be {n = 8}) $ 162 | case pad_theorem {block_nbyte = 128} {residue_max_nbyte = 111} {length_nbyte = 16} (LTESucc LTEZero) Refl s.buffer_nbyte_constraint s.buffer (integer_to_be _ $ 8 * (cast s.npassed_blocks * 128 + cast s.buffer_nbyte)) of 163 | Left block => sha512_compress block s.hash_values 164 | Right blocks => let (x1, x2) = splitAt 128 blocks in sha512_compress x2 $ sha512_compress x1 s.hash_values 165 | 166 | sha384_init_hash_values : Vect 8 Bits64 167 | sha384_init_hash_values = 168 | [ 0xcbbb9d5dc1059ed8, 0x629a292a367cd507, 0x9159015a3070dd17, 0x152fecd8f70e5939 169 | , 0x67332667ffc00b31, 0x8eb44a8768581511, 0xdb0c2e0d64f98fa7, 0x47b5481dbefa4fa4 ] 170 | 171 | export 172 | Digest Sha256 where 173 | digest_nbyte = 32 174 | update = sha256_update 175 | finalize = sha256_finalize 176 | 177 | export 178 | Digest Sha224 where 179 | digest_nbyte = 28 180 | update xs (MkSha224 s) = MkSha224 $ update xs s 181 | finalize (MkSha224 s) = take _ $ finalize s 182 | 183 | export 184 | Digest Sha512 where 185 | digest_nbyte = 64 186 | update = sha512_update 187 | finalize = sha512_finalize 188 | 189 | export 190 | Digest Sha384 where 191 | digest_nbyte = 48 192 | update xs (MkSha384 s) = MkSha384 $ update xs s 193 | finalize (MkSha384 s) = take _ $ finalize s 194 | 195 | export 196 | Hash Sha256 where 197 | block_nbyte = 64 198 | initialize = MkSha256 $ mk_merkle_damgard sha256_init_hash_values 199 | 200 | export 201 | Hash Sha224 where 202 | block_nbyte = 64 203 | initialize = MkSha224 $ MkSha256 $ mk_merkle_damgard sha224_init_hash_values 204 | 205 | export 206 | Hash Sha512 where 207 | block_nbyte = 128 208 | initialize = MkSha512 $ mk_merkle_damgard sha512_init_hash_values 209 | 210 | export 211 | Hash Sha384 where 212 | block_nbyte = 128 213 | initialize = MkSha384 $ MkSha512 $ mk_merkle_damgard sha384_init_hash_values 214 | -------------------------------------------------------------------------------- /src/Utils/Misc.idr: -------------------------------------------------------------------------------- 1 | module Utils.Misc 2 | 3 | import Data.Bits 4 | import Data.DPair 5 | import Data.Fin 6 | import Data.List 7 | import Data.Nat 8 | import Data.Nat.Division 9 | import Data.Stream 10 | import Data.Vect 11 | import Data.List1 12 | import Data.Fin.Extra 13 | import Syntax.WithProof 14 | 15 | ||| primarily used for `hack_*` functions for hacking open ADTs into sums ^/v products 16 | public export 17 | Eithers : List Type -> Type 18 | Eithers [] = Void 19 | Eithers (x :: []) = x 20 | Eithers (x :: xs) = Either x (Eithers xs) 21 | 22 | public export 23 | kill_linear : Void -> (1 _ : a) -> s 24 | kill_linear x = void x 25 | 26 | public export 27 | pair_to_list : (a, a) -> List a 28 | pair_to_list (x1, x2) = [x1, x2] 29 | 30 | public export 31 | vect_to_pair : Vect 2 a -> (a, a) 32 | vect_to_pair [x1, x2] = (x1, x2) 33 | 34 | public export 35 | pair_to_vect : (a, a) -> Vect 2 a 36 | pair_to_vect (x1, x2) = [x1, x2] 37 | 38 | public export 39 | from_vect : Vect 1 a -> a 40 | from_vect [x] = x 41 | 42 | public export 43 | to_vect : a -> Vect 1 a 44 | to_vect x = [x] 45 | 46 | ||| strict version of `(&&)` 47 | public export 48 | s_and : Bool -> Bool -> Bool 49 | s_and True False = False 50 | s_and True True = True 51 | s_and False False = False 52 | s_and False True = False 53 | 54 | public export 55 | mmod : Integer -> (m : Nat) -> {auto 0 ok : NonZero m} -> Nat 56 | mmod n m = 57 | let m' = natToInteger m 58 | in integerToNat ((m' + n `mod` m') `mod` m') 59 | 60 | public export 61 | mod': Integer -> Integer -> Integer 62 | mod' _ 0 = 0 63 | mod' n m = (m + n `mod` m) `mod` m 64 | 65 | public export 66 | s_eq : (Bits b, Eq b) => Vect n b -> Vect n b -> Bool 67 | s_eq a b = (zeroBits ==) $ foldr (.|.) zeroBits $ zipWith xor a b 68 | 69 | public export 70 | s_eq' : (Bits b, Eq b) => List b -> List b -> Bool 71 | s_eq' a b = (length a == length b) `s_and` ((zeroBits ==) $ foldr (.|.) zeroBits $ zipWith xor a b) 72 | 73 | public export 74 | vect_zip_with : {n : Nat} -> {m : Nat} -> (a -> b -> c) -> Vect n a -> Vect m b -> Vect (minimum n m) c 75 | vect_zip_with {n=0} {m} f [] _ = [] 76 | vect_zip_with {n} {m=0} f _ [] = rewrite minimumZeroZeroLeft n in [] 77 | vect_zip_with f (x::xs) (y::ys) = f x y :: vect_zip_with f xs ys 78 | 79 | public export 80 | group : (n : Nat) -> (m : Nat) -> Vect (n * m) a -> Vect n (Vect m a) 81 | group Z _ _ = [] 82 | group (S n) m xs = let (l, r) = splitAt m xs in l :: group n m r 83 | 84 | public export 85 | chunk : Nat -> List a -> List (List a) 86 | chunk _ [] = [] 87 | chunk n xs = (take n xs) :: (chunk n (drop n xs)) 88 | 89 | -- https://gist.github.com/buzden/afc798fd2b01388f1626ae58c6ab8548 90 | public export 91 | group' : (n : Nat) -> (m : Nat) -> Vect (n * m) a -> Vect m (Vect n a) 92 | group' n m xs = group m n $ rewrite multCommutative m n in xs 93 | 94 | -- https://gist.github.com/buzden/afc798fd2b01388f1626ae58c6ab8548 95 | -- to prove that, say given `xs : Vect (n + m) a`, can be splitted at index `n` into `l` and `r` (the (0 _ : splitAt n xs = (l, r)) part), and then be concatenated back into xs 96 | export 97 | split_at_concat_rev : (n : Nat) -> (xs : Vect (n + m) a) -> {0 l : Vect n a} -> {0 r : Vect m a} -> (0 _ : splitAt n xs = (l, r)) -> l ++ r = xs 98 | split_at_concat_rev Z _ Refl = Refl 99 | split_at_concat_rev (S n) (x :: xs) {l} prf with (splitAt n xs) proof sprf 100 | split_at_concat_rev (S n) (x :: xs) {l = x :: l} Refl | (l, _) = cong (x ::) $ split_at_concat_rev n xs sprf 101 | 102 | -- https://gist.github.com/buzden/afc798fd2b01388f1626ae58c6ab8548 103 | public export 104 | concat_group_id : (n : Nat) -> (m : Nat) -> (v : Vect (n * m) a) -> concat (group n m v) = v 105 | concat_group_id Z _ [] = Refl 106 | concat_group_id (S n) m xs with (splitAt m xs) proof prf 107 | _ | (l, r) = rewrite concat_group_id n m r in split_at_concat_rev m xs prf 108 | 109 | pow_mod' : Integer -> Integer -> Integer -> Integer -> Integer 110 | pow_mod' n x y m = 111 | if y == 0 112 | then n 113 | else let n' = (n * x) `mod` m 114 | y' = shiftR y 1 115 | x' = (x * x) `mod` m 116 | in pow_mod' (if testBit y 0 then n' else n) x' y' m 117 | 118 | public export 119 | pow_mod : Integer -> Integer -> Integer -> Integer 120 | pow_mod x y m = pow_mod' 1 (x `mod'` m) (y `mod'` m) m 121 | 122 | mul_mod' : Integer -> Integer -> Integer -> Integer -> Integer 123 | mul_mod' n x y m = 124 | if y == 0 125 | then n 126 | else let n' = (n + x) `mod` m 127 | y' = shiftR y 1 128 | x' = (x * 2) `mod` m 129 | in mul_mod' (if testBit y 0 then n' else n) x' y' m 130 | 131 | public export 132 | mul_mod : Integer -> Integer -> Integer -> Integer 133 | mul_mod x y m = mul_mod' 0 (x `mod'` m) (y `mod'` m) m 134 | 135 | public export 136 | quot_rem : Integer -> Integer -> (Integer, Integer) 137 | quot_rem val d = 138 | let dividend = if d < 0 then -(val `div` abs d) else val `div` d 139 | remainder = abs (val - dividend * d) 140 | in (dividend, remainder) 141 | 142 | public export 143 | gcd' : Integer -> Integer -> Integer 144 | gcd' a 0 = a 145 | gcd' a b = gcd' b (a `mod` b) 146 | 147 | public export 148 | are_coprimes : Integer -> Integer -> Bool 149 | are_coprimes x y = (gcd' x y) == 1 150 | 151 | -- Extended Euclidean Algorithm 152 | -- Only valid when gcd(a, b) = 1 153 | public export 154 | extended_gcd : Integer -> Integer -> (Integer, Integer) 155 | extended_gcd a 0 = (1, 0) 156 | extended_gcd a b = 157 | let (q, r) = quot_rem a b 158 | (s, t) = extended_gcd b r 159 | in (t, s - q * t) 160 | 161 | -- Only valid when gcd(a, b) = 1 162 | public export 163 | inv_mul_mod : Integer -> Integer -> Integer 164 | inv_mul_mod a m = 165 | let (x, y) = extended_gcd a m 166 | in mod' x m 167 | 168 | public export 169 | forM : Applicative f => (n : Nat) -> (f b) -> f (Vect n b) 170 | forM n f = for (the (Vect n (Fin n)) range) (const f) 171 | 172 | utf8_bytelen : Bits8 -> Maybe (Bits8, Nat) 173 | utf8_bytelen x = 174 | if (x .&. 0b01111111) == x then Just (x, 0) -- ascii 175 | else if (shiftR x 5) == 0b110 then Just (x .&. 0b0011111, 1) 176 | else if (shiftR x 4) == 0b1110 then Just (x .&. 0b0001111, 2) 177 | else if (shiftR x 3) == 0b11110 then Just (x .&. 0b0000111, 3) 178 | else Nothing 179 | 180 | utf8_unmask : Bits8 -> Maybe Bits8 181 | utf8_unmask x = const (x .&. 0b00111111) <$> guard (shiftR x 6 == 0b10) 182 | 183 | utf8_pushbits : Integer -> List Bits8 -> Integer 184 | utf8_pushbits acc [] = acc 185 | utf8_pushbits acc (x::xs) = utf8_pushbits ((shiftL acc 6) .|. (cast x)) xs 186 | 187 | public export 188 | utf8_decode : List Bits8 -> Maybe String 189 | utf8_decode = go [] 190 | where 191 | go : List Char -> List Bits8 -> Maybe String 192 | go acc [] = Just $ pack $ reverse acc 193 | go acc (x :: xs) = do 194 | (x, l) <- utf8_bytelen x 195 | let (y,ys) = splitAt l xs 196 | guard (length y == l) 197 | y <- traverse utf8_unmask y 198 | let c = utf8_pushbits (cast x) y 199 | go ((cast c) :: acc) ys 200 | 201 | public export 202 | stream_concat : Foldable t => Stream (t a) -> Stream a 203 | stream_concat = go . map toList 204 | where 205 | go : Stream (List a) -> Stream a 206 | go ([] :: ys) = stream_concat ys 207 | go ((x :: xs) :: ys) = x :: stream_concat (xs :: ys) 208 | 209 | public export 210 | ok_minus : (n : Nat) -> (m : Nat) -> LTE m n -> Nat 211 | ok_minus n Z LTEZero = n 212 | ok_minus (S n) (S m) (LTESucc wit) = ok_minus n m wit 213 | 214 | namespace List 215 | public export 216 | enumerate : Nat -> List a -> List (Nat, a) 217 | enumerate n [] = [] 218 | enumerate n (x :: xs) = (n, x) :: enumerate (S n) xs 219 | 220 | namespace Vect 221 | public export 222 | replace_vect : (0 _ : n = m) -> Vect n a -> Vect m a 223 | replace_vect prf input = rewrite sym prf in input 224 | 225 | public export 226 | cycle : Vect (S n) a -> Stream a 227 | cycle xs = go xs 228 | where 229 | go : Vect i a -> Stream a 230 | go [] = go xs 231 | go (z :: zs) = z :: go zs 232 | 233 | namespace Stream 234 | public export 235 | prepend : List a -> Stream a -> Stream a 236 | prepend [] ys = ys 237 | prepend (x :: xs) ys = x :: prepend xs ys 238 | 239 | public export 240 | duplicate : Stream a -> Stream (Stream a) 241 | duplicate (x :: xs) = (x :: xs) :: duplicate xs 242 | 243 | public export 244 | split : (n : Nat) -> Stream a -> (Vect n a, Stream a) 245 | split Z xs = ([], xs) 246 | split (S n) (v :: xs) = let (vs, xs') = split n xs in (v :: vs, xs') 247 | 248 | public export 249 | chunk : (n : Nat) -> Stream a -> Stream (Vect n a) 250 | chunk n xs = let (y, ys) = split n xs in y :: chunk n ys 251 | 252 | public export 253 | lte_plus_left : (a : _) -> LTE (a + b) c -> LTE b c 254 | lte_plus_left Z x = x 255 | lte_plus_left (S k) x = lte_plus_left k (lteSuccLeft x) 256 | 257 | public export 258 | maybe_to_either : Maybe a -> Lazy b -> Either b a 259 | maybe_to_either Nothing b = Left $ force b 260 | maybe_to_either (Just a) _ = Right a 261 | 262 | public export 263 | init' : List a -> List a 264 | init' [] = [] 265 | init' (x :: xs) = init (x :: xs) 266 | 267 | public export 268 | uncons1 : List1 a -> (List a, a) 269 | uncons1 lst = (init lst, last lst) 270 | 271 | public export 272 | splitAt : (n : Nat) -> Stream a -> (Vect n a, Stream a) 273 | splitAt n s = (take n s, drop n s) 274 | 275 | public export 276 | zeros : {n : Nat} -> Vect n Bits8 277 | zeros = map (const 0) Fin.range 278 | 279 | public export 280 | splitLastAt1 : (n : Nat) -> List a -> Maybe (List1 a, Vect n a) 281 | splitLastAt1 n v = do 282 | let m = minus (length v) n 283 | let (a, b) = splitAt m v 284 | a' <- fromList a 285 | b' <- exactLength n $ fromList b 286 | pure (a', b') 287 | 288 | public export 289 | modFinNZ : Nat -> (b : Nat) -> NonZero b -> Fin b 290 | modFinNZ a b prf = let x = boundModNatNZ a b prf in natToFinLTE (modNatNZ a b prf) x 291 | 292 | public export 293 | collapse_ordering : List Ordering -> Ordering 294 | collapse_ordering (LT :: xs) = LT 295 | collapse_ordering (GT :: xs) = GT 296 | collapse_ordering (EQ :: xs) = collapse_ordering xs 297 | collapse_ordering [] = EQ 298 | 299 | public export 300 | pad_zero : Nat -> List Bits8 -> List Bits8 301 | pad_zero Z a = a 302 | pad_zero (S n) a = 303 | let l = length a 304 | l = minus ((S n) * (divCeilNZ l (S n) SIsNonZero)) l 305 | in a <+> replicate l 0 306 | 307 | public export 308 | splitAtExact : (n : Nat) -> List a -> Maybe (Vect n a, List a) 309 | splitAtExact n list = 310 | let (a, b) = splitAt n list 311 | in (, b) <$> exactLength n (fromList a) 312 | -------------------------------------------------------------------------------- /src/Network/TLS/HelloExtension.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.HelloExtension 2 | 3 | import Data.List1 4 | import Data.Vect 5 | import Network.TLS.Magic 6 | import Network.TLS.Parsing 7 | import Utils.Bytes 8 | import Utils.Misc 9 | import Utils.Show 10 | 11 | public export 12 | KeyBytes : Type 13 | KeyBytes = List Bits8 14 | 15 | -- TODO: even more stuff 16 | public export 17 | data ServerNameEntry : Type where 18 | DNS : String -> ServerNameEntry 19 | 20 | public export 21 | Show ServerNameEntry where 22 | show (DNS x) = show_record "DNS" [("name", show x)] 23 | 24 | XServerNameEntry : Type 25 | XServerNameEntry = Eithers [String] 26 | 27 | hack_server_name_entry : ServerNameEntry -> XServerNameEntry 28 | hack_server_name_entry (DNS x) = x 29 | 30 | fix_server_name_entry : XServerNameEntry -> ServerNameEntry 31 | fix_server_name_entry x = (DNS x) 32 | 33 | namespace ClientExtension 34 | public export 35 | data ClientExtension : ExtensionType -> Type where 36 | ServerName : List1 ServerNameEntry -> ClientExtension ServerName 37 | SupportedGroups : List1 SupportedGroup -> ClientExtension SupportedGroups 38 | SignatureAlgorithms : List1 SignatureAlgorithm -> ClientExtension SignatureAlgorithms 39 | SupportedVersions : List1 TLSVersion -> ClientExtension SupportedVersions 40 | KeyShare : List1 (SupportedGroup, KeyBytes) -> ClientExtension KeyShare 41 | -- TODO: PSK 42 | 43 | public export 44 | Show (ClientExtension type) where 45 | show (ServerName entries) = show_record "ServerName" [("entries", show entries)] 46 | show (SupportedGroups entries) = show_record "SupportedGroups" [("entries", show entries)] 47 | show (SignatureAlgorithms entries) = show_record "SignatureAlgorithms" [("entries", show entries)] 48 | show (SupportedVersions entries) = show_record "SupportedVersions" [("entries", show entries)] 49 | show (KeyShare entries) = show_record "KeyShare" [("entries", show entries)] 50 | 51 | XClientExtension : Type 52 | XClientExtension = Eithers 53 | [ ClientExtension ServerName 54 | , ClientExtension SupportedGroups 55 | , ClientExtension SignatureAlgorithms 56 | , ClientExtension SupportedVersions 57 | , ClientExtension KeyShare 58 | ] 59 | 60 | hack_client_extension : DPair _ ClientExtension -> XClientExtension 61 | hack_client_extension (ServerName ** x) = Left x 62 | hack_client_extension (SupportedGroups ** x) = Right (Left x) 63 | hack_client_extension (SignatureAlgorithms ** x) = Right (Right (Left x)) 64 | hack_client_extension (SupportedVersions ** x) = Right (Right (Right (Left x))) 65 | hack_client_extension (KeyShare ** x) = Right (Right (Right (Right x))) 66 | 67 | fix_client_extension : XClientExtension -> DPair _ ClientExtension 68 | fix_client_extension (Left x) = (_ ** x) 69 | fix_client_extension (Right (Left x)) = (_ ** x) 70 | fix_client_extension (Right (Right (Left x))) = (_ ** x) 71 | fix_client_extension (Right (Right (Right (Left x)))) = (_ ** x) 72 | fix_client_extension (Right (Right (Right (Right x)))) = (_ ** x) 73 | 74 | namespace ServerExtension 75 | public export 76 | data ServerExtension : ExtensionType -> Type where 77 | SupportedGroups : SupportedGroup -> ServerExtension SupportedGroups 78 | SignatureAlgorithms : SignatureAlgorithm -> ServerExtension SignatureAlgorithms 79 | SupportedVersions : TLSVersion -> ServerExtension SupportedVersions 80 | KeyShare : (SupportedGroup, KeyBytes) -> ServerExtension KeyShare 81 | Unknown : (id : (Bits8, Bits8)) -> List Bits8 -> ServerExtension (Unknown id) 82 | 83 | public export 84 | Show (ServerExtension type) where 85 | show (SupportedGroups entries) = show_record "SupportedGroups" [("entry", show entries)] 86 | show (SignatureAlgorithms entries) = show_record "SignatureAlgorithms" [("entry", show entries)] 87 | show (SupportedVersions entries) = show_record "SupportedVersions" [("entry", show entries)] 88 | show (KeyShare entries) = show_record "KeyShare" [("entry", show entries)] 89 | show (Unknown (a, b) body) = show_record "Unknown" [("id", xxd $ the (List Bits8) [a, b]), ("body", xxd body)] 90 | 91 | XServerExtension : Type 92 | XServerExtension = Eithers 93 | [ ServerExtension SupportedGroups 94 | , ServerExtension SignatureAlgorithms 95 | , ServerExtension SupportedVersions 96 | , ServerExtension KeyShare 97 | , (a ** ServerExtension (Unknown a)) 98 | ] 99 | 100 | hack_server_extension : DPair _ ServerExtension -> XServerExtension 101 | hack_server_extension (SupportedGroups ** x) = Left x 102 | hack_server_extension (SignatureAlgorithms ** x) = Right (Left x) 103 | hack_server_extension (SupportedVersions ** x) = Right (Right (Left x)) 104 | hack_server_extension (KeyShare ** x) = Right (Right (Right (Left x))) 105 | hack_server_extension ((Unknown id) ** x) = Right (Right (Right (Right (id ** x)))) 106 | 107 | fix_server_extension : XServerExtension -> DPair _ ServerExtension 108 | fix_server_extension (Left x) = (_ ** x) 109 | fix_server_extension (Right (Left x)) = (_ ** x) 110 | fix_server_extension (Right (Right (Left x))) = (_ ** x) 111 | fix_server_extension (Right (Right (Right (Left x)))) = (_ ** x) 112 | fix_server_extension (Right (Right (Right (Right (x ** y))))) = (_ ** y) 113 | 114 | namespace Parsing 115 | namespace Client 116 | export 117 | with_id : (Cons (Posed Bits8) i, Monoid i) => {type : ExtensionType} -> Parserializer Bits8 i (SimpleError String) (ClientExtension type) -> Parserializer Bits8 i (SimpleError String) (ClientExtension type) 118 | with_id pser = under (show type <+> " extension") $ is (pair_to_vect $ extension_type_to_id type) *> pser 119 | 120 | -- TODO: generalize 121 | export 122 | server_name_dns_entry : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) String 123 | server_name_dns_entry = is [0x00] *> map ascii_to_string string_to_ascii (lengthed_list 2 token) 124 | 125 | export 126 | server_name_entry : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) ServerNameEntry 127 | server_name_entry = map fix_server_name_entry hack_server_name_entry $ server_name_dns_entry 128 | 129 | export 130 | no_id_server_name : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (ClientExtension ServerName) 131 | no_id_server_name = lengthed 2 $ map ServerName (\(ServerName x) => x) $ lengthed_list1 2 server_name_entry 132 | 133 | export 134 | no_id_supported_groups : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (ClientExtension SupportedGroups) 135 | no_id_supported_groups = lengthed 2 $ map SupportedGroups (\(SupportedGroups x) => x) $ lengthed_list1 2 supported_group 136 | 137 | export 138 | no_id_signature_algorithms : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (ClientExtension SignatureAlgorithms) 139 | no_id_signature_algorithms = lengthed 2 $ map SignatureAlgorithms (\(SignatureAlgorithms x) => x) $ lengthed_list1 2 signature_algorithm 140 | 141 | export 142 | no_id_supported_versions : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (ClientExtension SupportedVersions) 143 | no_id_supported_versions = lengthed 2 $ map SupportedVersions (\(SupportedVersions x) => x) $ lengthed_list1 1 tls_version 144 | 145 | export 146 | no_id_key_share : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (ClientExtension KeyShare) 147 | no_id_key_share = lengthed 2 $ map KeyShare (\(KeyShare x) => x) $ lengthed_list1 2 (supported_group <*>> lengthed_list 2 token) 148 | 149 | export 150 | extension : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (DPair _ ClientExtension) 151 | extension = map fix_client_extension hack_client_extension 152 | $ (with_id no_id_server_name) 153 | <|> (with_id no_id_supported_groups) 154 | <|> (with_id no_id_signature_algorithms) 155 | <|> (with_id no_id_supported_versions) 156 | <|> (with_id no_id_key_share) 157 | 158 | namespace Server 159 | export 160 | no_id_supported_groups : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (ServerExtension SupportedGroups) 161 | no_id_supported_groups = lengthed 2 $ map SupportedGroups (\(SupportedGroups x) => x) $ supported_group 162 | 163 | export 164 | no_id_signature_algorithms : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (ServerExtension SignatureAlgorithms) 165 | no_id_signature_algorithms = lengthed 2 $ map SignatureAlgorithms (\(SignatureAlgorithms x) => x) $ signature_algorithm 166 | 167 | export 168 | no_id_supported_versions : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (ServerExtension SupportedVersions) 169 | no_id_supported_versions = lengthed 2 $ map SupportedVersions (\(SupportedVersions x) => x) $ tls_version 170 | 171 | export 172 | no_id_key_share : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (ServerExtension KeyShare) 173 | no_id_key_share = lengthed 2 $ map KeyShare (\(KeyShare x) => x) $ (supported_group <*>> lengthed_list 2 token) 174 | 175 | export 176 | with_id : (Cons (Posed Bits8) i, Monoid i) => {type : ExtensionType} -> Parserializer Bits8 i (SimpleError String) (ServerExtension type) -> Parserializer Bits8 i (SimpleError String) (ServerExtension type) 177 | with_id pser = under (show type <+> " extension") $ is (pair_to_vect $ extension_type_to_id type) *> pser 178 | 179 | export 180 | with_id_unknown : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (rid ** ServerExtension (Unknown rid)) 181 | with_id_unknown = MkParserializer serialize deserialize 182 | where 183 | serialize : (rid ** ServerExtension (Unknown rid)) -> List Bits8 184 | serialize ((a,b) ** (Unknown _ body)) = [a,b] <+> (prepend_length 2 body) 185 | deserialize : Parser i (SimpleError String) (rid ** ServerExtension (Unknown rid)) 186 | deserialize = do 187 | [a, b] <- count 2 p_get 188 | body <- (lengthed_list 2 token).decode 189 | pure ((a,b) ** Unknown (a,b) body) 190 | 191 | export 192 | extension : (Cons (Posed Bits8) i, Monoid i) => Parserializer Bits8 i (SimpleError String) (DPair _ ServerExtension) 193 | extension = map fix_server_extension hack_server_extension 194 | $ (with_id no_id_supported_groups) 195 | <|> (with_id no_id_signature_algorithms) 196 | <|> (with_id no_id_supported_versions) 197 | <|> (with_id no_id_key_share) 198 | <|> (with_id_unknown) 199 | 200 | -------------------------------------------------------------------------------- /src/Network/TLS/Handle.idr: -------------------------------------------------------------------------------- 1 | module Network.TLS.Handle 2 | 3 | import Control.Linear.LIO 4 | import Control.Monad.Error.Either 5 | import Control.Monad.State 6 | import Crypto.ECDH 7 | import Crypto.Random 8 | import Data.List 9 | import Data.List1 10 | import Data.Vect 11 | import Data.Void 12 | import Network.TLS.Core 13 | import Network.TLS.Magic 14 | import Network.TLS.Parsing 15 | import Network.TLS.Record 16 | import Utils.Bytes 17 | import Utils.Handle 18 | import Utils.Misc 19 | import Utils.Parser 20 | 21 | public export 22 | tls_version_to_state_type : TLSVersion -> Type 23 | tls_version_to_state_type TLS12 = TLSState Application2 24 | tls_version_to_state_type TLS13 = TLSState Application3 25 | tls_version_to_state_type _ = Void 26 | 27 | export 28 | record TLSHandle (version : TLSVersion) t_ok t_closed where 29 | constructor MkTLSHandle 30 | 1 handle : Handle t_ok t_closed (Res String $ const t_closed) (Res String $ const t_closed) 31 | state : tls_version_to_state_type version 32 | buffer : List Bits8 33 | 34 | public export 35 | Uninhabited (TLSHandle TLS10 t_ok t_closed) where 36 | uninhabited = state 37 | 38 | public export 39 | Uninhabited (TLSHandle TLS11 t_ok t_closed) where 40 | uninhabited = state 41 | 42 | OkOrError : TLSVersion -> Type -> Type -> Type 43 | OkOrError tls_version t_ok t_closed = Res Bool $ \ok => if ok then TLSHandle tls_version t_ok t_closed else Res String (const t_closed) 44 | 45 | read_record : LinearIO m => (1 _ : Handle' t_ok t_closed) -> L1 m $ Res Bool $ \ok => if ok then Res (List Bits8) (const $ Handle' t_ok t_closed) else Res String (const t_closed) 46 | read_record handle = do 47 | -- read header 48 | (True # (b_header # handle)) <- read handle 5 49 | | (False # (error # handle)) => pure1 (False # ("read (record header / alert) failed: " <+> error # handle)) 50 | let (Pure [] (Right (_, TLS12, len))) = 51 | feed {i = List (Posed Bits8)} (map (uncurry MkPosed) $ enumerate 0 b_header) (alert <|> record_type_with_version_with_length).decode 52 | | Pure [] (Left x) => (close handle) >>= (\s => pure1 (False # (("ALERT: " <+> show x) # s))) 53 | | _ => (close handle) >>= (\s => pure1 (False # (("unable to parse header: " <+> xxd b_header) # s))) 54 | 55 | -- read record content 56 | (True # (b_body # handle)) <- read handle (cast len) 57 | | (False # (error # handle)) => pure1 (False # ("read (record body) failed: " <+> error # handle)) 58 | if length b_body == cast len 59 | then pure1 (True # (b_header <+> b_body # handle)) 60 | else let err = "length does not match header: " <+> xxd b_body 61 | <+> "\nexpected length: " <+> show len 62 | <+> "\nactual length: " <+> (show $ length b_body) 63 | in (close handle) >>= (\s => pure1 (False # (err # s))) 64 | 65 | gen_key : MonadRandom m => (g : SupportedGroup) -> m (DPair SupportedGroup (\g => Pair (curve_group_to_scalar_type g) (curve_group_to_element_type g))) 66 | gen_key group = do 67 | keypair <- generate_key_pair @{snd $ curve_group_to_type group} 68 | pure (group ** keypair) 69 | 70 | tls2_handshake : LinearIO io => TLSState ServerHello2 -> (1 _ : Handle' t_ok t_closed) -> CertificateCheck IO -> L1 io (OkOrError TLS12 t_ok t_closed) 71 | tls2_handshake state handle cert_ok = do 72 | (True # (b_cert # handle)) <- read_record handle 73 | | (False # other) => pure1 (False # other) 74 | 75 | let Right state = serverhello2_to_servercert state b_cert 76 | | Left error => (close handle) >>= (\s => pure1 (False # (error # s))) 77 | 78 | (True # (b_skex # handle)) <- read_record handle 79 | | (False # other) => pure1 (False # other) 80 | 81 | Right state <- liftIO1 $ servercert_to_serverkex state b_skex cert_ok 82 | | Left error => (close handle) >>= (\s => pure1 (False # (error # s))) 83 | 84 | (True # (b_s_hello_done # handle)) <- read_record handle 85 | | (False # other) => pure1 (False # other) 86 | 87 | let Right (state, handshake_data) = serverkex_process_serverhellodone state b_s_hello_done 88 | | Left error => (close handle) >>= (\s => pure1 (False # (error # s))) 89 | 90 | (True # handle) <- write handle handshake_data 91 | | (False # (error # handle)) => pure1 (False # ("send_byte (handshake data) failed: " <+> error # handle)) 92 | 93 | (True # (b_ccs # handle)) <- read_record handle 94 | | (False # other) => pure1 (False # other) 95 | 96 | let Right state = serverhellodone_to_applicationready2 state b_ccs 97 | | Left error => (close handle) >>= (\s => pure1 (False # (error # s))) 98 | 99 | (True # (b_fin # handle)) <- read_record handle 100 | | (False # other) => pure1 (False # other) 101 | 102 | case applicationready2_to_application2 state b_fin of 103 | Right state => pure1 (True # MkTLSHandle handle state []) 104 | Left error => (close handle) >>= (\s => pure1 (False # (error # s))) 105 | 106 | tls3_handshake : LinearIO io => TLSState ServerHello3 -> (1 _ : Handle' t_ok t_closed) -> CertificateCheck IO -> L1 io (OkOrError TLS13 t_ok t_closed) 107 | tls3_handshake state handle cert_ok = do 108 | (True # (b_response # handle)) <- read_record handle 109 | | (False # other) => pure1 (False # other) 110 | parsed <- liftIO1 $ tls3_serverhello_to_application state b_response cert_ok 111 | case parsed of 112 | Right (Right (client_verify, state)) => do 113 | (True # handle) <- write handle client_verify 114 | | (False # (error # handle)) => pure1 (False # ("send_byte (client verify data) failed: " <+> error # handle)) 115 | pure1 (True # MkTLSHandle handle state []) 116 | Right (Left state) => 117 | tls3_handshake state handle cert_ok 118 | Left error => 119 | (close handle) >>= (\s => pure1 (False # (error # s))) 120 | 121 | DecryptFunction : Type -> Type 122 | DecryptFunction state = state -> List Bits8 -> Either String (state, List Bits8) 123 | 124 | EncryptFunction : Type -> Type 125 | EncryptFunction state = state -> List Bits8 -> (state, List Bits8) 126 | 127 | tlshandle_read : {version : _} -> LinearIO io => (wanted : Nat) -> (1 _ : TLSHandle version t_ok t_closed) -> DecryptFunction (tls_version_to_state_type version) -> L1 io (Res Bool $ ReadHack (TLSHandle version t_ok t_closed) (Res String (const t_closed))) 128 | tlshandle_read wanted (MkTLSHandle handle state buffer) decrypt = 129 | let (a, b) = splitAt wanted buffer 130 | in if (length a) == wanted 131 | then pure1 (True # (a # MkTLSHandle handle state b)) 132 | else do 133 | (True # (b_record # handle)) <- read_record handle 134 | | (False # other) => pure1 (False # other) 135 | case decrypt state b_record of 136 | Right (state, plaintext) => tlshandle_read wanted (MkTLSHandle handle state $ buffer <+> plaintext) decrypt 137 | Left error => (close handle) >>= (\s => pure1 (False # (error # s))) 138 | 139 | tlshandle_write : {tls_version : TLSVersion} -> LinearIO io => List (List Bits8) -> (1 _ : TLSHandle tls_version t_ok t_closed) -> EncryptFunction (tls_version_to_state_type tls_version) -> L1 io (Res Bool $ WriteHack (TLSHandle tls_version t_ok t_closed) (Res String (const t_closed))) 140 | tlshandle_write [] sock encrypt = pure1 (True # sock) 141 | tlshandle_write (x :: xs) (MkTLSHandle handle state buffer) encrypt = do 142 | let (state, b_record) = encrypt state x 143 | (True # handle) <- write handle b_record 144 | | (False # (error # handle)) => pure1 (False # ("write (application data) failed: " <+> error # handle)) 145 | tlshandle_write xs (MkTLSHandle handle state buffer) encrypt 146 | 147 | ||| Reference: OpenSSL 148 | chunk_size : Nat 149 | chunk_size = 0x2000 150 | 151 | tlshandle_to_handle : {version : _} -> (1 _ : TLSHandle version t_ok t_closed) -> Handle' (TLSHandle version t_ok t_closed) t_closed 152 | tlshandle_to_handle {version=TLS10} (MkTLSHandle handle state buffer) = (kill_linear state) handle 153 | tlshandle_to_handle {version=TLS11} (MkTLSHandle handle state buffer) = (kill_linear state) handle 154 | tlshandle_to_handle {version=TLS12} handle = MkHandle 155 | handle 156 | ( \sock, len => tlshandle_read len sock decrypt_from_record2 ) 157 | ( \sock, input => tlshandle_write (chunk chunk_size input) sock encrypt_to_record2 ) 158 | ( \(MkTLSHandle handle state buffer) => close handle ) 159 | tlshandle_to_handle {version=TLS13} handle = MkHandle 160 | handle 161 | ( \sock, len => tlshandle_read len sock decrypt_from_record ) 162 | ( \sock, input => tlshandle_write (chunk chunk_size input) sock encrypt_to_record ) 163 | ( \(MkTLSHandle handle state buffer) => close handle ) 164 | 165 | TLSHandle' : Type -> Type -> Type 166 | TLSHandle' t_ok t_closed = Res TLSVersion $ \version => TLSHandle version t_ok t_closed 167 | 168 | abstract_tlshandle : (1 _ : TLSHandle' t_ok t_closed) -> Handle' (TLSHandle' t_ok t_closed) t_closed 169 | abstract_tlshandle x = MkHandle 170 | x 171 | ( \(v # h), wanted => do 172 | (True # (output # MkHandle h _ _ _)) <- read (tlshandle_to_handle h) wanted 173 | | (False # (err # x)) => pure1 $ False # (err # x) 174 | pure1 $ True # (output # (_ # h)) 175 | ) 176 | ( \(v # h), input => do 177 | (True # MkHandle h _ _ _) <- write (tlshandle_to_handle h) input 178 | | (False # (err # x)) => pure1 $ False # (err # x) 179 | pure1 $ True # (_ # h) 180 | ) 181 | ( \(v # h) => close $ tlshandle_to_handle h 182 | ) 183 | 184 | export 185 | tls_handshake : (MonadRandom IO, LinearIO io) => 186 | String -> 187 | List1 SupportedGroup -> 188 | List1 SignatureAlgorithm -> 189 | List1 CipherSuite -> 190 | (1 _ : Handle' t_ok t_closed) -> 191 | CertificateCheck IO -> 192 | L1 io (Res Bool $ \ok => if ok then Handle' (TLSHandle' t_ok t_closed) t_closed else Res String (const t_closed)) 193 | tls_handshake target_hostname supported_groups signature_algos cipher_suites handle cert_ok = do 194 | random <- liftIO1 $ random_bytes _ 195 | keypairs <- liftIO1 $ traverse gen_key supported_groups 196 | let 197 | (client_hello, state) = 198 | tls_init_to_clienthello $ TLS_Init $ MkTLSInitialState 199 | target_hostname 200 | random 201 | [] 202 | cipher_suites 203 | signature_algos 204 | keypairs 205 | 206 | (True # handle) <- write handle client_hello 207 | | (False # (error # handle)) => pure1 (False # ("send client_hello failed: " <+> error # handle)) 208 | 209 | (True # (b_server_hello # handle)) <- read_record handle 210 | | (False # other) => pure1 (False # other) 211 | 212 | case tls_clienthello_to_serverhello state b_server_hello of 213 | Right (Left state) => do 214 | (True # ok) <- tls2_handshake state handle cert_ok 215 | | (False # no) => pure1 (False # no) 216 | pure1 $ True # abstract_tlshandle (_ # ok) 217 | Right (Right state) => do 218 | (True # ok) <- tls3_handshake state handle cert_ok 219 | | (False # no) => pure1 (False # no) 220 | pure1 $ True # abstract_tlshandle (_ # ok) 221 | Left error => do 222 | h <- close handle 223 | pure1 $ False # (error # h) 224 | --------------------------------------------------------------------------------