Crypto 3.0.3 → 4.1.0
raw patch · 33 files changed
+1088/−5405 lines, 33 filesdep +arraydep +prettydep +randomdep −NewBinarydep −mtldep ~HUnitdep ~QuickCheckdep ~basenew-component:exe:HMACTestnew-component:exe:SHA1Testnew-uploader
Dependencies added: array, pretty, random
Dependencies removed: NewBinary, mtl
Dependency ranges changed: HUnit, QuickCheck, base
Files
- AttributeCertificate.hs +0/−174
- BERTest.hs +0/−1214
- Codec/ASN1.hs +0/−329
- Codec/ASN1/BER.hs +0/−556
- Codec/ASN1/InformationFramework.hs +0/−155
- Codec/ASN1/PKCS1v15.hs +0/−100
- Codec/ASN1/PKCS8.hs +0/−265
- Codec/ASN1/TLV.hs +0/−185
- Codec/ASN1/X509.hs +0/−465
- Codec/ASN1/X509/AttributeCertificateDefinitions.hs +0/−483
- Codec/Binary/Base64.hs +0/−282
- Codec/Binary/BubbleBabble.hs +41/−0
- Codec/Encryption/TEA.hs +85/−0
- Codec/Text/Raw.hs +10/−1
- Crypto.cabal +60/−103
- Data/Digest/SHA1.hs +105/−26
- Data/Digest/SHA1Aux.hs +0/−106
- Data/Digest/SHA2.hs +285/−0
- Data/Digest/SHA224.hs +26/−0
- Data/Digest/SHA256.hs +26/−0
- Data/Digest/SHA384.hs +26/−0
- Data/Digest/SHA512.hs +26/−0
- Data/HMAC.hs +118/−0
- Data/LargeWord.hs +13/−1
- HMACTest.hs +183/−0
- PKCS8Example.hs +0/−117
- QuickTest.hs +1/−14
- RSAEncryptionExample.hs +0/−104
- RSATest.hs +6/−4
- RSAVerifyExample.hs +0/−112
- ReadMe.tex +42/−489
- SHA1Test.hs +35/−0
- X509Example.hs +0/−120
− AttributeCertificate.hs
@@ -1,174 +0,0 @@-module Main(main) where--import Data.Char-import Data.Maybe-import Control.Monad.Error-import Control.Monad.State-import Codec.ASN1.BER-import Codec.ASN1-import Codec.ASN1.X509-import Codec.ASN1.InformationFramework-import Codec.ASN1.X509.AttributeCertificateDefinitions-import Test.HUnit-import System.IO-import System.Environment-import System.Console.GetOpt-import Codec.Utils-import Codec.ASN1.TLV-import NewBinary.Binary-import Text.PrettyPrint-import Codec.Text.Raw--instance PP AttributeCertificate where- pp ac =- (label' "AttributeCertificateInfo". pp . attributeCertificateInfo1 $ ac)- $$- (label' "AlgorithmIdentifier" . pp . algorithmIdentifier2 $ ac)- $$- (label' "Encrypted" . pp . encrypted $ ac)--instance PP AttributeCertificateInfo where- pp aci =- (label "Version" . pp . version1 $ aci)- $$- (label' "Holder" . pp . holder1 $ aci)- $$- (label' "AttCertIssuer" . pp . issuer2 $ aci)- $$- (label' "AlgorithmIdentifier" . pp . signature1 $ aci)- $$- (label' "CertificateSerialNumber" . pp . serialNumber1 $ aci)- $$- (label' "CertificateValidity" . pp . attrCertValidityPeriod $ aci)- $$- (label' "Attributes" . pp . attributes $ aci)--label :: String -> Doc -> Doc-label s d = text s <> colon <> space <> d--hangingLabel :: String -> Int -> Doc -> Doc-hangingLabel s n d = hang (text s <> colon <> space) n d--label' s d = hangingLabel s 3 d--class PP a where- pp :: a -> Doc--instance PP GeneralName where- pp gn =- case gn of- Rfc822Name x -> text "Rfc822Name"- DNSName x -> text "DNSName"- DirectoryName x -> pp x- UnifromResourceIdentifier x -> text "UniformResourceIdentifier"- IPAddress x -> text "IPAddress"- RegisteredID x -> text "RegisteredID"--instance PP a => PP [a] where- pp xs = vcat (map pp xs)--instance PP a => PP (Maybe a) where- pp Nothing = text "Nothing"- pp (Just x) = pp x--instance PP Holder where- pp = pp . entityName --instance PP AttCertIssuer where- pp aci = - (label "IssuerName" . pp . issuerName $ aci)- $$- (label' "BaseCertificateID" . pp . baseCertificateID $ aci)--instance PP IssuerSerial where- pp is = - (label "Issuer" . pp . issuer1 $ is)- $$- (label "CertificateSerialNumber" . pp . serial $ is)--instance PP AlgorithmIdentifier where- pp ai = - (label "Algorithm" . pp . algorithm1 $ ai)- $$- (label "Parameters" . pp . parameters1 $ ai)--instance PP NULL where- pp _ = text "NULL"- -instance PP Integer where- pp = integer--instance PP BitString where- pp (BitString bs) = hexdump 16 bs--instance PP HolderGeneralNames where- pp (HolderGeneralNames x) = pp x--instance PP GeneralNames where- pp (GeneralNames xs) = pp xs--instance PP VisibleString where- pp (VisibleString x) = text x--instance PP PrintableString where- pp (PrintableString x) = text x--instance PP IA5String where- pp (IA5String x) = text x--instance PP DirectoryString where- pp (VS x) = pp x- pp (PS x) = pp x- pp (IA x) = pp x--instance PP AttributeTypeAndValue where- pp x =- (pp . type1 $ x) <> space <> (pp . value $ x) --instance PP Attribute where- pp x =- (pp . attributeType $ x) <> space <> (pp . attributeValues $ x)--instance PP AttributeValue where- pp (AVPS x) = pp x--instance PP OID where- pp x = text . show $ x--instance PP a => PP (SetOf a) where- pp (SetOf x) = pp x--instance PP RelativeDistinguishedName where- pp (RelativeDistinguishedName x) = pp x--instance PP RDNSequence where- pp (RDNSequence x) = pp x--instance PP Name where- pp (Name x) = pp x--instance PP AttCertValidityPeriod where- pp x = - (label "NotBeforeTime" . pp . notBeforeTime $ x)- $$- (label "NotAfterTime" . pp . notAfterTime $ x)--instance PP GeneralizedTime where- pp (GeneralizedTime x) = pp x--test1 fileName =- do h <- openFile fileName ReadMode- bin <- openBinIO_ h- (l,x) <- tlvIO bin- (w,y) <- typeCheck attributeCertificate x- let (_ ::= c) = w- let d = (decode c (Just y))::(Maybe AttributeCertificate)- putStrLn (render . pp . fromJust $ d)- putStrLn "Success"--main =- do progName <- getProgName- args <- getArgs- if length args /= 1- then putStrLn ("Usage: " ++ progName ++ " <fileName>")- else test1 (args!!0)
− BERTest.hs
@@ -1,1214 +0,0 @@-module Main(main) where--import Data.Char-import Data.Maybe-import Control.Monad.Error-import Control.Monad.State-import Codec.ASN1.BER-import Codec.ASN1-import Test.HUnit--{--Some of the ASN.1 definitions are taken from various standards and-these are annotated with references. The other ASN.1 definitions-have been created specifically to check decoding. These have been-checked using the on-line tool, Asnp, available at- -http://asn1.elibel.tm.fr/en/tools/asnp/index.htm--Notes: Definitions using ANY DEFINED BY have to be checked with -1990-option. Asnp was developed in Objective Caml.--}--expectSuccess testName asnType berValue expectedAbsValue =- TestCase $- do (w,x) <- typeCheck asnType berValue- let (_ ::= c) = w- d = decode c (Just x)- (Just y) = d- assertEqual testName expectedAbsValue y--expectFailure testName asnType berValue expectedError = - TestCase $- do x <- (do y <- typeCheck asnType berValue- return "Unexpected successful typechecking") - `catchError` (\e -> return $ show e)- assertEqual testName x expectedError--{--Some tagged value tests. See 8.14.3 of X.690 (ISO 8825-1).--Type1 ::= VisibleString-Type2 ::= [APPLICATION 3] IMPLICIT Type1-Type3 ::= [2] Type2-Type4 ::= [APPLICATION 7] IMPLICIT Type3-Type5 ::= [2] IMPLICIT Type2--}--type1' = modName "Type1" absVisibleString--type Type1 = VisibleString--jones1 = Primitive Universal 26 5 [0x4a,0x6f,0x6e,0x65,0x73]--decodedJones1 = VisibleString "Jones"--tagTest1 = expectSuccess "Type1" type1' jones1 decodedJones1--type2 = "Type2" ::= AbsRef Application 3 Implicit type1'--data Type2 = Type2 VisibleString- deriving (Eq,Show)--instance Encode Type2 where- decode a b =- do x <- decode a b- return $ Type2 x--jones2 = Primitive Application 3 5 [0x4a,0x6f,0x6e,0x65,0x73]--decodedJones2 = Type2 decodedJones1--tagTest2 = expectSuccess "Type2" type2 jones2 decodedJones2--type3 = "Type3" ::= AbsRef Context 2 Explicit type2--data Type3 = Type3 Type2- deriving (Eq,Show)--instance Encode Type3 where- decode a b =- do y <- b- let a' = absRefedType a- b' = (encodedDefComps y)!!0- x <- decode a' b'- return $ Type3 x--jones3 = Constructed Context 2 7 [jones2]--decodedJones3 = Type3 decodedJones2--tagTest3 = expectSuccess "Type3" type3 jones3 decodedJones3--type4 = "Type4" ::= AbsRef Application 7 Implicit type3--jones4 = Constructed Application 7 7 [jones2]--data Type4 = Type4 Type3- deriving (Eq,Show)--instance Encode Type4 where- decode a b =- do x <- decode a b- return $ Type4 x--decodedJones4 = Type4 decodedJones3--tagTest4 = expectSuccess "Type4" type4 jones4 decodedJones4--{--Some tests for OPTIONAL components.--}--{--Journey ::= - SEQUENCE {- origin IA5String,- stop1 [0] IA5String OPTIONAL,- stop2 [1] IA5String OPTIONAL,- destination IA5String- }--}--journey =- "Journey" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "origin" :>: (Nothing :@: absIA5String)),- Optional (Just "stop1" :>: (Just 0 :@: absIA5String)),- Optional (Just "stop2" :>: (Just 1 :@: absIA5String)),- Regular (Just "destination" :>: (Nothing :@: absIA5String))- ]--j1 = - Constructed Universal 16 24 [- Primitive Universal 22 3 [97,97,98],- Primitive Context 0 3 [99,100,101],- Primitive Context 1 3 [102,103,104], - Primitive Universal 22 3 [97,97,98]- ]--j2 = - Constructed Universal 16 24 [- Primitive Universal 22 3 [97,97,98],- Primitive Context 1 3 [102,103,104], - Primitive Universal 22 3 [97,97,98]- ]--data Journey =- Journey {- origin :: IA5String,- stop1 :: Maybe IA5String,- stop2 :: Maybe IA5String,- destination :: IA5String- }- deriving (Eq,Show)--instance Encode Journey where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - Journey {- origin = fromJust (decode (as!!0) (bs!!0)),- stop1 = do decode (as!!1) (bs!!1),- stop2 = do decode (as!!2) (bs!!2),- destination = fromJust (decode (as!!3) (bs!!3))- }--decodedJ1 =- Journey {- origin = IA5String "aab",- stop1 = Just $ IA5String "cde",- stop2 = Just $ IA5String "fgh",- destination = IA5String "aab"- }- -decodedJ2 =- Journey {- origin = IA5String "aab",- stop1 = Nothing,- stop2 = Just $ IA5String "fgh",- destination = IA5String "aab"- }--journeyTest1 =- expectSuccess "Journey1" journey j1 decodedJ1 --journeyTest2 =- expectSuccess "Journey2" journey j2 decodedJ2 --{--Odyssey ::= SEQUENCE {- start Journey,- trip1 [0] Journey OPTIONAL,- trip2 [1] Journey OPTIONAL,- trip3 [2] Journey OPTIONAL,- end Journey- }--}--odyssey =- "Odyssey" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "start" :>: (Nothing :@: journey)),- Optional (Just "trip1" :>: (Just 0 :@: journey)),- Optional (Just "trip2" :>: (Just 1 :@: journey)),- Optional (Just "trip3" :>: (Just 2 :@: journey)),- Regular (Just "end" :>: (Nothing :@: journey))- ]--prej1 = [- Primitive Universal 22 3 [97,97,98],- Primitive Context 0 3 [99,100,101],- Primitive Context 1 3 [102,103,104], - Primitive Universal 22 3 [97,97,98]- ]--o1 = - Constructed Universal 16 130 [- j1,- Constructed Context 0 26 prej1,- Constructed Context 1 26 prej1, - Constructed Context 2 26 prej1, - j1- ]--o2 = - Constructed Universal 16 52 [- j1,- j1- ]--data Odyssey =- Odyssey {- start :: Journey,- trip1 :: Maybe Journey,- trip2 :: Maybe Journey,- trip3 :: Maybe Journey,- end :: Journey- }- deriving (Eq,Show)--instance Encode Odyssey where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - Odyssey {- start = fromJust (decode (as!!0) (bs!!0)),- trip1 = do decode (as!!1) (bs!!1),- trip2 = do decode (as!!2) (bs!!2), - trip3 = do decode (as!!3) (bs!!3),- end = fromJust (decode (as!!4) (bs!!4))- }--decodedO1 =- Odyssey {- start = decodedJ1,- trip1 = Just decodedJ1,- trip2 = Just decodedJ1,- trip3 = Just decodedJ1,- end = decodedJ1- } --decodedO2 =- Odyssey {- start = decodedJ1,- trip1 = Nothing,- trip2 = Nothing,- trip3 = Nothing,- end = decodedJ1- } --odysseyTest1 =- expectSuccess "Odyssey1" odyssey o1 decodedO1 --odysseyTest2 =- expectSuccess "Odyssey2" odyssey o2 decodedO2 --{--FunnyOptional ::= - SEQUENCE {- perhaps [0] IA5String OPTIONAL- }--}--funnyOptional =- "FunnyOptional" ::=- AbsSeq Universal 16 Implicit [- Optional (Just "perhaps" :>: (Just 0 :@: absIA5String))- ]--fo1 = - Constructed Universal 16 7 [- Primitive Context 0 3 [97,97,98]- ]--fo2 = Constructed Universal 16 0 []--data FunnyOptional =- FunnyOptional {- perhaps :: Maybe IA5String- }- deriving (Eq,Show)--instance Encode FunnyOptional where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - FunnyOptional {- perhaps = do decode (as!!0) (bs!!0)- }--decodedFO1 =- FunnyOptional {- perhaps = Just $ IA5String "aab"- }--funnyOptionalTest1 =- expectSuccess "FunnyOptional1" funnyOptional fo1 decodedFO1 --decodedFO2 =- FunnyOptional {- perhaps = Nothing- }--funnyOptionalTest2 =- expectSuccess "FunnyOptional2" funnyOptional fo2 decodedFO2 ---{--Some ANY DEFINED BY tests. See the former versions of the ASN.1-standards, X.208 and X.209, sometimes referred to as ASN.1:1988 or-ASN.1:1990. This was used in some definitions of X.509 certificates,-for example:--AlgorithmIdentifier ::= SEQUENCE {- algorithm OBJECT IDENTIFIER,- parameters ANY DEFINED BY algorithm OPTIONAL }- -- contains a value of the type- -- registered for use with the- -- algorithm object identifier value--}--{--TextBook = SEQUENCE- {- author PrintableString,- citationType OID,- reference ANY DEFINED BY CitationType- }--}--textBook =- "TextBook" ::= - AbsSeq Universal 16 Implicit - [Regular (Just "author" :>: (Nothing :@: absPrintableString)),- Regular (Just "citationType" :>: (Nothing :@: absOID)),- AnyDefBy 1]--data TextBook =- TextBook {- author :: PrintableString,- citationType :: OID,- reference :: PrintableString- }- deriving (Eq,Show)--instance Encode TextBook where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - TextBook {- author = fromJust $ decode (as!!0) (bs!!0),- citationType = fromJust $ decode (as!!1) (bs!!1),- reference = fromJust $ decode (as!!2) (bs!!2)- }--encodedPrintableString1 = - Primitive Universal 19 5 [104,101,108,108,111]--encodedPrintableString2 = - Primitive Universal 19 5 [105,101,108,108,111]--encodedPrintableString3 = - Primitive Universal 19 5 [106,101,108,108,111]--encodedPrintableString4 = - Primitive Universal 19 5 [107,101,108,108,111]--encodedOID1 = Primitive Universal 6 3 [85,4,7]--encodedTextBook1 = - Constructed Universal 16 13 [- encodedPrintableString1,- encodedOID1- ]--decodedTextBook1 = - "user error (Checking AnyDefBy 1: insufficient components)"--encodedTextBook2 = - Constructed Universal 16 13 [- encodedPrintableString1,- encodedOID1,- encodedPrintableString2- ]--decodedTextBook2 =- TextBook {- author = PrintableString "hello",- citationType = OID [2,5,4,7],- reference = PrintableString "iello"- }--encodedTextBook3 = - Constructed Universal 16 13 [- encodedPrintableString3,- encodedOID1,- encodedPrintableString4- ]--decodedTextBook3 =- TextBook {- author = PrintableString "jello",- citationType = OID [2,5,4,7],- reference = PrintableString "kello"- }--textBookTest1 =- expectFailure "TextBook1" textBook encodedTextBook1 decodedTextBook1--textBookTest2 = - expectSuccess "TextBook2" textBook encodedTextBook2 decodedTextBook2--textBookTest3 = - expectSuccess "TextBook3" textBook encodedTextBook3 decodedTextBook3--library =- "Library" ::=- AbsSeq Universal 16 Implicit- [Regular (Just "first" :>: (Nothing :@: textBook)),- Regular (Just "second" :>: (Nothing :@: textBook))]--data Library =- Library {- first :: TextBook,- second :: TextBook- }- deriving (Eq,Show)--instance Encode Library where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - Library {- first = fromJust $ decode (as!!0) (bs!!0),- second = fromJust $ decode (as!!1) (bs!!1)- }--encodedLibrary =- Constructed Universal 16 28 [encodedTextBook2,encodedTextBook3]--decodedLibrary =- Library {- first = decodedTextBook2,- second = decodedTextBook3- }--libraryTest = - expectSuccess "Library1" library encodedLibrary decodedLibrary--v1 = Primitive Universal 26 5 [104,101,108,108,111] -- Valid-v2 = Primitive Universal 26 5 [103,101,108,108,111] -- Valid-v3 = Primitive Universal 26 5 [31,101,108,108,111] -- Not valid VisibleString--expectedv1 = VisibleString "hello"-expectedv2 = VisibleString "gello"-expectedv3 = - "user error (Checking \"VisibleString\": type not compatible " ++- "with values [31,101,108,108,111])"--visibleStringTest1 = - expectSuccess "VisibleString1" absVisibleString v1 expectedv1--visibleStringTest2 = - expectSuccess "VisibleString2" absVisibleString v2 expectedv2--visibleStringTest3 = - expectFailure "VisibleString3" absVisibleString v3 expectedv3--{--A modified version of the example in Annex A of X.690 (ISO 8825-1).--}--{--Name ::= [APPLICATION 1] IMPLICIT SEQUENCE- {givenName VisibleString,- initial VisibleString,- familyName VisibleString}--}--name = - "Name" ::= - AbsSeq Application 1 Implicit [- Regular (Just "givenName" :>: (Nothing :@: absVisibleString)),- Regular (Just "initial" :>: (Nothing :@: absVisibleString)),- Regular (Just "familyName" :>: (Nothing :@: absVisibleString))- ]--data Name = Name {givenName :: VisibleString,- initial :: VisibleString,- familyName :: VisibleString}- deriving (Eq,Show)--instance Encode Name where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- Name {- givenName = fromJust $ decode (as!!0) (bs!!0),- initial = fromJust $ decode (as!!1) (bs!!1),- familyName = fromJust $ decode (as!!2) (bs!!2)- }--n1 = Constructed Application 1 14 [v1,v2] -- Invalid number- -- of components--n2 = Constructed Application 1 14 [v1] -- Invalid number- -- of components--n3 = Constructed Application 1 14 [] -- Invalid number- -- of components --n4 = Constructed Application 1 14 [v1,v2,v1] -- Valid--n5 = Constructed Application 1 14 [v1,v2,v3] -- Invalid component--expectedn1 = - "user error (Checking Regular (Just \"familyName\" :>: " ++- "(Nothing :@: (\"VisibleString\" ::= " ++- "AbsBasePrim Universal 26 AbsVisibleString))): " ++- "insufficient components)"--nameTest1 =- expectFailure "Name1" name n1 expectedn1 --expectedn2 = - "user error (Checking Regular (Just \"initial\" :>: " ++- "(Nothing :@: (\"VisibleString\" ::= " ++- "AbsBasePrim Universal 26 AbsVisibleString))): " ++- "insufficient components)"--nameTest2 = - expectFailure "Name2" name n2 expectedn2 --expectedn3 = - "user error (Checking Regular (Just \"givenName\" :>: " ++- "(Nothing :@: (\"VisibleString\" ::= " ++- "AbsBasePrim Universal 26 AbsVisibleString))): " ++- "insufficient components)"--nameTest3 = - expectFailure "Name3" name n3 expectedn3 --expectedn4 =- Name {- givenName = VisibleString "hello",- initial = VisibleString "gello",- familyName = VisibleString "hello"- }- -nameTest4 =- expectSuccess "Name4" name n4 expectedn4 --expectedn5 =- "user error (Checking \"VisibleString\": " ++- "type not compatible with values [31,101,108,108,111])"--nameTest5 = - expectFailure "Name5" name n5 expectedn5 --{--EmployeeNumber ::= [APPLICATION 2] IMPLICIT INTEGER--}--employeeNumber =- "EmployeeNumber" ::= AbsRef Application 2 Implicit absInteger--data EmployeeNumber = EmployeeNumber Integer- deriving (Eq,Show)--instance Encode EmployeeNumber where- decode a b = - do x <- decode a b- return $ EmployeeNumber x--en1 = Primitive Application 2 1 [0x33]--decodedEN1 = EmployeeNumber 51--enTest1 =- expectSuccess "EmployeeNumber1" employeeNumber en1 decodedEN1 --{--Date ::= [APPLICATION 3] IMPLICIT VisibleString -- YYYYMMDD--}--date = "Date" ::= - AbsRef Application 3 Implicit absVisibleString--data Date = Date VisibleString- deriving (Eq,Show)--instance Encode Date where- decode a b = - do x <- decode a b- return $ Date x--b = "30/03/2003 19:37:34 GMT"-a = "30/03/2004 19:37:34 GMT"--nb = map (fromIntegral . ord) b-na = map (fromIntegral . ord) a--d1 = Constructed Application 3 7 [Primitive Universal 23 23 na] -- Invalid-d2 = Primitive Application 3 6 nb -- Valid--expectedD1 = - "user error (Checking \"Date\": " ++ - "expected PRIMITIVE Tag found CONSTRUCTED Tag\n" ++- "\"Date\" ::= AbsBasePrim Application 3 AbsVisibleString\n" ++- show d1 ++ ")"--decodedD2 = Date $ VisibleString b--dateTest1 = - expectFailure "Date1" date d1 expectedD1 --dateTest2 =- expectSuccess "Date2" date d2 decodedD2--{--ChildInformation ::= SEQUENCE- { name Name,- dateOfBirth [0] Date}--}--childInformation = - "ChildInformation" ::= - AbsSeq Universal 16 Implicit [- Regular (Just "name" :>: (Nothing :@: name)),- Regular (Just "dateOfBirth" :>: (Just 0 :@: date))- ]--data ChildInformation = - ChildInformation { name1 :: Name,- dateOfBirth :: Date }- deriving (Eq,Show)--instance Encode ChildInformation where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - ChildInformation {- name1 = fromJust $ decode (as!!0) (bs!!0),- dateOfBirth = fromJust $ decode (as!!1) (bs!!1)- }--ci1 = Constructed Universal 16 28- [n4,Primitive Context 0 6 nb] --expectedCI1 =- ChildInformation {- name1 = expectedn4,- dateOfBirth = decodedD2- }--ciTest1 =- expectSuccess "ChildInformation1" childInformation ci1 expectedCI1--{--PersonnelRecord ::= [APPLICATION 0] IMPLICIT SEQUENCE {- name Name,- title [0] VisibleString,- number EmployeeNumber,- dateOfHire [1] Date,- nameOfSpouse [2] Name,- children [3] IMPLICIT- SEQUENCE OF ChildInformation DEFAULT {} }--}--personnelRecord =- "PersonnelRecord" ::=- AbsSeq Application 0 Implicit [- Regular (Just "name" :>: (Nothing :@: name)),- Regular (Just "title" :>: (Just 0 :@: absVisibleString)),- Regular (Just "number" :>: (Nothing :@: employeeNumber)),- Regular (Just "dateOfHire" :>: (Just 1 :@: date)),- Regular (Just "nameOfSpouse" :>: (Just 2 :@: name)),- Regular (- Just "children" :>: (- Just 3 :@: (- "SEQUENCE OF ChildInformation" ::= - AbsSeqOf Universal 16 Implicit childInformation- )- )- )- ]--data PersonnelRecord = - PersonnelRecord {name2 :: Name,- title :: VisibleString,- number :: EmployeeNumber,- dateOfHire :: Date,- nameOfSpouse :: Name,- children :: [ChildInformation]}- deriving (Eq,Show)--instance Encode PersonnelRecord where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - PersonnelRecord {- name2 = fromJust $ decode (as!!0) (bs!!0),- title = fromJust $ decode (as!!1) (bs!!1),- number = fromJust $ decode (as!!2) (bs!!2),- dateOfHire = fromJust $ decode (as!!3) (bs!!3),- nameOfSpouse = fromJust $ decode (as!!4) (bs!!4),- children = fromJust $ decode (as!!5) (bs!!5)}--pr1 = - Constructed Application 0 23 [- n4,- Primitive Context 0 5 [104,101,108,108,111],- en1,- Primitive Context 1 6 nb,- Constructed Context 2 14 [v1,v2,v1],- Constructed Context 3 30 [ci1]--- Constructed Context 3 18 [Constructed Universal 16 16 [ci1]]- ]--decodedpr1 =- PersonnelRecord {- name2 = expectedn4,- title = expectedv1,- number = decodedEN1,- dateOfHire = decodedD2,- nameOfSpouse = expectedn4,- children = [expectedCI1]- }--prTest1 =- expectSuccess "PersonnelRecord1" personnelRecord pr1 decodedpr1 --taggedRecord =- "PersonnelRecord" ::=- AbsSeq Application 0 Implicit [- Regular (Just "name" :>: (Nothing :@: name)),- Regular (Just "nameOfSpouse" :>: (Just 2 :@: name))- ]--tr1 = - Constructed Application 0 23 [- n4,- Constructed Context 2 14 [v1,v2,v1]- ]--taggedRecord1 =- "PersonnelRecord" ::=- AbsSeq Application 0 Implicit [- Regular (Just "name" :>: (Nothing :@: name)),- Regular (Just "title" :>: (Just 0 :@: absVisibleString)),- Regular (Just "number" :>: (Nothing :@: employeeNumber)),- Regular (Just "dateOfHire" :>: (Just 1 :@: date)),- Regular (Just "nameOfSpouse" :>: (Just 2 :@: name)),- Regular (Just "another" :>: (Just 3 :@: name))- ]--tr2 = - Constructed Application 0 23 [- n4,- Primitive Context 0 5 [104,101,108,108,111],- en1,- Primitive Context 1 6 nb,- Constructed Context 2 14 [v1,v2,v1],- Constructed Context 3 14 [v1,v2,v1]- ]--taggedRecord2 =- "PersonnelRecord" ::=- AbsSeq Application 0 Implicit [- Regular (Just "name" :>: (Nothing :@: name)),- Regular (- Just "children" :>: (- Just 3 :@: (- "SEQUENCE OF ChildInformation" ::= - AbsSeqOf Universal 16 Implicit childInformation- )- )- )- ]--tr3 = - Constructed Application 0 23 [- n4,- Constructed Context 3 18 [Constructed Universal 16 16 [ci1]]- ]--taggedRecord3 =- "TaggedRecord3" ::=- AbsSeq Application 0 Implicit [- Regular (- Just "children" :>: (- Just 3 :@: (- "SEQUENCE OF ChildInformation" ::= - AbsSeqOf Universal 16 Implicit childInformation- )- )- )- ]--tr4 = - Constructed Application 0 23 [- Constructed Context 3 18 [Constructed Universal 16 16 [ci1]]- ]--sequenceOfChildInformation =- "SEQUENCE OF ChildInformation" ::= - AbsSeqOf Universal 16 Implicit childInformation--soci1 = Constructed Universal 16 30 [ci1]--tr5 = - Constructed Application 0 32 [- Constructed Context 3 30 [ci1]- ]--taggedRecord4 =- "TaggedRecord3" ::=- AbsSeq Application 0 Implicit [- Regular (Just "children" :>: (Just 3 :@: sequenceOfChildInformation))- ]--{-- Choice1 ::= CHOICE {- z1 [0] EmployeeNumber,- z2 [1] EmployeeNumber,- z3 [2] EmployeeNumber- }- A ::= CHOICE {- b B,- c C- }- B ::= CHOICE {- d [0] NULL,- e [1] NULL- }- C ::= CHOICE {- f [2] NULL,- g [3] NULL- }--}--choice1 =- "Choice1" ::=- AbsChoice [- (Implicit, Just "z1" :>: (Just 0 :@: employeeNumber)),- (Implicit, Just "z2" :>: (Just 1 :@: employeeNumber)),- (Implicit, Just "z3" :>: (Just 2 :@: employeeNumber))- ]--c1 = Primitive Context 0 1 [0x33]-c2 = Primitive Context 1 1 [0x33]-c3 = Primitive Context 2 1 [0x33]-c4 = Primitive Context 3 1 [0x33]--decodedC1 = Z1 (EmployeeNumber' 51)-decodedC2 = Z2 (EmployeeNumber' 51)-decodedC3 = Z3 (EmployeeNumber' 51)--data Choice1 = - Z1 EmployeeNumber' | - Z2 EmployeeNumber' |- Z3 EmployeeNumber'- deriving (Eq,Show)--instance Encode Choice1 where- decode a b =- do x <- b- let t = defaultedTagValue x- case t of- 0 -> do foo <- decode a b- return $ Z1 foo- 1 -> do foo <- decode a b- return $ Z2 foo- 2 -> do foo <- decode a b- return $ Z3 foo--{--EmployeeNumber ::= [APPLICATION 2] IMPLICIT INTEGER--}--employeeNumber' =- "EmployeeNumber" ::= AbsRef Application 2 Implicit absInteger--data EmployeeNumber' = EmployeeNumber' Integer- deriving (Eq,Show)--instance Encode EmployeeNumber' where- decode a b = - do x <- decode a b- return $ EmployeeNumber' x--tChoice11 =- expectSuccess "Choice1" choice1 c1 decodedC1--choice2 =- "A" ::=- AbsChoice [- (Implicit, Just "b" :>: (Nothing :@: choice3)),- (Implicit, Just "c" :>: (Nothing :@: choice4))- ]--data Choice2 = - B Choice3 | - C Choice4 - deriving (Eq,Show)--instance Encode Choice2 where- decode a b =- do x <- b- let t = defaultedTagValue x- f t - | t `elem` [0,1] = - do foo <- decode a b- return $ B foo- | t `elem` [2,3] =- do foo <- decode a b- return $ C foo- f t--decodedCBD = B decodedCD-decodedCBE = B decodedCE--tChoice21 =- expectSuccess "Choice2BD" choice2 c1 decodedCBD--tChoice22 =- expectSuccess "Choice2BE" choice2 c2 decodedCBE--choice3 =- "B" ::=- AbsChoice [- (Implicit, Just "d" :>: (Just 0 :@: employeeNumber)),- (Implicit, Just "e" :>: (Just 1 :@: employeeNumber))- ]--decodedCD = D (EmployeeNumber' 51)-decodedCE = E (EmployeeNumber' 51)--data Choice3 = - D EmployeeNumber' | - E EmployeeNumber' - deriving (Eq,Show)--instance Encode Choice3 where- decode a b =- do x <- b- let t = defaultedTagValue x- case t of- 0 -> do foo <- decode a b- return $ D foo- 1 -> do foo <- decode a b- return $ E foo--tChoice31 =- expectSuccess "Choice3D" choice3 c1 decodedCD--tChoice32 =- expectSuccess "Choice3E" choice3 c2 decodedCE--choice4 =- "C" ::=- AbsChoice [- (Implicit, Just "f" :>: (Just 2 :@: employeeNumber)),- (Implicit, Just "g" :>: (Just 3 :@: employeeNumber))- ]--decodedCF = F (EmployeeNumber' 51)-decodedCG = G (EmployeeNumber' 51)--data Choice4 = - F EmployeeNumber' | - G EmployeeNumber' - deriving (Eq,Show)--instance Encode Choice4 where- decode a b =- do x <- b- let t = defaultedTagValue x- case t of- 2 -> do foo <- decode a b- return $ F foo- 3 -> do foo <- decode a b- return $ G foo--tChoice43 =- expectSuccess "Choice4F" choice4 c3 decodedCF--tChoice44 =- expectSuccess "Choice4G" choice2 c4 decodedCG--{--NoTags ::= CHOICE {- myInt INTEGER,- myIA5 IA5String- }--}--noTags =- "NoTags" ::=- AbsChoice [- (Implicit, Just "myInt" :>: (Nothing :@: absInteger)),- (Implicit, Just "myIA5" :>: (Nothing :@: absIA5String))- ]--nt1 = Primitive Universal 2 1 [0x33]-nt2 = Primitive Universal 22 1 [0x33]-nt3 = Primitive Universal 3 1 [0x33]-nt4 = Primitive Universal 23 1 [0x33]--decodedNT1 = MyInt 51-decodedNT2 = MyIA5 (IA5String "3")--data NoTags = - MyInt Integer | - MyIA5 IA5String - deriving (Eq,Show)--instance Encode NoTags where- decode a b =- do x <- b- let t = defaultedTagValue x- f t - | t `elem` [2] = - do foo <- decode a b- return $ MyInt foo- | t `elem` [22] =- do foo <- decode a b- return $ MyIA5 foo- f t--tNoTags1 =- expectSuccess "NoTags1" noTags nt1 decodedNT1--tNoTags2 =- expectSuccess "NoTags2" noTags nt2 decodedNT2--{-- ExplicitChoice ::= CHOICE {- x1 [0] EXPLICIT EmployeeNumber,- x2 [1] EXPLICIT EmployeeNumber,- x3 [2] EXPLICIT EmployeeNumber- }--}--explicitChoice =- "ExplicitChoice" ::=- AbsChoice [- (Explicit, Just "z1" :>: (Just 0 :@: employeeNumber)),- (Explicit, Just "z2" :>: (Just 1 :@: employeeNumber)),- (Explicit, Just "z3" :>: (Just 2 :@: employeeNumber))- ]--ec1 = Constructed Context 0 3 [en1]-ec2 = Constructed Context 1 3 [en1]-ec3 = Constructed Context 2 3 [en1]-ec4 = Constructed Context 3 3 [en1]--foo e =- do (w,x) <- typeCheck explicitChoice e- putStrLn (show x)- putStrLn (show w)- let (_ ::= c) = w- d = decode c (Just x)- (Just y) = d::(Maybe ExplicitChoice)- putStrLn (show y)-- -data ExplicitChoice =- X1 EmployeeNumber |- X2 EmployeeNumber |- X3 EmployeeNumber- deriving (Eq,Show)--instance Encode ExplicitChoice where- decode a b =- do x <- b- let t = defaultedTagValue x- a' = absRefedType a- b' = (encodedDefComps x)!!0- foo <- decode a' b'- case t of - 0 -> return (X1 foo)- 1 -> return (X2 foo)- 2 -> return (X3 foo)--{--We can't put this in a test yet as w does not return something-that can be decoded mechanically. It needs more investigation but-is probably because EXPLICIT doesn't get handled correctly either-for CHOICE or SEQUENCE.--}--version = modName "Version" absInteger--type Version = Integer--certificateVersion =- "version" ::= AbsRef Context 0 Explicit version--data CertificateVersion =- CertificateVersion Version- deriving (Eq,Show)--instance Encode CertificateVersion where- decode a b =- do y <- b- let a' = absRefedType a- b' = (encodedDefComps y)!!0- x <- decode a' b'- return $ CertificateVersion x---ver1 =- Constructed Universal 16 17 [- Constructed Context 0 3 [- Primitive Universal 2 1 [2]- ],- Primitive Universal 2 10 [25,139,17,209,63,154,143,254,105,160]- ]--ver2 =- Constructed Context 0 3 [- Primitive Universal 2 1 [2]- ]--decodedVer2 = CertificateVersion 2--bar =- do (w,x) <- typeCheck certificateVersion ver2- putStrLn (show x)- putStrLn (show w)- let (_ ::= c) = w- d = decode c (Just x)- (Just y) = d::(Maybe CertificateVersion)- putStrLn (show y)--tVer1 = expectSuccess "Version1" certificateVersion ver2 decodedVer2--tests = - TestList [- tagTest1, tagTest2, tagTest3, tagTest4, - textBookTest1, textBookTest2, textBookTest3, libraryTest, - visibleStringTest1, visibleStringTest2, visibleStringTest3,- nameTest1, nameTest2, nameTest3, nameTest4, nameTest5,- enTest1, dateTest1, dateTest2, ciTest1,- prTest1, journeyTest1, journeyTest2, odysseyTest1,- odysseyTest2, funnyOptionalTest1, funnyOptionalTest2,- tChoice11, tChoice31, tChoice32, tChoice43, tChoice44,- tChoice21, tChoice22, tNoTags1, tNoTags2, tVer1- ]--main = runTestTT tests--{--051217083900--Three (at least) things to think about.--1. Real errors in choice. At the moment, all errors get treated-as a trigger to try the next alternative.--2. Typechecking a reference returns the abstract BER representation-of the referenced element. Should this be the whole element?--3. SEQUENCE elements can be IMPLICIT or EXPLICIT. Currently all are- treated as IMPLICIT because of--k (Regular (mn :>: (tv :@: td)):as) (bv:bvs) =- do foo <- lift $ case tv of- Nothing ->- tc td bv- Just v ->- case mn of- Nothing ->- tc ("" ::= AbsRef Context v Implicit td) bv- Just name ->- tc (name ::= AbsRef Context v Implicit td) bv--}
− Codec/ASN1.hs
@@ -1,329 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Codec.ASN1--- Copyright : (c) Dominic Steinitz 2005--- License : BSD-style (see the file ReadMe.tex)--- --- Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : portable------ Typecheck and decode an abstract BER representations (as, for--- example, produced by Codec.ASN1.TLV).-----------------------------------------------------------------------------------module Codec.ASN1 (- -- * Types- TagType(..),- TagValue,- TagPlicity(..),- AbsPrimType(..),- AbstractType(..),- TypeDefn(..),- TaggedType(..),- NamedType(..),- ComponentType(..),- -- * Haskell Equivalences of Base ASN.1 Types- VisibleString(..),- PrintableString(..),- IA5String(..),- DirectoryString(..),- OID(..),- NULL,- OctetString(..),- BitString(..),- SetOf(..),- -- * Modifiers and Accessor Functions- modName,- getAbsType,- modTagType,- modTagVal,- absRefedType,- absSeqComponents,- absSeqOfType,- absSetOfType,- namedTypeAbstract,- unVisibleString,- unDirectoryString,- unSetOf,- -- * Base ASN.1 Type Definitions- absVisibleString,- absPrintableString,- absIA5String,- absInteger,- absOID,- absNull,- absOctetString,- absBitString,- -- * Auxilliary ASN.1 Type Definitions- commonName,- organizationUnitName,- emailAddress,- domainComponent,- -- * Association Table of Types and OIDs- oids- ) where--import Data.Char-import qualified Data.Map as Map-import Codec.Utils--data TagType = Universal | Application | Context | Private- deriving (Eq,Show, Enum)--type TagValue = Integer--data TagPlicity = Implicit | Explicit- deriving (Eq,Show)--data AbsPrimType = AbsVisibleString- | AbsPrintableString- | AbsIA5String- | AbsBool- | AbsInteger- | AbsOID - | AbsNull- | AbsOctetString- | AbsBitString- deriving (Eq,Show)--data AbstractType = AbsBasePrim TagType TagValue AbsPrimType- | AbsRef TagType TagValue TagPlicity TypeDefn- | AbsSeq TagType TagValue TagPlicity [ComponentType]- | AbsSeqOf TagType TagValue TagPlicity TypeDefn- | AbsSetOf TagType TagValue TagPlicity TypeDefn- | AbsChoice [(TagPlicity,NamedType)]- | AbsAnyDefBy ComponentIndex- deriving (Eq,Show)--data TaggedType = Maybe TagValue :@: TypeDefn- deriving (Eq,Show)--data NamedType = Maybe String :>: TaggedType- deriving (Eq,Show)--{--For now. We should probably replace [Octet] by an existential type-and know how to encode it rather than forcing the user to encode it-by hand for a specific encoding.--}--{--Also for now, we will hand code the Component Index.--}--type ComponentIndex = Int--data ComponentType = Regular NamedType- | Optional NamedType- | Default NamedType [Octet]- | AnyDefBy ComponentIndex- deriving (Eq,Show)--data TypeDefn = String ::= AbstractType- deriving (Eq,Show)--class Tagged a where- modTagVal :: Maybe TagValue -> a -> a- modTagType :: TagType -> a -> a --instance Tagged AbstractType where- modTagVal x a@(AbsBasePrim tt tv at) = - case x of - Nothing -> a- Just y -> AbsBasePrim tt y at- modTagVal x a@(AbsRef tt tv tp at) =- case x of- Nothing -> a- Just y -> AbsRef tt y tp at- modTagVal x a@(AbsSeq tt tv tp as) = - case x of- Nothing -> a- Just y -> AbsSeq tt y tp as- modTagVal x a@(AbsSeqOf tt y tp td) =- case x of- Nothing -> a- Just y -> AbsSeqOf tt y tp td- modTagVal x a@(AbsChoice tpnts) =- case x of- Nothing -> a- Just y -> let tps = map fst tpnts- nts = map snd tpnts- mts = map (modTagVal x) nts- in AbsChoice $ zip tps mts- modTagType x a@(AbsBasePrim tt tv at) = - AbsBasePrim x tv at- modTagType x a@(AbsRef tt tv tp at) =- AbsRef x tv tp at- modTagType x a@(AbsSeq tt tv tp as) = - AbsSeq x tv tp as- modTagType x a@(AbsSeqOf tt tv tp td) =- AbsSeqOf x tv tp td- modTagType x a@(AbsChoice tpnts) =- let tps = map fst tpnts- nts = map snd tpnts- mts = map (modTagType x) nts- in AbsChoice $ zip tps mts--instance Tagged TypeDefn where- modTagVal x (n ::= t) = n ::= (modTagVal x t)- modTagType x (n ::= t) = n ::= (modTagType x t)--instance Tagged NamedType where- modTagVal x (n :>: t) = n :>: (modTagVal x t)- modTagType x (n :>: t) = n :>: (modTagType x t)--instance Tagged TaggedType where- modTagVal x (_ :@: t) = x :@: t- modTagType x (v :@: t) = v :@: (modTagType x t)---- | Create a new type definition from an existing one.--modName :: String -> TypeDefn -> TypeDefn-modName x (_ ::= at) = (x ::= at)--getAbsType :: TypeDefn -> AbstractType-getAbsType (_ ::= t) = t---- | Get the components of a SEQUENCE.--absSeqComponents :: AbstractType -> [AbstractType]-absSeqComponents (AbsSeq _ _ _ as) = ats- where ats = map f as- f (Regular (_ :>: (_ :@: (_ ::= x)))) = x- f (Optional (_ :>: (_ :@: (_ ::= x)))) = x- f (Default (_ :>: (_ :@: (_ ::= x))) _) = x- f (AnyDefBy n) = AbsAnyDefBy n---- | Get the component of the SEQUENCE OF.--absSeqOfType :: AbstractType -> AbstractType-absSeqOfType (AbsSeqOf _ _ _ (_ ::= x)) = x---- | Get the component of the SET OF.--absSetOfType :: AbstractType -> AbstractType-absSetOfType (AbsSetOf _ _ _ (_ ::= x)) = x---- | Get the component of a referenced type.--absRefedType :: AbstractType -> AbstractType-absRefedType (AbsRef _ _ _ (_ ::= x)) = x--namedTypeAbstract :: NamedType -> AbstractType-namedTypeAbstract (_ :>: (_ :@: (_ ::= x))) = x--data VisibleString = VisibleString String- deriving (Eq,Show)--unVisibleString :: VisibleString -> String-unVisibleString (VisibleString x) = x--data PrintableString = PrintableString String- deriving (Eq,Show)--data IA5String = IA5String String- deriving (Eq,Show)--data DirectoryString = VS VisibleString - | PS PrintableString- | IA IA5String- deriving (Eq,Show)--unDirectoryString :: DirectoryString -> String-unDirectoryString (PS (PrintableString x)) = x-unDirectoryString (VS (VisibleString x)) = x-unDirectoryString (IA (IA5String x)) = x--newtype OID = OID [Integer]- deriving (Eq, Show, Ord)--data NULL = NULL- deriving (Eq, Show)--data OctetString = OctetString [Octet]- deriving (Eq,Show)--data BitString = BitString [Octet]- deriving (Eq,Show)--data SetOf a = SetOf [a]- deriving (Eq,Show)--unSetOf :: SetOf a -> [a]-unSetOf (SetOf x) = x--absVisibleString :: TypeDefn-absVisibleString = - "VisibleString" ::= AbsBasePrim Universal 26 AbsVisibleString--absPrintableString :: TypeDefn-absPrintableString =- "PrintableString" ::= AbsBasePrim Universal 19 AbsPrintableString--absIA5String :: TypeDefn-absIA5String =- "IA5String" ::= AbsBasePrim Universal 22 AbsIA5String--absInteger :: TypeDefn-absInteger =- "Integer" ::= AbsBasePrim Universal 2 AbsInteger--absOID :: TypeDefn-absOID =- "OID" ::= AbsBasePrim Universal 6 AbsOID--absNull :: TypeDefn-absNull =- "NULL" ::= AbsBasePrim Universal 5 AbsNull--absOctetString :: TypeDefn-absOctetString =- "OCTET STRING" ::= AbsBasePrim Universal 4 AbsOctetString--absBitString :: TypeDefn-absBitString =- "BIT STRING" ::= AbsBasePrim Universal 3 AbsBitString--commonName :: TypeDefn-commonName = modName "CommonName" absPrintableString--countryName :: TypeDefn-countryName = modName "CountryName" absPrintableString--localityName :: TypeDefn-localityName = modName "LocalityName" absPrintableString--organization :: TypeDefn-organization = modName "Organization" absPrintableString--organizationUnitName :: TypeDefn-organizationUnitName = modName "OrganizationUnitName" absPrintableString--emailAddress :: TypeDefn-emailAddress = modName "EmailAddress" absIA5String--domainComponent :: TypeDefn-domainComponent = modName "DomainComponent" absIA5String--userId :: TypeDefn-userId = modName "UserId" absPrintableString--exemptionRole :: TypeDefn-exemptionRole = modName "exemptionRole" absPrintableString--oids :: Map.Map OID TypeDefn--oids = - Map.fromList [- (OID [2,5,4,3],commonName),- (OID [2,5,4,6],countryName),- (OID [2,5,4,7],localityName),- (OID [2,5,4,10],organization),- (OID [2,5,4,11],organizationUnitName),- (OID [1,2,840,113549,1,9,1],emailAddress),- (OID [0,9,2342,19200300,100,1,25],domainComponent),- (OID [0,9,2342,19200300,100,1,1],userId),- (OID [1,2,826,0,1,3344810,1,1,23],exemptionRole)- ]
− Codec/ASN1/BER.hs
@@ -1,556 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Codec.ASN1.BER--- Copyright : (c) Dominic Steinitz 2005--- License : BSD-style (see the file ReadMe.tex)--- --- Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : portable------ Typecheck and decode BER representations as produced by--- Codec.ASN1.TLV -----------------------------------------------------------------------------------module Codec.ASN1.BER (- -- * Types- Encoding(..),- Defaulted(..),- Length,- -- * Type classes- Encode(..),- -- * Function types- encodedComponents,- encodedDefComps,- defaultedTagValue,- typeCheck,- replaceRef- ) where--import Data.Char-import Data.Bits-import Data.List-import qualified Data.Map as Map-import Control.Monad.Error-import Control.Monad.State-import Codec.Utils-import Codec.ASN1--type Length = Integer-type PrimitiveValue = [Octet]--data Encoding = Primitive TagType TagValue Length PrimitiveValue- | Constructed TagType TagValue Length [Encoding]- deriving (Eq,Show)--data Defaulted = DefPrim TagType TagValue Length PrimitiveValue- | DefCons TagType TagValue Length [Maybe Defaulted]- deriving (Eq,Show)--encodedComponents :: Encoding -> [Encoding]-encodedComponents (Constructed _ _ _ es) = es--encodedDefComps :: Defaulted -> [Maybe Defaulted]-encodedDefComps (DefCons _ _ _ es) = es--defaultedTagValue :: Defaulted -> TagValue-defaultedTagValue (DefPrim _ t _ _) = t-defaultedTagValue (DefCons _ t _ _) = t---- | Type check the abstract representation of a Tag Length Value--- against an ASN.1 type definition.--typeCheck :: TypeDefn -> Encoding -> IO (TypeDefn,Defaulted)--typeCheck a b =- do ((q,r),_) <- runStateT (tc a b) []- return (q,r)--tc :: (MonadState [Maybe Encoding] m, MonadError e m) =>- TypeDefn -> Encoding -> m (TypeDefn,Defaulted)--tc a@(n ::= AbsBasePrim att atv at) b@(Primitive btt btv l bv) - | att /= btt = tagMismatch n att btt- | atv /= btv = tagValMismatch n atv btv- | not $ bv `compatibleWith` at = - fail ("Checking " ++ (show n) ++ ": " ++- "type not compatible with values " ++ (show bv))- | otherwise = return $ (a,DefPrim btt btv l bv)--tc a@(n ::= AbsBasePrim att atv at) b@(Constructed btt btv _ bv) - = fail ("Checking " ++ (show n) ++ ": " ++- "expected PRIMITIVE Tag found CONSTRUCTED Tag" ++- "\n" ++ (show a) ++ "\n" ++ (show b))---- See x.690 8.14.2 & 8.14.3--tc (n ::= AbsRef att atv atp at) b@(Primitive btt btv _ bv)- | atp == Explicit = - fail ("Checking " ++ (show n) ++ ": " ++- "expected IMPLICIT Tag found PRIMITIVE type")- | att /= btt = tagMismatch n att btt- | atv /= btv = tagValMismatch n atv btv- | otherwise = tc a b- where a = modName n $ modTagType att $ modTagVal (Just atv) at--tc a'@(n ::= AbsRef att atv atp at) b@(Constructed btt btv bl bvs)- | att /= btt = tagMismatch n att btt- | atv /= btv = tagValMismatch n atv btv- | otherwise = - case atp of- Implicit -> - tc a b- Explicit -> - if null bvs- then fail "unable to match empty value"- else do (w,x) <- tc at (bvs!!0)- let u = DefCons btt btv bl [Just x]- v = n ::= AbsRef att atv atp w- return $ (v,u)- where a = modName n $ modTagType att $ modTagVal (Just atv) at--tc (n ::= AbsSeq _ _ _ _) (Primitive _ _ _ _) =- constructionMismatch n "SEQUENCE" "PRIMITIVE"--tc a@(n ::= AbsSeq att atv atp as) b@(Constructed btt btv l bvs)- | att /= btt = tagMismatch n att btt- | atv /= btv = tagValMismatch n atv btv- | otherwise = - do ((tas,tbvs),s) <- runStateT (k as bvs) []- return ((n ::= AbsSeq att atv atp tas),(DefCons btt btv l tbvs))--tc (n ::= AbsSeqOf _ _ _ _) (Primitive _ _ _ _) =- constructionMismatch n "SEQUENCE OF" "PRIMITIVE"--tc a@(n ::= AbsSeqOf att atv Implicit td) b@(Constructed btt btv l bvs)- | att /= btt = tagMismatch n att btt- | atv /= btv = tagValMismatch n atv btv- | otherwise = do ds <- sequence $ zipWith tc (repeat td) bvs- let tbvs = map snd ds- ttd = if null ds then td else head $ map fst ds- return (n ::= AbsSeqOf att atv Implicit ttd,DefCons btt btv l (map Just tbvs))--tc (n ::= AbsSetOf _ _ _ _) (Primitive _ _ _ _) =- constructionMismatch n "SET OF" "PRIMITIVE"--tc (n ::= AbsSetOf att atv Implicit td) (Constructed btt btv l bvs)- | att /= btt = tagMismatch n att btt- | atv /= btv = tagValMismatch n atv btv- | otherwise = do ds <- sequence $ zipWith tc (repeat td) bvs- let tbvs = map snd ds- ttd = if null ds then td else head $ map fst ds- return (n ::= AbsSetOf att atv Implicit ttd,DefCons btt btv l (map Just tbvs))--tc (n ::= AbsAnyDefBy i) b =- do s <- get- let t = reverse s- if ((t!!i) == Nothing)- then fail ("Checking " ++ (show n) ++ ": " ++- "no optional value present in ANY DEFINED BY")- else do let (Just x) = t!!i- (_,y) <- tc absOID x- let u = (decode (getAbsType absOID) (Just y))::(Maybe OID)- (Just u') = u- v = Map.lookup u' oids- if v == Nothing - then fail ("Checking " ++ (show n) ++ ": " ++- (show u) ++ " not supported")- else do let (Just w) = v- foo <- tc w b- return foo--tc (n ::= AbsChoice tpnts) b =- foldr ignoreErr - (fail (choiceFailMsg n b))- (map ((flip choiceAux) b) tpnts)--ignoreErr :: MonadError e m => m a -> m a -> m a-ignoreErr m n = m `catchError` (\_ -> n)--choiceFailMsg n b =- "Checking " ++ - (show n) ++ - ": " ++- "no CHOICE alternative matches " ++- (show b)--choiceAux :: (MonadState [Maybe Encoding] m, MonadError e m) =>- (TagPlicity,NamedType) -> Encoding -> m (TypeDefn,Defaulted)--- TypeDefn -> Encoding -> m (TypeDefn,Defaulted)--choiceAux (tp,nt) b =- do let (mn :>: (mt :@: td)) = nt- case mn of- Nothing ->- fail ("expected identifier " ++- "(beginning with a lower-case letter): " ++- "this identifier is mandatory since ASN.1:1994")- Just n -> - case tp of- Implicit ->- case mt of- Nothing ->- tc (modName n td) b- Just t ->- tc (modName n $ modTagType Context $ modTagVal mt td) b- Explicit ->- case mt of- Nothing -> - fail "tag expected before EXPLICIT"- Just t ->- tc (n ::= AbsRef Context t Explicit td) b--k :: (MonadState [Maybe Encoding] m, MonadError e m) =>- [ComponentType] -> [Encoding] -> - StateT [Maybe Encoding] m ([ComponentType],[Maybe Defaulted])--k [] [] = return ([],[])--k [] _ = return ([],[])--k ((a@(Regular _)):_) [] = - fail ("Checking " ++ (show a) ++ ": " ++ "insufficient components")--k (a@(AnyDefBy n):as) [] =- fail ("Checking " ++ (show a) ++ ": " ++ "insufficient components")--k a@(Optional _:_) [] = return (a,[Nothing])--k (Default _ _:_) [] = fail "To be fixed"--k (Regular (mn :>: (tv :@: td)):as) (bv:bvs) = - do s <- get- let inner = - do put s- case tv of- Nothing ->- tc td bv- Just v ->- case mn of--- 29/01/05 082427 Consider replacing Maybe String by String.--- If there is no name then it's the empty String "".- Nothing ->- tc ("" ::= AbsRef Context v Implicit td) bv- Just name ->- tc (name ::= AbsRef Context v Implicit td) bv- (ttd,tbv) <- lift $ inner- let tct = Regular (mn :>: (tv :@: ttd))- put (Just bv:s)- (tcts,tbvs) <- k as bvs- return (tct:tcts,(Just tbv):tbvs)--k (a@(Optional (mn :>: (tv :@: td))):as) b@(bv:bvs) = --- For the moment. We don't want to catch all errors. For example,--- if we get an eof error then it should be propogated.- do s <- get- let inner =- do put s- case tv of- Nothing ->- tc td bv- Just v ->- case mn of--- 29/01/05 082427 Consider replacing Maybe String by String.--- If there is no name then it's the empty String "".- Nothing ->- tc ("" ::= AbsRef Context v Implicit td) bv- Just name ->- tc (name ::= AbsRef Context v Implicit td) bv- maybeOption <- - (do foo <- lift $ inner - return (Just foo)) `catchError`- (\_ -> return Nothing)- case maybeOption of- Nothing ->- do put (Nothing:s)- (tcts,tbvs) <- k as b- return (a:tcts,Nothing:tbvs)- Just (ttd,tbv) ->- do s <- get- put (Just bv:s)- (tcts,tbvs) <- k as bvs- let tct = Optional (mn :>: (tv :@: ttd))- return (tct:tcts,(Just tbv):tbvs)--k (a@(Default (mn :>: (tv :@: td)) _):as) b@(bv:bvs) = --- For the moment. We don't want to catch all errors. For example,--- if we get an eof error then it should be propogated.- do s <- get- let inner =- do put s- case tv of- Nothing ->- tc td bv- Just v ->- case mn of--- 29/01/05 082427 Consider replacing Maybe String by String.--- If there is no name then it's the empty String "".- Nothing ->- tc ("" ::= AbsRef Context v Implicit td) bv- Just name ->- tc (name ::= AbsRef Context v Implicit td) bv- maybeOption <- - (do foo <- lift $ inner - return (Just foo)) `catchError`- (\_ -> return Nothing)- case maybeOption of- Nothing ->- do put (Nothing:s) -- This is wrong. We should insert the default.- (tcts,tbvs) <- k as b- return (a:tcts,Nothing:tbvs)- Just (ttd,tbv) ->- do s <- get- put (Just bv:s)- (tcts,tbvs) <- k as bvs- let tct = Optional (mn :>: (tv :@: ttd))- return (tct:tcts,(Just tbv):tbvs)--k ((AnyDefBy n):as) (bv:bvs) =- do s <- get- if ((s!!n) == Nothing)- then fail ("Checking " ++ (show n) ++ ": " ++- "no optional value present in ANY DEFINED BY")- else do let (Just x) = (reverse s)!!n- (_,y) <- lift $ tc absOID x- let u = decode (getAbsType absOID) (Just y)- (Just u') = u- v = Map.lookup u' oids- if v == Nothing - then fail ("Checking " ++ (show n) ++ ": " ++- (show u) ++ " not supported")- else do let (Just w) = v- (ttd,tbv) <- lift $ tc w bv- s <- get- put (Just bv:s)- (tcts,tbvs) <- k as bvs- -- We didn't capture all the relevant- -- information in the AnyDefBy constructor- -- so this is all we can do for the moment.- let tct = Regular (Nothing :>: (Nothing :@: ttd))- return (tct:tcts,(Just tbv):tbvs)--compatibleWith :: PrimitiveValue -> AbsPrimType -> Bool-compatibleWith pv AbsVisibleString = - all (flip elem visibleOctets) pv-compatibleWith pv AbsPrintableString =- all (flip elem printableOctets) pv-compatibleWith pv AbsIA5String =- all (flip elem ia5Octets) pv -compatibleWith pv AbsBool = - length pv == 1 -compatibleWith pv AbsInteger =- if length pv > 1- then not ((pv!!0 == 0xff && (testBit (pv!!1) msb)) ||- (pv!!0 == 0x00 && (not (testBit (pv!!1) msb))))- else length pv == 1-compatibleWith pv AbsOID = not $ null pv-compatibleWith pv AbsOctetString = True-compatibleWith pv AbsBitString = True-compatibleWith pv AbsNull = null pv--ia5Octets :: [Octet]-ia5Octets = [0..127]--visibleOctets :: [Octet]-visibleOctets = map fromIntegral [ord ' '..ord '~']--printableOctets :: [Octet]-printableOctets = - map (fromIntegral . ord) printableString--printableString =- ['A'..'Z'] ++- ['0'..'9'] ++- [' '] ++- ['a'..'z'] ++- ['\''] ++- ['('] ++- [')'] ++- ['+'] ++- [','] ++- ['-'] ++- ['.'] ++- ['/'] ++- [':'] ++- ['='] ++- ['?'] --tagMismatch n a b =- fail ("Checking " ++ (show n) ++ ": " ++- "expected tag type " ++ (show a) ++ " " ++- "found tag type " ++ (show b))--tagValMismatch n a b =- fail ("Checking " ++ (show n) ++ ": " ++- "expected tag value " ++ (show a) ++ " " ++- "found tag value " ++ (show b))--constructionMismatch n sa sb = - fail ("Checking " ++ (show n) ++ ": " ++- "unable to match " ++ sa ++ " with " ++ sb)--decodeMismatch a b =- fail ("Panic: unable to decode " ++ (show b) ++ " with " ++ (show a)) --class Encode a where- decode :: AbstractType -> Maybe Defaulted -> Maybe a--instance Encode VisibleString where- decode a{-@(AbsBasePrim _ _ AbsVisibleString)-} b = - case a of- AbsBasePrim _ _ AbsVisibleString ->- do x <- b- case x of- DefPrim _ _ _ bv ->- return $ VisibleString $ map (chr . fromIntegral) bv- _ ->- decodeMismatch a b- _ ->- error (show a) --instance Encode PrintableString where- decode a@(AbsBasePrim _ _ AbsPrintableString) b = - do x <- b- case x of- DefPrim _ _ _ bv ->- return $ PrintableString $ map (chr . fromIntegral) bv- _ ->- decodeMismatch a b--instance Encode IA5String where- decode a@(AbsBasePrim _ _ AbsIA5String) b = - do x <- b- case x of- DefPrim _ _ _ bv ->- return $ IA5String $ map (chr . fromIntegral) bv- _ ->- decodeMismatch a b--instance Encode DirectoryString where- decode a@(AbsBasePrim _ _ AbsIA5String) b = - do x <- decode a b- return (IA x)- decode a@(AbsBasePrim _ _ AbsPrintableString) b = - do x <- decode a b - return (PS x)- decode a@(AbsBasePrim _ _ AbsVisibleString) b = - do x <- decode a b - return (VS x)--instance Encode Bool where- decode a@(AbsBasePrim _ _ AbsBool) b =- do x <- b- case x of- DefPrim _ _ _ bv ->- case bv of- [0x00] -> return False- otherwise -> return True- _ ->- decodeMismatch a b--instance Encode Integer where- decode a@(AbsBasePrim _ _ AbsInteger) b =- do x <- b- case x of- DefPrim _ _ _ bv ->- return (fromTwosComp bv)- _ ->- decodeMismatch a b --instance Encode OctetString where- decode a@(AbsBasePrim _ _ AbsOctetString) b =- do x <- b- case x of- DefPrim _ _ _ bv ->- return $ OctetString bv - _ ->- decodeMismatch a b--instance Encode BitString where- decode a@(AbsBasePrim _ _ AbsBitString) b =- do x <- b- case x of- DefPrim _ _ _ bv ->- return $ BitString (tail bv) --- For now. Typechecking will have to ensure this is valid. - _ ->- decodeMismatch a b--instance Encode a => Encode (SetOf a) where- decode a b = - do d <- b- let bs = encodedDefComps d- cs <- f a' bs- return $ SetOf cs- where a' = absSetOfType a- f x ys = - case ys of- [] ->- return $ []- (z:zs) ->- do u <- decode x z- us <- f x zs- return $ (u:us) --instance Encode a => Encode [a] where- decode a b = - do d <- b- let bs = encodedDefComps d- cs <- f a' bs- return cs- where a' = absSeqOfType a- f x ys = - case ys of- [] ->- return $ []- (z:zs) ->- do u <- decode x z- us <- f x zs- return $ (u:us) --instance Encode OID where- decode a@(AbsBasePrim _ _ AbsOID) b =- do x <- b- case x of- DefPrim _ _ _ bv ->- return $ decodeOIDAux bv- _ ->- decodeMismatch a b--decodeOIDAux (x:xs) = - OID $ ((fromIntegral x) `div` 40):((fromIntegral x) `mod` 40):ys- where- ys = map fromIntegral $- map (fromOctets (2^oidBitsPerOctet)) $- (map . map) (flip clearBit oidBitsPerOctet) (subIds xs)- subIds :: [Octet] -> [[Octet]]- subIds = unfoldr getSubId- getSubId :: [Octet] -> Maybe ([Octet], [Octet])- getSubId [] = Nothing- getSubId xs = Just $ span' endOfSubId xs- endOfSubId = not . (flip testBit oidBitsPerOctet)--oidBitsPerOctet = 7 :: Int--span' :: (a -> Bool) -> [a] -> ([a],[a])-span' p []- = ([],[])-span' p xs@(x:xs') - | p x = ([x],xs') - | otherwise = (x:ys,zs)- where (ys,zs) = span' p xs'--replaceRef :: AbstractType -> - [AbstractType] -> - [Maybe Defaulted] -> - AbstractType-replaceRef a as bs = - case a of- AbsAnyDefBy n -> u- where- oidat = decode (as!!n) (bs!!n)- (Just oidat') = oidat- t = Map.lookup oidat' oids- (Just (_ ::= u)) = t- _ -> a
− Codec/ASN1/InformationFramework.hs
@@ -1,155 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Coded.ASN1.InformationFramework--- Copyright : (c) Dominic Steinitz 2006--- License : BSD-style (see the file ReadMe.tex)--- --- Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : non-portable------ Definitions to allow the typechecking of (BER) encodings of definitions from--- InformationFramework {joint-iso-itu-t(2) ds(5) module(1) informationFramework(1) 3}--- and --- functions to extract information from encodings of them.--- --- See <http://www.itu.int/ITU-T/asn1/database/itu-t/x/x501/2005/InformationFramework.html>-----------------------------------------------------------------------------------module Codec.ASN1.InformationFramework (--- * Type declarations- GeneralName(..),- GeneralNames(..),- Name(..),- RDNSequence(..),--- * Function declarations- generalName,- generalNames,- name,- rdnSequence,- unRDNSequence- ) where--import Codec.ASN1-import Codec.ASN1.BER-import Codec.ASN1.X509 (- relativeDistinguishedName,- RelativeDistinguishedName- )--{--GeneralNames ::= SEQUENCE SIZE (1..MAX) OF GeneralName--GeneralName ::= CHOICE {- otherName [0] INSTANCE OF OTHER-NAME,- rfc822Name [1] IA5String,- dNSName [2] IA5String,- x400Address [3] ORAddress,- directoryName [4] Name,- ediPartyName [5] EDIPartyName,- uniformResourceIdentifier [6] IA5String,- iPAddress [7] OCTET STRING,- registeredID [8] OBJECT IDENTIFIER- }---- naming data types -Name ::= CHOICE { - -- only one possibility for now - rdnSequence RDNSequence- }--RDNSequence ::= SEQUENCE OF RelativeDistinguishedName--}--generalName :: TypeDefn-generalName =- "GeneralName" ::= - AbsChoice [--- (Explicit, Just "otherName" :>: [0] INSTANCE OF OTHER-NAME),- (Explicit, Just "rfc822Name" :>: (Just 1 :@: absIA5String)),- (Explicit, Just "dNSName" :>: (Just 2 :@: absIA5String)),--- (Explicit, Just "x400Address" :>: [3] ORAddress),- (Explicit, Just "directoryName" :>: (Just 4 :@: name)),--- (Explicit, Just "ediPartyName" :>: [5] :@: EDIPartyName),- (Explicit, Just "uniformResourceIdentifier" :>: - (Just 6 :@: absIA5String)),- (Explicit, Just "iPAddress" :>: (Just 7 :@: absOctetString)),- (Explicit, Just "registeredID" :>: (Just 8 :@: absOID))- ]--data GeneralName =- Rfc822Name IA5String |- DNSName IA5String |- DirectoryName Name |- UnifromResourceIdentifier IA5String |- IPAddress OctetString |- RegisteredID OID- deriving (Eq,Show)--instance Encode GeneralName where- decode a b =- do x <- b- let t = defaultedTagValue x- bs = encodedDefComps x- a' = absRefedType a- b' = (encodedDefComps x)!! 0- case t of- 1 -> do foo <- decode a' b'- return $ Rfc822Name foo- 2 -> do foo <- decode a' b'- return $ DNSName foo- 4 -> do foo <- decode a' b'- return $ DirectoryName foo- 6 -> do foo <- decode a' b'- return $ UnifromResourceIdentifier foo- 7 -> do foo <- decode a' b'- return $ IPAddress foo- 8 -> do foo <- decode a' b'- return $ RegisteredID foo--generalNames :: TypeDefn-generalNames = - "GeneralNames" ::= - AbsSeqOf Universal 16 Implicit generalName--data GeneralNames = GeneralNames [GeneralName]- deriving (Eq,Show)--instance Encode GeneralNames where- decode a b =- do x <- decode a b- return (GeneralNames x)--name :: TypeDefn-name =- "Name" ::=- AbsChoice [(Implicit,Just "rdnSequence" :>: (Nothing :@: rdnSequence))]--data Name= Name RDNSequence- deriving (Eq,Show)--instance Encode Name where- decode a b =- do x <- b- let t = defaultedTagValue x- case t of- 16 -> do foo <- decode a b- return $ Name foo--rdnSequence :: TypeDefn-rdnSequence =- "RDNSequence" ::=- AbsSeqOf Universal 16 Implicit relativeDistinguishedName--data RDNSequence = RDNSequence [RelativeDistinguishedName]- deriving (Eq,Show)--unRDNSequence :: RDNSequence -> [RelativeDistinguishedName]-unRDNSequence (RDNSequence x) = x--instance Encode RDNSequence where- decode a b =- do x <- decode a b- return (RDNSequence x)-
− Codec/ASN1/PKCS1v15.hs
@@ -1,100 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Codec.Encryption.RSA.PKCS1v15--- Copyright : (c) Dominic Steinitz 2005--- License : BSD-style (see the file ReadMe.tex)------ Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : portable------ Functions and types to allow the encoding and decoding of the --- RSA PKCS1v1.5--- signature scheme. See --- (<ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-1/pkcs-1v2-1.pdf> and--- <ftp://ftp.rsasecurity.com/pub/pkcs/ascii/pkcs-1.asc>) for --- further information.--------------------------------------------------------------------------------module Codec.ASN1.PKCS1v15(- -- * Type Declarations- DigestInfo(..),- DigestAlgorithm,- -- * Function Declarations- encode, - decode,- digestInfo,- digestAlgorithm- ) where--import Data.Maybe-import Codec.Utils (Octet)-import Codec.ASN1-import qualified Codec.ASN1.BER as BER-import Codec.ASN1.X509 (algorithmIdentifier,AlgorithmIdentifier)---- | Not yet implemented.--encode :: [Octet] -> [Octet]--encode xs = error "tbd"---- | Take an encoded message and return the decoded message provided all the--- conditions in the specification are met.--decode :: [Octet] -> Maybe [Octet]-decode encoded =- if decodeError - then Nothing- else (Just m)- where - (x0,t0) = splitAt 1 encoded- (x1,t1) = splitAt 1 t0- (ps,t2) = span (==0xff) t1- (x3,m) = splitAt 1 t2- decodeError = - and [- x0 /= [0x00], - x1 /= [0x02], - x3 /= [0x00],- length ps < 8- ]--{--DigestInfo ::= SEQUENCE {- digestAlgorithm DigestAlgorithm,- digest OCTET STRING-}--}--digestInfo =- "DigestInfo" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "digestAlgorithm" :>: (Nothing :@:- digestAlgorithm)),- Regular (Just "digest" :>: (Nothing :@:- absOctetString))- ]--data DigestInfo =- DigestInfo {- digestAlgorithm1 :: DigestAlgorithm,- digest :: OctetString- }- deriving (Eq,Show)--instance BER.Encode DigestInfo where- decode a b =- do x <- b- let as = absSeqComponents a- bs = BER.encodedDefComps x- return $- DigestInfo {- digestAlgorithm1 = fromJust $ BER.decode (as!!0) (bs!!0),- digest = fromJust $ BER.decode (as!!1) (bs!!1)- }--digestAlgorithm =- modName "DigestAlgorithm" algorithmIdentifier--type DigestAlgorithm = AlgorithmIdentifier
− Codec/ASN1/PKCS8.hs
@@ -1,265 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Coded.ASN1.PKCS8--- Copyright : (c) Dominic Steinitz 2003--- License : BSD-style (see the file ReadMe.tex)--- --- Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : non-portable------ Definitions to allow the typechecking of a PKCS8 private key and--- functions to extract information from it. --- --- See <http://www.rsasecurity.com/rsalabs/pkcs/pkcs-8/>.-----------------------------------------------------------------------------------module Codec.ASN1.PKCS8 (--- * Type declarations- RSAPrivateKey(..),- PrivateKeyInfo(..),--- * Function declarations- rsaPrivateKey,- privateKeyInfo- ) where--import Data.Maybe-import Codec.ASN1-import Codec.ASN1.BER-import Codec.ASN1.X509 (- algorithmIdentifier,- AlgorithmIdentifier,- attributeTypeAndValue,- AttributeTypeAndValue- )--{--See http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1.2. A.1.2-RSA private key syntax:--RSAPrivateKey ::= SEQUENCE {- version Version,- modulus INTEGER, -- n- publicExponent INTEGER, -- e- privateExponent INTEGER, -- d- prime1 INTEGER, -- p- prime2 INTEGER, -- q- exponent1 INTEGER, -- d mod (p-1)- exponent2 INTEGER, -- d mod (q-1)- coefficient INTEGER, -- (inverse of q) mod p- otherPrimeInfos OtherPrimeInfos OPTIONAL- }--}--rsaPrivateKey :: TypeDefn-rsaPrivateKey =- "RSAPrivateKey" ::=- AbsSeq Universal 16 Implicit - [Regular (Just "version" :>: (Nothing :@: version)),- Regular (Just "modulus" :>: (Nothing :@: absInteger)),- Regular (Just "publicExponent" :>: (Nothing :@: absInteger)),- Regular (Just "privateExponent" :>: (Nothing :@: absInteger)),- Regular (Just "prime1" :>: (Nothing :@: absInteger)),- Regular (Just "prime2" :>: (Nothing :@: absInteger)),- Regular (Just "exponent1" :>: (Nothing :@: absInteger)),- Regular (Just "exponent2" :>: (Nothing :@: absInteger)),- Regular (Just "coefficient" :>: (Nothing :@: absInteger))]--data RSAPrivateKey =- RSAPrivateKey {- version1 :: Integer,- modulus :: Integer, -- n- publicExponent :: Integer, -- e- privateExponent :: Integer, -- d- prime1 :: Integer, -- p- prime2 :: Integer, -- q- exponent1 :: Integer, -- d mod (p-1)- exponent2 :: Integer, -- d mod (q-1)- coefficient :: Integer -- (inverse of q) mod p- }- deriving Show--instance Encode RSAPrivateKey where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- as' = map (\x -> replaceRef x as bs) as- version = fromJust $ decode (as'!!0) (bs!!0)- modulus = fromJust $ decode (as'!!1) (bs!!1)- publicExponent = fromJust $ decode (as'!!2) (bs!!2)- privateExponent = fromJust $ decode (as'!!3) (bs!!3)- prime1 = fromJust $ decode (as'!!4) (bs!!4)- prime2 = fromJust $ decode (as'!!5) (bs!!5)- exponent1 = fromJust $ decode (as'!!6) (bs!!6)- exponent2 = fromJust $ decode (as'!!7) (bs!!7)- coefficient = fromJust $ decode (as'!!8) (bs!!8)- return $ - RSAPrivateKey {- version1 = version,- modulus = modulus,- publicExponent = publicExponent,- privateExponent = privateExponent,- prime1 = prime1,- prime2 = prime2,- exponent1 = exponent1,- exponent2 = exponent2,- coefficient = coefficient}--version = modName "Version" absInteger--type Version = Integer--{--PrivateKey ::= OCTET STRING--}--privateKey = modName "PrivateKey" absOctetString--type PrivateKey = OctetString--{--Attributes ::= SET OF Attribute--}--attributes = - "Attributes" ::= AbsSetOf Universal 16 Implicit attributeTypeAndValue--type Attributes = SetOf AttributeTypeAndValue--{--PrivateKeyInfo ::= SEQUENCE {- version Version,- privateKeyAlgorithm AlgorithmIdentifier {{PrivateKeyAlgorithms}},- privateKey PrivateKey,- attributes [0] Attributes OPTIONAL - }--}--privateKeyInfo :: TypeDefn-privateKeyInfo =- "privateKeyInfo" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "version" :>: (Nothing :@: version)),- Regular (- Just "privateKeyAlgorithm" :>: (Nothing :@: algorithmIdentifier)- ),- Regular (Just "privateKey" :>: (Nothing :@: privateKey)),- Optional (Just "attributes" :>: (Nothing :@: attributes))- ]--data PrivateKeyInfo =- PrivateKeyInfo {- version2 :: Version,- privateKeyAlgorithm :: AlgorithmIdentifier,- privateKey1 :: PrivateKey,- attributes1 :: Maybe Attributes- }- deriving Show--instance Encode PrivateKeyInfo where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- as' = map (\x -> replaceRef x as bs) as- version = fromJust $ decode (as'!!0) (bs!!0)- privateKeyAlgorithm = fromJust $ decode (as'!!1) (bs!!1)- privateKey = fromJust $ decode (as'!!2) (bs!!2)- attributes = decode (as'!!3) (bs!!3)- return $ - PrivateKeyInfo {- version2 = version,- privateKeyAlgorithm = privateKeyAlgorithm,- privateKey1 = privateKey,- attributes1 = attributes- }--{--type Algorithm = OID---- | This will do for now. DSA has some parameters which are more complicated--- than this but since we plan to do RSA initially and this has NULL parameters--- then anything will do to get us going.--type Parameters = Int---- | The parameters will only ever be Nothing as this implementation--- only supports RSA and this has no parameters. So even if the parameters--- are non-NULL, fromASN will not fail but will ignore them.--data AlgorithmIdentifier =- MkAlgorithmIdentifier {- algorithm :: Algorithm,- parameters :: Maybe Parameters } - deriving Show--data PrivateKeyInfo =- MkPrivateKeyInfo {- version1 :: Version,- privateKeyAlgorithm :: AlgorithmIdentifier,- privateKey :: RSAPrivateKey }- deriving Show--{--We are "overloading" Version. It is defined in --ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-8/pkcs-8v1_2.asn:--Version ::= INTEGER {v1(0)} (v1,...)--and also in --http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1.2:--Version ::= INTEGER { two-prime(0), multi(1) } --although for the latter-definition we represent two-prime in Haskell as V1 and do not support-multi.--}--{--We assume:--Algorithm ::= OID --although the situation is far more complicated.-See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html.--}--algorithm = modName "Algorithm" absOID--type Algorithm = OID--{--We assume:--Parameters ::= NULL--although the situation is far more complicated.-See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html.--}--parameters = modName "Parameters" absNull--type Parameters = NULL--{--See http://www.itu.int/ITU-T/asn1/database/itu-t/x/x509/1997/AuthenticationFramework.html#AuthenticationFramework.AlgorithmIdentifier.--For now, the parameters will only ever be Nothing as this implementation-only supports RSA and this has no parameters. If the parameters-are non-NULL, we will report an error.--See http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1. A.1 RSA key representation:--"The parameters field associated with this OID in a value of type AlgorithmIdentifier shall have a value of type NULL"--}--{--See ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-8/pkcs-8v1_2.asn.--}---}
− Codec/ASN1/TLV.hs
@@ -1,185 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Codec.ASN1.TLV--- Copyright : (c) Dominic Steinitz 2005--- License : BSD-style (see the file ReadMe.tex)--- --- Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : portable------ Decode binary BER into abstract an abstract representation of tag,--- length and value ensuring that the lengths are consistent.-----------------------------------------------------------------------------------module Codec.ASN1.TLV (- -- * Types-- -- * Function types,- tlv,- tlvIO- ) where-import Data.Bits-import Control.Exception-import Control.Monad.State-import Control.Monad.Error-import System.IO.Error-import qualified NewBinary.Binary as B (BinHandle, getBits, getByte)-import Codec.ASN1.BER-import Codec.Utils---- The bit decoder will (by design) never lie about lengths--- because it can check these. It may lie (if that's what it's being--- told) about numbers of components because it can't check these --- without having the ASN.1 definitions.--{--041120 125723-When interpreting the bits into tag-length-value form,-remember to keep track of where things are.--041120 161608-We'll need isEOFBin or to catch exceptions.--041121 151059-As decoding to tag length value is monadic and then so it-decoding to the ASN.1 at some point we'll need to interleave-actions.--080105 082425-tlv should report an error if there are any Octets left over.--}--tlv :: [Octet] -> (Length,Encoding)-tlv xs = let ((l,e),_) = runState (tlv_ undefined) (xs,0::Offset) in (l,e)--tlvIO :: BinHandle -> IO (Length, Encoding)-tlvIO = tlv_--tlv_ bin =- do tagValueVal <- getBits bin 5- tagConstructionVal <- getBits bin 1- tagTypeVal <- getBits bin 2- let tagType = toEnum $ fromIntegral tagTypeVal- tagValue = fromIntegral tagValueVal- if tagValue /= 31- then do (ll,l) <- getLength bin- f 1 tagConstructionVal - tagType tagValue ll l- else do xs <- getTagOctets bin- let longform = - fromIntegral (fromOctets 128 xs)- (ll,l) <- getLength bin- f (fromIntegral $ length xs) tagConstructionVal - tagType longform ll l- where f tl tcv tt tv ll l = - if tcv == 0- then do xs <- getOctets bin l- let x = Primitive tt tv l xs- return (tl+ll+l,x)- else do ys <- tlvs_ bin l- let x = Constructed tt tv l ys- return (tl+ll+l,x)--tlvs_ bin curLen- | curLen < 0 = fail "Codec.ASN1.TLV.tlvs_: trying to decode a negative number of octets"- | curLen == 0 = return []- | otherwise = do (l,x) <- tlv_ bin- ys <- tlvs_ bin (curLen-l)- return (x:ys)--getTagOctets bin = - do x <- getByte bin- if not (testBit x msb)- then return [x]- else do xs <- getTagOctets bin- return ((clearBit x msb):xs)---- Need to think about testing. Here are some links:---- http://www.eeye.com/html/Research/Advisories/AD20040210.html--- http://www.galois.com/files/HCSS-04-ASN.1.pdf--- http://www.larmouth.demon.co.uk/tutorials/tagging/sld003.htm---getLength bin =- do x <- getByte bin- let isShort = not (testBit x msb)- shortform = fromIntegral x- length = fromIntegral (clearBit x msb) in - if x == 0x80- then error "Indefinite length not supported"- else if isShort- then return (1,shortform)- else do xs <- getOctets bin length- let longform = fromOctets 256 xs in- return (length+1,longform)--getOctets bin l = - if l <= 0 - then return []- else do x <- getByte bin- xs <- getOctets bin (l-1)- return (x:xs)--type BinHandle = B.BinHandle--type NumBits = Int--class Binary m where- getBits :: BinHandle -> NumBits -> m Octet- getByte :: BinHandle -> m Octet--instance Binary IO where- getBits = B.getBits- getByte = B.getByte--type Offset = Int--instance Binary (State ([Octet],Offset)) where- getBits = getBits'- getByte = getByte'--{--getBits is never exported and does not need to be general. We know-we will only ever use it at an Octet boundary and we will never cross-an Octet boundary.--}--getBits' :: MonadState ([Octet],Offset) m => BinHandle -> NumBits -> m Octet-getBits' _ n =- do (xs,offset) <- get- if null xs- then throw (IOException $ - mkIOError eofErrorType - "Codec.ASN1.TLV.getBits" - Nothing Nothing)- else do let r = select offset n (head xs)- m = bitSize r - if offset + n < m- then put (xs,offset + n)- else put (tail xs,0)- return r--select :: Offset -> NumBits -> Octet -> Octet-select offset n x = - clearBits n p $ shiftR x offset- where p = bitSize n--clearBits :: Bits a => Int -> Int -> a -> a-clearBits = bits clearBit--bits :: Enum b => (a -> b -> a) -> b -> b -> a -> a-bits f m n = foldr (.) id (map (\i -> flip f i) [m..n]) --getByte' :: MonadState ([Octet],Offset) m => BinHandle -> m Octet-getByte' _ =- do (xs,offset) <- get- if null xs- then throw (IOException $ - mkIOError eofErrorType - "Codec.ASN1.TLV.getByte" - Nothing Nothing)- else do put (tail xs,offset)- return (head xs)
− Codec/ASN1/X509.hs
@@ -1,465 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Codec.ASN1.X509--- Copyright : (c) Dominic Steinitz 2005--- License : BSD-style (see the file ReadMe.tex)--- --- Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : portable------ Definitions to allow the typechecking of an X.509--- certificate and functions to extract information from it.-----------------------------------------------------------------------------------module Codec.ASN1.X509 (- -- * Types- Certificate(..),- SignedCertificate(..),- SubjectPublicKeyInfo(..),- RSAPublicKey(..),- AlgorithmIdentifier(..),- AttributeTypeAndValue(..),- RelativeDistinguishedName(..),- CertificateVersion,- -- * Type classes- -- * Function types- time,- validity,- attributeTypeAndValue,- relativeDistinguishedName,- algorithmIdentifier,- signedCertificate,- rsaPublicKey,- certificate,- certificate',--- certificateVersion,--- algorithm1,--- parameters1,--- validity1,- notBefore,- notAfter,--- type1,--- value,- unName,- unTime,- unRelativeDistinguishedName-) where-import System.Time-import Data.Maybe-import Codec.ASN1.BER-import Codec.ASN1--{--CertificateSerialNumber ::= INTEGER--}--certificateSerialNumber = modName "CertificateSerialNumber" absInteger--type CertificateSerialNumber = Integer--{--AttributeTypeAndValue ::=- SEQUENCE {- type OBJECT IDENTIFIER,- value ANY DEFINED by type- }--}--attributeTypeAndValue :: TypeDefn-attributeTypeAndValue =- "AttributeTypeAndValue" ::= - AbsSeq Universal 16 Implicit - [Regular (Just "type" :>: (Nothing :@: absOID)),- AnyDefBy 0]--data AttributeTypeAndValue = - AttributeTypeAndValue { type1 :: OID,- value :: DirectoryString}- deriving (Eq,Show)--instance Encode AttributeTypeAndValue where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - AttributeTypeAndValue {- type1 = fromJust $ decode (as!!0) (bs!!0),- value = fromJust $ decode (as!!1) (bs!!1)- }--{--RelativeDistinguishedName ::=- SET OF AttributeTypeAndValue--}--relativeDistinguishedName :: TypeDefn-relativeDistinguishedName =- "RelativeDistinguishedName" ::=- AbsSetOf Universal 17 Implicit attributeTypeAndValue--data RelativeDistinguishedName = - RelativeDistinguishedName (SetOf AttributeTypeAndValue)- deriving (Eq,Show)--unRelativeDistinguishedName :: - RelativeDistinguishedName -> SetOf AttributeTypeAndValue-unRelativeDistinguishedName (RelativeDistinguishedName x) = x--instance Encode RelativeDistinguishedName where- decode a b = - do x <- decode a b- return (RelativeDistinguishedName x)--{--Name ::= SEQUENCE OF RelativeDistnguishedName--}--name =- "Name" ::=- AbsSeqOf Universal 16 Implicit relativeDistinguishedName--data Name = Name [RelativeDistinguishedName]- deriving (Eq,Show)--unName :: Name -> [RelativeDistinguishedName]-unName (Name x) = x--instance Encode Name where- decode a b = - do x <- decode a b- return (Name x)--{--Validity ::= - SEQUENCE {notBefore Time,- notAfter Time- }--}--validity :: TypeDefn-validity =- "Validity" ::=- AbsSeq Universal 16 Implicit- [Regular (Just "notBefore" :>: (Nothing :@: time)),- Regular (Just "notAfter" :>: (Nothing :@: time))]--data Validity =- Validity {- notBefore :: Time, -- CalendarTime- notAfter :: Time -- CalendarTime - }- deriving (Eq,Show)--instance Encode Validity where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - Validity {- notBefore = fromJust $ decode (as!!0) (bs!!0),- notAfter = fromJust $ decode (as!!1) (bs!!1)- }--{--Time ::= - CHOICE {utcTime UTCTime,- generalizedTime GeneralizedTime- }--}--time :: TypeDefn-time =- "Time" ::= AbsRef Universal 23 Implicit absVisibleString--data Time = Time VisibleString- deriving (Eq,Show)--unTime :: Time -> VisibleString-unTime (Time x) = x--instance Encode Time where- decode a b = - do x <- decode a b- return $ Time x--{--SubjectPublicKeyInfo ::= - SEQUENCE {- algorithm AlgorithmIdentifier,- subjectPublicKey BIT STRING- }--}--subjectPublicKeyInfo =- "SubjectPublicKeyInfo" ::=- AbsSeq Universal 16 Implicit- [Regular (Just "algorithm" :>: (Nothing :@: algorithmIdentifier)),- Regular (Just "subjectPublicKeyInfo" :>: (Nothing :@: absBitString))]--data SubjectPublicKeyInfo =- SubjectPublicKeyInfo {- algorithm2 :: AlgorithmIdentifier,- subjectPublicKeyInfo1 :: BitString - }- deriving (Eq,Show)--instance Encode SubjectPublicKeyInfo where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - SubjectPublicKeyInfo {- algorithm2 = fromJust $ decode (as!!0) (bs!!0),- subjectPublicKeyInfo1 = fromJust $ decode (as!!1) (bs!!1)- }--{--Certificate ::=- SEQUENCE {- version [0] Version DEFAULT v1,- serialNumber CertificateSerialNumber,- signature AlgorithmIdentifier,- issuer Name,- validity Validity,- subject Name,- subjectPublicKeyInfo SubjectPublicKeyInfo,- issuerUniqueIdentifier [1] IMPLICIT UniqueIdentifier OPTIONAL,- -- if present, version shall be v2 or v3- subjectUniqueIdentifier [2] IMPLICIT UniqueIdentifier OPTIONAL,- -- if present, version shall be v2 or v3- extensions [3] Extensions OPTIONAL- -- If present, version shall be v3 - }--}--certificate =- "Certificate" ::=- AbsSeq Universal 16 Implicit- [Default (Just "version" :>: - ((Just 0) :@: version)) [030200],- Regular (Just "serialNumber" :>: - (Nothing :@: certificateSerialNumber)),- Regular (Just "signature" :>: - (Nothing :@: algorithmIdentifier)),- Regular (Just "issuer" :>: - (Nothing :@: name)),- Regular (Just "validity" :>: - (Nothing :@: validity)),- Regular (Just "subject" :>: - (Nothing :@: name)),- Regular (Just "subjectPublicKeyInfo" :>: - (Nothing :@: subjectPublicKeyInfo))]--{--We don't handle IMPLICIT / EXPLICIT correctly on ComponentTypes of-SEQUENCE so we have to invent a new intermediate type to get over-the problem here until it is fixed in the main ASN1 module.--CertificateVersion ::=- [1] EXPLICIT Version--}--certificateVersion =- "version" ::= AbsRef Context 0 Explicit version--certificate' =- "Certificate" ::=- AbsSeq Universal 16 Implicit- [Default (Nothing :>: - (Nothing :@: certificateVersion)) [030200],- Regular (Just "serialNumber" :>: - (Nothing :@: certificateSerialNumber)),- Regular (Just "signature" :>: - (Nothing :@: algorithmIdentifier)),- Regular (Just "issuer" :>: - (Nothing :@: name)),- Regular (Just "validity" :>: - (Nothing :@: validity)),- Regular (Just "subject" :>: - (Nothing :@: name)),- Regular (Just "subjectPublicKeyInfo" :>: - (Nothing :@: subjectPublicKeyInfo))]--data CertificateVersion =- CertificateVersion Version- deriving (Eq,Show)--instance Encode CertificateVersion where- decode a b =- do y <- b- let a' = absRefedType a- b' = (encodedDefComps y)!!0- x <- decode a' b'- return $ CertificateVersion x--certificateVersionToVersion :: CertificateVersion -> Version-certificateVersionToVersion (CertificateVersion x) = x--data Certificate =- Certificate {- version3 :: Version,- serialNumber :: CertificateSerialNumber,- signature :: AlgorithmIdentifier,- issuer :: Name,- validity1 :: Validity,- subject :: Name,- subjectPublicKeyInfo2 :: SubjectPublicKeyInfo- }- deriving (Eq,Show)--instance Encode Certificate where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- version = certificateVersionToVersion $ - fromJust $ decode (as!!0) (bs!!0)- serialNumber = fromJust $ decode (as!!1) (bs!!1)- signature = fromJust $ decode (as!!2) (bs!!2)- issuer = fromJust $ decode (as!!3) (bs!!3)- validity = fromJust $ decode (as!!4) (bs!!4)- subject = fromJust $ decode (as!!5) (bs!!5)- subjectPublicKeyInfo = fromJust $ decode (as!!6) (bs!!6)- return $ - Certificate {- version3 = version,- serialNumber = serialNumber,- signature = signature,- issuer = issuer,- validity1 = validity,- subject = subject,- subjectPublicKeyInfo2 = subjectPublicKeyInfo- }--signedCertificate :: TypeDefn-signedCertificate =- "SignedCertificate" ::=- AbsSeq Universal 16 Implicit- [Regular (Nothing :>: (Nothing :@: certificate')),- Regular (Nothing :>: (Nothing :@: algorithmIdentifier)),- Regular (Nothing :>: (Nothing :@: absBitString))]--data SignedCertificate =- SignedCertificate {- certificate1 :: Certificate,- algorithmIdentifier1 :: AlgorithmIdentifier,- octetString :: BitString- } - deriving (Eq,Show)--instance Encode SignedCertificate where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - SignedCertificate {- certificate1 = fromJust $ decode (as!!0) (bs!!0),- algorithmIdentifier1 = fromJust $ decode (as!!1) (bs!!1),- octetString = fromJust $ decode (as!!2) (bs!!2)- }--{--RSAPublicKey ::= SEQUENCE {- modulus INTEGER, -- n- publicExponent INTEGER -- e -}--}--rsaPublicKey :: TypeDefn-rsaPublicKey =- "RSAPublicKey" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "modulus" :>: (Nothing :@: absInteger)),- Regular (Just "publicExponent" :>: (Nothing :@: absInteger))- ]--data RSAPublicKey = - RSAPublicKey {- modulus1 :: Integer,- publicExponent1 :: Integer- }- deriving (Eq,Show)--instance Encode RSAPublicKey where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - RSAPublicKey {- modulus1 = fromJust $ decode (as!!0) (bs!!0),- publicExponent1 = fromJust $ decode (as!!1) (bs!!1)- }--version = modName "Version" absInteger--type Version = Integer--{--We assume:--Algorithm ::= OID --although the situation is far more complicated.-See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html.--}--algorithm = modName "Algorithm" absOID--type Algorithm = OID--{--We assume:--Parameters ::= NULL--although the situation is far more complicated.-See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html.--}--parameters = modName "Parameters" absNull--type Parameters = NULL--{--See http://www.itu.int/ITU-T/asn1/database/itu-t/x/x509/1997/AuthenticationFramework.html#AuthenticationFramework.AlgorithmIdentifier.--For now, the parameters will only ever be Nothing as this implementation-only supports RSA and this has no parameters. If the parameters-are non-NULL, we will report an error.--See http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1. A.1 RSA key representation:--"The parameters field associated with this OID in a value of type AlgorithmIdentifier shall have a value of type NULL"--}--algorithmIdentifier :: TypeDefn-algorithmIdentifier =- "AlgorithmIdentifier" ::=- AbsSeq Universal 16 Implicit - [Regular (Just "algorithm" :>: (Nothing :@: algorithm)), - Regular (Just "parameters" :>: (Nothing :@: parameters))]--data AlgorithmIdentifier =- AlgorithmIdentifier {- algorithm1 :: Algorithm,- parameters1 :: Maybe Parameters } - deriving (Eq,Show)--instance Encode AlgorithmIdentifier where- decode a b = - do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $ - AlgorithmIdentifier {- algorithm1 = fromJust $ decode (as!!0) (bs!!0),- parameters1 = Nothing- }-
− Codec/ASN1/X509/AttributeCertificateDefinitions.hs
@@ -1,483 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Coded.ASN1.InformationFramework--- Copyright : (c) Dominic Steinitz 2006--- License : BSD-style (see the file ReadMe.tex)--- --- Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : non-portable------ Definitions to allow the typechecking of (BER) encodings of definitions from--- AttributeCertificateDefinitions {joint-iso-itu-t ds(5) module(1)--- attributeCertificateDefinitions(32) 5}--- and --- functions to extract information from encodings of them.--- --- See <http://www.itu.int/ITU-T/asn1/database/itu-t/x/x509/2005/AttributeCertificateDefinitions.html>-----------------------------------------------------------------------------------module Codec.ASN1.X509.AttributeCertificateDefinitions (--- * Type declarations- AttributeCertificate(..),- AttributeCertificateInfo(..),- Holder(..),- HolderGeneralNames(..),- AttCertIssuer(..),- IssuerSerial(..),- Attribute(..),- AttributeValue(..),- AttCertValidityPeriod(..),- GeneralizedTime(..),--- * Function declarations- attributeCertificate,- holder,- holder',- holderGeneralNames,- attCertIssuer,- issuerSerial,- attribute- ) where--import Codec.ASN1-import Codec.ASN1.BER-import Data.Maybe(- fromJust- )-import Codec.ASN1.X509 (- algorithmIdentifier,- AlgorithmIdentifier- )-import Codec.ASN1.InformationFramework (- generalNames,- GeneralNames- )--{--AttributeCertificate ::= SIGNED {AttributeCertificateInfo}--AttributeCertificate ::= SEQUENCE {- attributeCertificateInfo AttributeCertificateInfo,- algorithmIdentifier AlgorithmIdentifier,- encrypted BIT STRING- } --AttributeCertificateInfo ::= SEQUENCE {- version AttCertVersion, --version is v2- holder Holder,- issuer AttCertIssuer,- signature AlgorithmIdentifier,- serialNumber CertificateSerialNumber,- attrCertValidityPeriod AttCertValidityPeriod,- attributes SEQUENCE OF Attribute,- issuerUniqueID UniqueIdentifier OPTIONAL,- extensions Extensions OPTIONAL- }--AttCertVersion ::= INTEGER { v2(1) }--}--attributeCertificate :: TypeDefn-attributeCertificate =- "attributeCertificate" ::=- AbsSeq Universal 16 Implicit- [Regular (Nothing :>: (Nothing :@: attributeCertificateInfo)),- Regular (Nothing :>: (Nothing :@: algorithmIdentifier)),- Regular (Nothing :>: (Nothing :@: absBitString))]--attributeCertificateInfo :: TypeDefn-attributeCertificateInfo =- "attributeCertificateInfo" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "version" :>: (Nothing :@: version)),- Regular (Just "holder" :>: (Nothing :@: holder')),- Regular (Just "issuer" :>: (Nothing :@: attCertIssuer)),- Regular (Just "signature" :>: - (Nothing :@: algorithmIdentifier)),- Regular (Just "serialNumber" :>: - (Nothing :@: certificateSerialNumber)),- Regular (Just "attrCertValidityPeriod" :>: - (Nothing :@: attCertValidityPeriod)),- Regular (Just "attributes" :>:- (Nothing :@: (- "SEQUENCE OF Attribute" ::=- AbsSeqOf Universal 16 Implicit attribute- )- )- )- ]--data AttributeCertificate =- AttributeCertificate {- attributeCertificateInfo1 :: AttributeCertificateInfo,- algorithmIdentifier2 :: AlgorithmIdentifier,- encrypted :: BitString- } deriving (Eq,Show) --instance Encode AttributeCertificate where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- AttributeCertificate {- attributeCertificateInfo1 = fromJust $ decode (as!!0) (bs!!0),- algorithmIdentifier2 = fromJust $ decode (as!!1) (bs!!1),- encrypted = fromJust $ decode (as!!2) (bs!!2)- }--data AttributeCertificateInfo =- AttributeCertificateInfo {- version1 :: Version,- holder1 :: Holder,- issuer2 :: AttCertIssuer,- signature1 :: AlgorithmIdentifier,- serialNumber1 :: CertificateSerialNumber,- attrCertValidityPeriod :: AttCertValidityPeriod,- attributes :: [Attribute]- } deriving (Eq,Show)--instance Encode AttributeCertificateInfo where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- AttributeCertificateInfo {- version1 = fromJust $ decode (as!!0) (bs!!0),- holder1 = fromJust $ decode (as!!1) (bs!!1),- issuer2 = fromJust $ decode (as!!2) (bs!!2),- signature1 = fromJust $ decode (as!!3) (bs!!3),- serialNumber1 = fromJust $ decode (as!!4) (bs!!4),- attrCertValidityPeriod = fromJust $ decode (as!!5) (bs!!5),- attributes = fromJust $ decode (as!!6) (bs!!6)- }--type Version = Integer--version = modName "Version" absInteger--{--Holder ::= SEQUENCE {- baseCertificateID [0] IssuerSerial OPTIONAL,- -- the issuer and serial number of the holder's Public Key Certificate- entityName [1] GeneralNames OPTIONAL,- -- the name of the entity or role- objectDigestInfo [2] ObjectDigestInfo OPTIONAL- --used to directly authenticate the holder, e.g. an executable- --at least one of baseCertificateID, entityName or objectDigestInfo- -- shall be present- }--}--holder =- "Holder" ::= - AbsSeq Universal 16 Implicit- [Optional (Just "entityName" :>: (Just 1 :@: generalNames))]--holder' =- "Holder" ::= - AbsSeq Universal 16 Implicit- [Optional (Nothing :>: (Nothing :@: holderGeneralNames))]--{--We don't handle IMPLICIT / EXPLICIT correctly on ComponentTypes of-SEQUENCE so we have to invent a new intermediate type to get over -the problem here until it is fixed in the main ASN1 module.--HolderGeneralNames ::=- [1] IMPLICIT GeneralNames--}--holderGeneralNames = - "entityName" ::= AbsRef Context 1 Implicit generalNames--data HolderGeneralNames = - HolderGeneralNames GeneralNames- deriving (Eq,Show)--instance Encode HolderGeneralNames where- decode a b =- do x <- decode a b- return $ HolderGeneralNames x--data Holder =- Holder {- entityName :: Maybe HolderGeneralNames- }- deriving (Eq,Show)--instance Encode Holder where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- Holder {- entityName = decode (as!!0) (bs!!0)- }--{--AttCertIssuer ::= [0] SEQUENCE {- issuerName GeneralNames OPTIONAL,- baseCertificateID [0] IssuerSerial OPTIONAL,- objectDigestInfo [1] ObjectDigestInfo OPTIONAL - }--- At least one component shall be present- ( WITH COMPONENTS { ..., issuerName PRESENT } |- WITH COMPONENTS { ..., baseCertificateID PRESENT } |- WITH COMPONENTS { ..., objectDigestInfo PRESENT } )--}--attCertIssuer :: TypeDefn-attCertIssuer =- "attCertIssuer" ::=- AbsSeq Context 0 Implicit- [Optional (Just "issuerName" :>: - (Nothing :@: generalNames)),- Optional (Just "baseCertificateID" :>:- (Just 0 :@: issuerSerial))-{--051218140100--For now. Since with the PERMIS attribute certificate, we know-that we will get an issuerName, we don't have to support this yet-and ObjectDigestInfo is a) more work and b) contains ENUMERATED-which we don't support yet even though it's not hard so to do.-- Optional (Just "objectDigestInfo" :>:- (Just 1 :@: objectDigestInfo))--}- ]--data AttCertIssuer =- AttCertIssuer {- issuerName :: Maybe GeneralNames,- baseCertificateID :: Maybe IssuerSerial- }- deriving (Eq,Show)--instance Encode AttCertIssuer where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- AttCertIssuer {- issuerName = decode (as!!0) (bs!!0),- baseCertificateID = decode (as!!1) (bs!!1)- }--{- -IssuerSerial ::= SEQUENCE {- issuer GeneralNames,- serial CertificateSerialNumber,- issuerUID UniqueIdentifier OPTIONAL - }--}--issuerSerial =- "IssuerSerial" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "issuer" :>: (Nothing :@: generalNames)),- Regular (Just "serial" :>: (Nothing :@: certificateSerialNumber)),- Optional (Just "issuerUID" :>: (Nothing :@: uniqueIdentifier))- ]--data IssuerSerial =- IssuerSerial {- issuer1 :: GeneralNames,- serial :: CertificateSerialNumber,- issuerID :: Maybe UniqueIdentifier- }- deriving (Eq,Show)--instance Encode IssuerSerial where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- IssuerSerial {- issuer1 = fromJust $ decode (as!!0) (bs!!0),- serial = fromJust $ decode (as!!1) (bs!!1),- issuerID = decode (as!!2) (bs!!2)- }--{--CertificateSerialNumber ::= INTEGER--}--certificateSerialNumber =- modName "CertificateSerialNumber" absInteger--type CertificateSerialNumber = Integer--{--AttCertValidityPeriod ::= SEQUENCE {- notBeforeTime GeneralizedTime,- notAfterTime GeneralizedTime - }--}--attCertValidityPeriod :: TypeDefn-attCertValidityPeriod =- "Validity" ::=- AbsSeq Universal 16 Implicit- [Regular (Just "notBeforeTime" :>: (Nothing :@: generalizedTime)),- Regular (Just "notAfterTime" :>: (Nothing :@: generalizedTime))]--data AttCertValidityPeriod =- AttCertValidityPeriod {- notBeforeTime :: GeneralizedTime,- notAfterTime :: GeneralizedTime- }- deriving (Eq,Show)--instance Encode AttCertValidityPeriod where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- AttCertValidityPeriod {- notBeforeTime = fromJust $ decode (as!!0) (bs!!0),- notAfterTime = fromJust $ decode (as!!1) (bs!!1)- }--{--This is really from X.680.--GeneralizedTime ::= [UNIVERSAL 24] IMPLICIT VisibleString--}--generalizedTime :: TypeDefn-generalizedTime =- "Time" ::= AbsRef Universal 24 Implicit absVisibleString--data GeneralizedTime = GeneralizedTime VisibleString- deriving (Eq,Show)--instance Encode GeneralizedTime where- decode a b =- do x <- decode a b- return $ GeneralizedTime x--{--This is really from--SelectedAttributeTypes {- joint-iso-itu-t ds(5) module(1) selectedAttributeTypes (5) 4- }--UniqueIdentifier ::= BIT STRING--WARNING: typechecking BIT STRING is a kludge and may not work for this.--}--uniqueIdentifier =- modName "UniqueIdentifier" absBitString--type UniqueIdentifier = BitString--{--This is invalid ASN.1 even though it comes from-RFC 3281.--Attribute ::= SEQUENCE {- type AttributeType,- values SET OF AttributeValue- -- at least one value is required- }--AttributeType ::= OBJECT IDENTIFIER--AttributeValue ::= ANY DEFINED BY AttributeType--This is also invalid but it should be easy to support-typechecking of it.--Attribute ::= SEQUENCE {- type AttributeType,- values SET OF ANY DEFINED BY type,- -- at least one value is required- }--The "real" definition is from--InformationFramework -{joint-iso-itu-t(2) ds(5) module(1) informationFramework(1) 3}-has a different definition:--Attribute ::= SEQUENCE {- type - ATTRIBUTE.&id({SupportedAttributes}),- values- SET SIZE (0..MAX) OF- ATTRIBUTE.&Type({SupportedAttributes}{@type}),- valuesWithContext- SET SIZE (1..MAX) OF- SEQUENCE {- value ATTRIBUTE.&Type({SupportedAttributes}{@type}),- contextList SET SIZE (1..MAX) OF Context} OPTIONAL- }--Thus we won't support valuesWithContext. Should they be present,-they will be ignored.--}--{--attribute :: TypeDefn-attribute =- "Attribute" ::=- AbsSeq Universal 16 Implicit- [Regular (Just "type" :>: (Nothing :@: absOID)),- AnyDefBy 0]--}--attribute :: TypeDefn-attribute =- "Attribute" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "type" :>: (Nothing :@: absOID)),- Regular (- Just "values" :>: (- Nothing :@: (- "SET OF AttributeValue" ::= - AbsSetOf Universal 17 Implicit (- "ANY DEFINED BY type" ::= AbsAnyDefBy 0- )- )- )- )- ]--data Attribute =- Attribute {- attributeType :: OID,- attributeValues :: SetOf AttributeValue- }- deriving (Eq,Show)--instance Encode Attribute where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- Attribute {- attributeType = fromJust $ decode (as!!0) (bs!!0),- attributeValues = fromJust $ decode (as!!1) (bs!!1)- }--data AttributeValue = AVPS PrintableString- deriving (Eq,Show)--instance Encode AttributeValue where- decode a@(AbsBasePrim _ _ AbsPrintableString) b =- do x <- decode a b- return (AVPS x)- decode a b =- error (show a ++ "\n" ++ show b)-
− Codec/Binary/Base64.hs
@@ -1,282 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Codec.Binary.Base64--- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002--- License : BSD-style (see the file ReadMe.tex)------ Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : portable------ Base64 encoding and decoding functions provided by Warwick Gray. --- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> --- and <http://www.faqs.org/rfcs/rfc2045.html>.-----------------------------------------------------------------------------------module Codec.Binary.Base64 (- encode,- decode,- chop72-) where----{-------------------------------------------------------------------------This is what RFC2045 had to say:--6.8. Base64 Content-Transfer-Encoding-- The Base64 Content-Transfer-Encoding is designed to represent- arbitrary sequences of octets in a form that need not be humanly- readable. The encoding and decoding algorithms are simple, but the- encoded data are consistently only about 33 percent larger than the- unencoded data. This encoding is virtually identical to the one used- in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421.-- A 65-character subset of US-ASCII is used, enabling 6 bits to be- represented per printable character. (The extra 65th character, "=",- is used to signify a special processing function.)-- NOTE: This subset has the important property that it is represented- identically in all versions of ISO 646, including US-ASCII, and all- characters in the subset are also represented identically in all- versions of EBCDIC. Other popular encodings, such as the encoding- used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and- the base85 encoding specified as part of Level 2 PostScript, do not- share these properties, and thus do not fulfill the portability- requirements a binary transport encoding for mail must meet.-- The encoding process represents 24-bit groups of input bits as output- strings of 4 encoded characters. Proceeding from left to right, a- 24-bit input group is formed by concatenating 3 8bit input groups.- These 24 bits are then treated as 4 concatenated 6-bit groups, each- of which is translated into a single digit in the base64 alphabet.- When encoding a bit stream via the base64 encoding, the bit stream- must be presumed to be ordered with the most-significant-bit first.- That is, the first bit in the stream will be the high-order bit in- the first 8bit byte, and the eighth bit will be the low-order bit in- the first 8bit byte, and so on.-- Each 6-bit group is used as an index into an array of 64 printable- characters. The character referenced by the index is placed in the- output string. These characters, identified in Table 1, below, are- selected so as to be universally representable, and the set excludes- characters with particular significance to SMTP (e.g., ".", CR, LF)- and to the multipart boundary delimiters defined in RFC 2046 (e.g.,- "-").---- Table 1: The Base64 Alphabet-- Value Encoding Value Encoding Value Encoding Value Encoding- 0 A 17 R 34 i 51 z- 1 B 18 S 35 j 52 0- 2 C 19 T 36 k 53 1- 3 D 20 U 37 l 54 2- 4 E 21 V 38 m 55 3- 5 F 22 W 39 n 56 4- 6 G 23 X 40 o 57 5- 7 H 24 Y 41 p 58 6- 8 I 25 Z 42 q 59 7- 9 J 26 a 43 r 60 8- 10 K 27 b 44 s 61 9- 11 L 28 c 45 t 62 +- 12 M 29 d 46 u 63 /- 13 N 30 e 47 v- 14 O 31 f 48 w (pad) =- 15 P 32 g 49 x- 16 Q 33 h 50 y-- The encoded output stream must be represented in lines of no more- than 76 characters each. All line breaks or other characters not- found in Table 1 must be ignored by decoding software. In base64- data, characters other than those in Table 1, line breaks, and other- white space probably indicate a transmission error, about which a- warning message or even a message rejection might be appropriate- under some circumstances.-- Special processing is performed if fewer than 24 bits are available- at the end of the data being encoded. A full encoding quantum is- always completed at the end of a body. When fewer than 24 input bits- are available in an input group, zero bits are added (on the right)- to form an integral number of 6-bit groups. Padding at the end of- the data is performed using the "=" character. Since all base64- input is an integral number of octets, only the following cases can- arise: (1) the final quantum of encoding input is an integral- multiple of 24 bits; here, the final unit of encoded output will be- an integral multiple of 4 characters with no "=" padding, (2) the- final quantum of encoding input is exactly 8 bits; here, the final- unit of encoded output will be two characters followed by two "="- padding characters, or (3) the final quantum of encoding input is- exactly 16 bits; here, the final unit of encoded output will be three- characters followed by one "=" padding character.-- Because it is used only for padding at the end of the data, the- occurrence of any "=" characters may be taken as evidence that the- end of the data has been reached (without truncation in transit). No- such assurance is possible, however, when the number of octets- transmitted was a multiple of three and no "=" characters are- present.-- Any characters outside of the base64 alphabet are to be ignored in- base64-encoded data.-- Care must be taken to use the proper octets for line breaks if base64- encoding is applied directly to text material that has not been- converted to canonical form. In particular, text line breaks must be- converted into CRLF sequences prior to base64 encoding. The- important thing to note is that this may be done directly by the- encoder rather than in a prior canonicalization step in some- implementations.-- NOTE: There is no need to worry about quoting potential boundary- delimiters within base64-encoded bodies within multipart entities- because no hyphen characters are used in the base64 encoding.-------------------------------------------------------------------------------}---{---The following properties should hold:-- decode . encode = id- decode . chop72 . encode = id--I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input,-the second variation corresponds better with the RFC above, but outside of-MIME applications might be undesireable.----But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only - 8 significant bits, which is more than enough for US-ASCII. --}-----import Data.Array-import Data.Bits-import Data.Int-import Data.Char (chr,ord)-import Codec.Utils (Octet)--encodeArray :: Array Int Char-encodeArray = array (0,64) - [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') - , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') - , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R')- , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X')- , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')- , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j')- , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p')- , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v')- , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1')- , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7')- , (60,'8'), (61,'9'), (62,'+'), (63,'/') ]----- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits)--- clearly the upmost/leftmost 8 bits of the answer are 0.--- Hack Alert: In the last entry of the answer, the upper 8 bits encode --- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3.--- 0 represents a 4 :(-int4_char3 :: [Int] -> [Char]-int4_char3 (a:b:c:d:t) = - let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d)- in (chr (n `shiftR` 16 .&. 0xff))- : (chr (n `shiftR` 8 .&. 0xff))- : (chr (n .&. 0xff)) : int4_char3 t--int4_char3 [a,b,c] =- let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6)- in [ (chr (n `shiftR` 16 .&. 0xff))- , (chr (n `shiftR` 8 .&. 0xff)) ]--int4_char3 [a,b] = - let n = (a `shiftL` 18 .|. b `shiftL` 12)- in [ (chr (n `shiftR` 16 .&. 0xff)) ]--int4_char3 [] = [] ------- Convert triplets of characters to--- 4 base64 integers. The last entries--- in the list may not produce 4 integers,--- a trailing 2 character group gives 3 integers,--- while a trailing single character gives 2 integers.-char3_int4 :: [Char] -> [Int]-char3_int4 (a:b:c:t) - = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c)- in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t--char3_int4 [a,b]- = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8)- in [ (n `shiftR` 18 .&. 0x3f)- , (n `shiftR` 12 .&. 0x3f)- , (n `shiftR` 6 .&. 0x3f) ]- -char3_int4 [a]- = let n = (ord a `shiftL` 16)- in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]--char3_int4 [] = []----- Retrieve base64 char, given an array index integer in the range [0..63]-enc1 :: Int -> Char-enc1 ch = encodeArray!ch----- | Cut up a string into 72 char lines, each line terminated by CRLF.--chop72 :: String -> String-chop72 str = let (bgn,end) = splitAt 70 str- in if null end then bgn else "\r\n" ++ chop72 end----- Pads a base64 code to a multiple of 4 characters, using the special--- '=' character.-quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t-quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit-quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit-quadruplets [] = [] -- 24bit tail unit---enc :: [Int] -> [Char]-enc = quadruplets . map enc1---dcd [] = []-dcd (h:t)- | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t- | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t- | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t- | h == '+' = 62 : dcd t- | h == '/' = 63 : dcd t- | h == '=' = [] -- terminate data stream- | otherwise = dcd t----- Principal encoding and decoding functions.--encode :: [Octet] -> String-encode = enc . char3_int4 . (map (chr .fromIntegral))--{--prop_base64 os =- os == (f . g . h) os- where types = (os :: [Word8])- f = map (fromIntegral. ord)- g = decode . encode- h = map (chr . fromIntegral)--}--decode :: String -> [Octet]-decode = (map (fromIntegral . ord)) . int4_char3 . dcd
+ Codec/Binary/BubbleBabble.hs view
@@ -0,0 +1,41 @@+module Codec.Binary.BubbleBabble(encode) where+++import Data.Array.Unboxed+import Data.Bits+import Data.Word++import Codec.Utils+++vowel :: UArray Int Char+vowel = listArray (0,5) "aeiouy"++consonant :: UArray Int Char+consonant = listArray (0,16) "bcdfghklmnprstvzx"+++-- | Encode binary data into the bubble babble human readable encoding.+-- Bubble Babble is an encoding that represents binary data as psuedowords+-- which are more pronouncable and memorable than standard hexadecimal encoding.+--+-- It is mainly used for representing cryptographic fingerprints.+-- In addition, there is an amount of redundancy and error correction built into+-- the representation so that transcription errors can be more readily identified.+--+-- see: http://en.wikipedia.org/wiki/Bubble_Babble+--++encode :: [Octet] -> String+encode cs = 'x' : bb 1 (map fromIntegral cs) where+ bb seed [] = vcvx ((seed `mod` 6),16,(seed `div` 6))+ bb seed [x] = vcvx ((((x `shiftR` 6) .&. 3) + seed) `mod` 6, (x `shiftR` 2) .&. 15, ((x .&. 3) + (seed `div` 6)) `mod` 6)+ bb seed (x:y:xs) = vcvcc (a,b,c,d,e) $ bb ((seed * 5 + (x * 7 + y)) `mod` 36) xs where+ a = (((x `shiftR` 6) .&. 3) + seed) `mod` 6+ b = (x `shiftR` 2) .&. 15+ c = ((x .&. 3) + (seed `div` 6)) `mod` 6+ d = (y `shiftR` 4) .&. 15+ e = y .&. 15+ vcvx (a,b,c) = vowel!a : consonant!b : vowel!c : "x"+ vcvcc (a,b,c,d,e) xs = vowel!a : consonant!b : vowel!c : consonant!d : '-' : consonant!e : xs+
+ Codec/Encryption/TEA.hs view
@@ -0,0 +1,85 @@+-----------------------------------------------------------------------------+-- |+-- Module : Codec.Encryption.TEA+-- Copyright : (c) John Meacham 2008+-- License : BSD-style (see the file ReadMe.tex)+--+-- Maintainer : john@repetae.net (http://repetae.net/)+-- Stability : experimental+-- Portability : portable+--+-- Implementation of the TEA tiny encryption algorithm+--+-----------------------------------------------------------------------------++module Codec.Encryption.TEA(+ TEAKey(TEAKey),+ encrypt,+ decrypt+ ) where++import Data.Bits+import Data.Word++-- We don't use LargeKey for both efficiency and practical reasons.++data TEAKey = TEAKey {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32+++delta :: Word32+delta = 0x9e3779b9++rounds = 32++encrypt :: TEAKey -> Word64 -> Word64+encrypt (TEAKey k0 k1 k2 k3) v = f rounds 0 v0 v1 where+ v0,v1 :: Word32+ v0 = fromIntegral v+ v1 = fromIntegral $ v `shiftR` 32+ f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined+ f 0 _ v0 v1 = (fromIntegral v1 `shiftL` 32) .|. (fromIntegral v0 .&. 0xffffffff)+ f n sum v0 v1 = f (n - 1) sum' v0' v1' where+ sum' = sum + delta+ v0' = (v0 + (((v1 `shiftL` 4) + k0) `xor` (v1 + sum') `xor` ((v1 `shiftR` 5) + k1)))+ v1' = (v1 + (((v0' `shiftL` 4) + k2) `xor` (v0' + sum') `xor` ((v0' `shiftR` 5) + k3)))+++decrypt :: TEAKey -> Word64 -> Word64+decrypt (TEAKey k0 k1 k2 k3) v = f rounds 0xC6EF3720 v0 v1 where+ v0,v1 :: Word32+ v0 = fromIntegral v+ v1 = fromIntegral $ v `shiftR` 32+ f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined+ f 0 _ v0 v1 = (fromIntegral v1 `shiftL` 32) .|. (fromIntegral v0 .&. 0xFFFFFFFF)+ f n sum v0 v1 = f (n - 1) (sum - delta) v0' v1' where+ v1' = (v1 - (((v0 `shiftL` 4) + k2) `xor` (v0 + sum) `xor` ((v0 `shiftR` 5) + k3)))+ v0' = (v0 - (((v1' `shiftL` 4) + k0) `xor` (v1' + sum) `xor` ((v1' `shiftR` 5) + k1)))++++{-+ void encrypt (unsigned long* v, unsigned long* k) {+ unsigned long v0=v[0], v1=v[1], sum=0, i; /* set up */+ unsigned long delta=0x9e3779b9; /* a key schedule constant */+ unsigned long k0=k[0], k1=k[1], k2=k[2], k3=k[3]; /* cache key */+ for (i=0; i < 32; i++) { /* basic cycle start */+ sum += delta;+ v0 += ((v1<<4) + k0) ^ (v1 + sum) ^ ((v1>>5) + k1);+ v1 += ((v0<<4) + k2) ^ (v0 + sum) ^ ((v0>>5) + k3); /* end cycle */+ }+ v[0]=v0; v[1]=v1;+}++void decrypt (unsigned long* v, unsigned long* k) {+ unsigned long v0=v[0], v1=v[1], sum=0xC6EF3720, i; /* set up */+ unsigned long delta=0x9e3779b9; /* a key schedule constant */+ unsigned long k0=k[0], k1=k[1], k2=k[2], k3=k[3]; /* cache key */+ for (i=0; i<32; i++) { /* basic cycle start */+ v1 -= ((v0<<4) + k2) ^ (v0 + sum) ^ ((v0>>5) + k3);+ v0 -= ((v1<<4) + k0) ^ (v1 + sum) ^ ((v1>>5) + k1);+ sum -= delta; /* end cycle */+ }+ v[0]=v0; v[1]=v1;+}++-}
Codec/Text/Raw.hs view
@@ -11,7 +11,8 @@ ----------------------------------------------------------------------------- module Codec.Text.Raw(- hexdump+ hexdump,+ hexdumpBy, ) where import Data.List@@ -36,5 +37,13 @@ vcat . map hcat . map (intersperse colon) . + map (map (text . sh)) . + split n ++hexdumpBy :: String -> OctetsPerLine -> [Octet] -> Doc+hexdumpBy s n = + vcat . + map hcat . + map (intersperse (text s)) . map (map (text . sh)) . split n
Crypto.cabal view
@@ -1,32 +1,27 @@ Name: Crypto-Version: 3.0.3+Version: 4.1.0 License: OtherLicense License-File: ReadMe.tex Author: Dominic Steinitz Maintainer: dominic.steinitz@blueyonder.co.uk-Copyright: Dominic Steinitz 2003 - 2006+Copyright: Dominic Steinitz 2003 - 2007 Stability: Alpha-Synopsis: DES, Blowfish, AES, SHA1, MD5, RSA, X.509 Identity - and Attribute Certificates, General ASN.1 Support, Base64, PKCS8,- PKCS1v15, Hexdump, Support for Word128, Word192 and Word256 and Beyond, PKCS5+Synopsis: DES, Blowfish, AES, TEA, SHA1, MD5, RSA, BubbleBabble,+ Hexdump, Support for Word128, Word192 and Word256 and Beyond, PKCS5 Padding, Various Encryption Modes e.g. Cipher Block Chaining all in one package.-Build-Depends: base, mtl, QuickCheck, HUnit, NewBinary-Ghc-options: -fglasgow-exts-Exposed-Modules: Codec.ASN1,- Codec.ASN1.BER,- Codec.ASN1.InformationFramework,- Codec.ASN1.TLV,- Codec.ASN1.X509,- Codec.ASN1.X509.AttributeCertificateDefinitions,- Codec.ASN1.PKCS1v15,- Codec.ASN1.PKCS8,- Codec.Binary.Base64,+Cabal-Version: >= 1.2+flag small_base+ description: choose the new smaller, split-up base package.+Library+ Exposed-Modules: + Codec.Binary.BubbleBabble, Codec.Encryption.RSA, Codec.Encryption.RSA.EMEOAEP, Codec.Encryption.RSA.MGF, Codec.Encryption.RSA.NumberTheory, Codec.Encryption.DES, Codec.Encryption.AES,+ Codec.Encryption.TEA, Codec.Encryption.Blowfish, Codec.Encryption.Modes, Codec.Encryption.Padding,@@ -34,98 +29,60 @@ Codec.Utils, Data.Digest.MD5, Data.Digest.SHA1,- Data.LargeWord-Other-modules: Codec.Encryption.BlowfishAux,+ Data.Digest.SHA2,+ Data.Digest.SHA224,+ Data.Digest.SHA256,+ Data.Digest.SHA384,+ Data.Digest.SHA512,+ Data.LargeWord,+ Data.HMAC+ Build-Depends: QuickCheck, HUnit+ if flag(small_base)+ Build-Depends: base >= 3, array, random, pretty+ else+ Build-Depends: base < 3+ Ghc-options: -fglasgow-exts+ Other-modules: + Codec.Encryption.BlowfishAux, Codec.Encryption.DESAux,- Data.Digest.SHA1Aux, Codec.Encryption.AESAux, Data.Digest.MD5Aux -Executable: BERTest-Main-Is: BERTest.hs-Ghc-options: -fglasgow-exts-Other-modules: Codec.ASN1,- Codec.ASN1.BER--Executable: X509Example-Main-Is: X509Example.hs-Ghc-options: -fglasgow-exts-Other-modules: Codec.ASN1.BER,- Codec.ASN1,- Codec.ASN1.TLV,- Codec.ASN1.X509,- Codec.Utils--Executable: PKCS8Example-Main-Is: PKCS8Example.hs-Ghc-options: -fglasgow-exts-Other-modules: Codec.ASN1.BER,- Codec.ASN1,- Codec.ASN1.TLV,- Codec.ASN1.X509,- Codec.Utils--Executable: AttributeCertificate-Main-Is: AttributeCertificate.hs-Ghc-options: -fglasgow-exts-Other-modules: Codec.ASN1.BER,- Codec.ASN1,- Codec.ASN1.TLV,- Codec.ASN1.X509,- Codec.Utils,- Codec.ASN1.InformationFramework- Codec.ASN1.X509.AttributeCertificateDefinitions--Executable: RSAEncryptionExample-Main-Is: RSAEncryptionExample.hs-Ghc-options: -fglasgow-exts-Other-modules: Codec.ASN1- Codec.Utils- Data.Digest.SHA1- Codec.Encryption.RSA.MGF- Codec.Encryption.RSA.EMEOAEP- Codec.Encryption.RSA- Codec.ASN1.TLV- Codec.ASN1.X509- Codec.ASN1.BER+Executable SymmetricTest+ Main-Is: SymmetricTest.hs+ Ghc-options: -fglasgow-exts+ Other-modules: Codec.Utils+ Codec.Encryption.Blowfish+ Codec.Encryption.Modes+ Codec.Encryption.Padding+ Codec.Encryption.DES+ Codec.Encryption.AES+ Data.LargeWord -Executable: RSAVerifyExample-Main-Is: RSAVerifyExample.hs-Ghc-options: -fglasgow-exts-Other-modules: Codec.ASN1- Codec.Utils- Data.Digest.SHA1- Codec.Encryption.RSA- Codec.ASN1.TLV- Codec.ASN1.X509- Codec.ASN1.BER- Codec.ASN1.PKCS1v15+Executable SHA1Test+ Main-Is: SHA1Test.hs+ Other-modules: Codec.Text.Raw+ Data.Digest.SHA1 -Executable: SymmetricTest-Main-Is: SymmetricTest.hs-Ghc-options: -fglasgow-exts-Other-modules: Codec.Utils- Codec.Encryption.Blowfish- Codec.Encryption.Modes- Codec.Encryption.Padding- Codec.Encryption.DES- Codec.Encryption.AES- Data.LargeWord+Executable RSATest+ Main-Is: RSATest.hs+ Other-modules: Codec.Utils+ Data.Digest.SHA1+ Codec.Encryption.RSA.MGF+ Codec.Encryption.RSA.EMEOAEP+ Codec.Encryption.RSA -Executable: RSATest-Main-Is: RSATest.hs-Other-modules: Codec.Utils- Data.Digest.SHA1- Codec.Encryption.RSA.MGF- Codec.Encryption.RSA.EMEOAEP- Codec.Encryption.RSA+Executable QuickTest+ Main-Is: QuickTest.hs+ Ghc-options: -fglasgow-exts+ Other-modules: Codec.Utils+ Codec.Encryption.Blowfish+ Codec.Encryption.AES+ Codec.Encryption.Modes+ Codec.Encryption.Padding+ Data.LargeWord -Executable: QuickTest-Main-Is: QuickTest.hs-Ghc-options: -fglasgow-exts-Other-modules: Codec.Utils- Codec.Encryption.Blowfish- Codec.Encryption.AES- Codec.Encryption.Modes- Codec.Encryption.Padding- Data.LargeWord+Executable HMACTest+ Main-Is: HMACTest.hs+ Other-modules: Codec.Utils+ Data.HMAC
Data/Digest/SHA1.hs view
@@ -1,41 +1,120 @@+{-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Digest.SHA1--- Copyright : (c) Dominic Steinitz 2003+-- Copyright : (c) Dominic Steinitz 2007 -- License : BSD-style (see the file ReadMe.tex)--- +-- -- Maintainer : dominic.steinitz@blueyonder.co.uk -- Stability : experimental -- Portability : portable ----- Takes the SHA1 module supplied by Ian Lynagh and wraps it so it--- takes [Octet] and returns [Octet] where the length of the result--- is always 20.--- See <http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/>--- and <http://www.itl.nist.gov/fipspubs/fip180-1.htm>.+-- Take [Word8] and return Word160.+-- See <http://www.itl.nist.gov/fipspubs/fip180-1.htm> for the specification. -- ----------------------------------------------------------------------------- -module Data.Digest.SHA1 (- -- * Function Types- hash) where+module Data.Digest.SHA1(+ Word160(Word160),+ hash,+ lift2,+ toInteger+ ) where -import Data.Digest.SHA1Aux+import Data.Bits+import Data.List+import Data.Word+import Data.Array.IArray import Codec.Utils-import Data.Char(chr)-import Data.List(unfoldr)-import Numeric(readHex)+import Prelude hiding (toInteger) --- | Take [Octet] and return [Octet] according to the standard.--- The length of the result is always 20 octets or 160 bits as required--- by the standard.+rotL :: Bits b => Int -> b -> b+rotL = flip rotateL -hash :: [Octet] -> [Octet]-hash xs = - unfoldr f $ sha1 $ map (chr . fromIntegral) xs- where f :: String -> Maybe (Octet,String)- f [] = - Nothing- f (x:y:zs) = - Just (fromIntegral a,zs)- where [(a,_)] = readHex (x:y:[])+data Word160 = Word160 {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ deriving (Eq, Show)++toInteger :: Word160 -> Integer+toInteger (Word160 a b c d e) = let n = fromIntegral e ++ (fromIntegral d `shiftL` 32) ++ (fromIntegral c `shiftL` 64) ++ (fromIntegral b `shiftL` 96) ++ (fromIntegral a `shiftL` 128)+ in n `seq` n++lift2 :: (Word32 -> Word32 -> Word32) -> Word160 -> Word160 -> Word160+lift2 f a@(Word160 x1 x2 x3 x4 x5) b@(Word160 y1 y2 y3 y4 y5) = + Word160 (f x1 y1) (f x2 y2) (f x3 y3) (f x4 y4) (f x5 y5)++f n x y z + | n <= 19 = (x .&. y) .|. ((complement x) .&. z)+ | n <= 39 = x `xor` y `xor` z+ | n <= 59 = (x .&. y) .|. (x .&. z) .|. (y .&. z)+ | n <= 79 = x `xor` y `xor` z++k n+ | n <= 19 = 0x5a827999+ | n <= 39 = 0x6ed9eba1+ | n <= 59 = 0x8f1bbcdc+ | n <= 79 = 0xca62c1d6++data AccAndWord160 = AccAndWord160 !Int !Word160++-- Word160 -> Word512 -> Word160 +oneBlock ss xs = tt+ where+ us :: Array Int Word32+ us = + accumArray (curry snd) 0 (0,79) (zip [0..15] xs ++ map (\(x,y) -> (x, rotL 1 y))[(i, xxor i) | i<-[16..79]])+ where+ xxor i = us ! (i-16) `xor` us ! (i-3) `xor` us ! (i-8) `xor` us ! (i-14)+ g (AccAndWord160 n (Word160 a b c d e)) w = + AccAndWord160 (n+1) (Word160 ((rotL 5 a) + (f n b c d) + e + w + (k n)) a (rotL 30 b) c d)+ (AccAndWord160 _ tt) = foldl' g (AccAndWord160 0 ss) (elems us)++ss :: Word160+ss = Word160 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0++pad = pad' 0+ where pad' l [] = [0x80] ++ ps ++ lb+ where pl = (64-(l+9)) `mod` 64+ ps = replicate pl 0x00+ lb = i2osp 8 (8*l)+ pad' l (x:xs) = x : (pad' $! l+1) xs -- otherwise (l+1) it will be deferred until replicate++blockWord8sIn512 :: [Word8] -> [[Word8]]+blockWord8sIn512 =+ unfoldr g+ where+ g [] = Nothing+ g xs = Just (splitAt 64 xs)++fromBytes :: (Bits a) => [a] -> a+fromBytes input =+ let dofb accum [] = accum+ dofb accum (x:xs) = dofb ((shiftL accum 8) .|. x) xs+ in+ dofb 0 input++blockWord8sIn32 :: [Word8] -> [[Word8]]+blockWord8sIn32 =+ unfoldr g+ where+ g [] = Nothing+ g xs = Just (splitAt 4 xs)++getWord32s :: [Word8] -> [Word32]+getWord32s =+ map fromBytes . map (map fromIntegral) . blockWord8sIn32++blockWord32sIn512 :: [Word8] -> [[Word32]]+blockWord32sIn512 = (map getWord32s) . blockWord8sIn512 . pad++hashOnce ss a = lift2 (+) ss (oneBlock ss a)++hash :: [Word8] -> Word160+hash = foldl' hashOnce ss . blockWord32sIn512
− Data/Digest/SHA1Aux.hs
@@ -1,106 +0,0 @@-module Data.Digest.SHA1Aux (sha1, sha1_size) where--import Data.Char-import Data.Bits-import Data.Word--type ABCDE = (Word32, Word32, Word32, Word32, Word32)-type XYZ = (Word32, Word32, Word32)-type Rotation = Int--sha1 :: String -> String-sha1 s = s5- where s1_2 = sha1_step_1_2_pad_length s- abcde = sha1_step_3_init- abcde' = sha1_step_4_main abcde s1_2- s5 = sha1_step_5_display abcde'--sha1_size :: (Integral a) => a -> String -> String-sha1_size l s = s5- where s1_2 = s ++ sha1_step_1_2_work (fromIntegral ((toInteger l) `mod` (2^64))) ""- abcde = sha1_step_3_init- abcde' = sha1_step_4_main abcde s1_2- s5 = sha1_step_5_display abcde'--sha1_step_1_2_pad_length :: String -> String-sha1_step_1_2_pad_length s = sha1_step_1_2_work 0 s--sha1_step_1_2_work :: Integer -> String -> String-sha1_step_1_2_work c64 "" = padding ++ len- where padding = '\128':replicate' (shiftR (fromIntegral $ (440 - c64) `mod` 512) 3) '\000'- len = map chr $ size_split 8 c64-sha1_step_1_2_work c64 (c:cs) = c:sha1_step_1_2_work ((c64 + 8) `mod` (2^64)) cs--replicate' :: Word16 -> a -> [a]-replicate' 0 _ = []-replicate' n x = x:replicate' (n-1) x--size_split :: Int -> Integer -> [Int]-size_split 0 _ = []-size_split p n = size_split (p-1) n' ++ [fromIntegral d]- where (n', d) = divMod n 256--sha1_step_3_init :: ABCDE-sha1_step_3_init = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476, 0xc3d2e1f0)--sha1_step_4_main :: ABCDE -> String -> ABCDE-sha1_step_4_main abcde "" = {- abcde -} abcde-sha1_step_4_main abcde0 s = sha1_step_4_main abcde5 s'- where (s64, s') = takeDrop 64 s- s16 = get_word_32s s64- s80 = s16 ++ sha1_add_ws 16 (drop 13 s16, drop 8 s16, drop 2 s16, s16)- (s20_0, s60) = takeDrop 20 s80- (s20_1, s40) = takeDrop 20 s60- (s20_2, s20_3) = takeDrop 20 s40- abcde1 = foldl (doit f1 0x5a827999) abcde0 s20_0- abcde2 = foldl (doit f2 0x6ed9eba1) abcde1 s20_1- abcde3 = foldl (doit f3 0x8f1bbcdc) abcde2 s20_2- abcde4 = foldl (doit f2 0xca62c1d6) abcde3 s20_3- f1 (x, y, z) = (x .&. y) .|. ((complement x) .&. z)- f2 (x, y, z) = x `xor` y `xor` z- f3 (x, y, z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)- (a, b, c, d, e ) = abcde0- (a', b', c', d', e') = abcde4- abcde5 = (a + a', b + b', c + c', d + d', e + e')--doit :: (XYZ -> Word32) -> Word32 -> ABCDE -> Word32 -> ABCDE-doit f k (a, b, c, d, e) w = (a', a, rotL b 30, c, d)- where a' = rotL a 5 + f(b, c, d) + e + w + k--sha1_add_ws :: Int -> ([Word32], [Word32], [Word32], [Word32]) -> [Word32]-sha1_add_ws 80 _ = []-sha1_add_ws n (w1:w1s, w2:w2s, w3:w3s, w4:w4s)- = w:sha1_add_ws (n + 1) (w1s ++ [w], w2s ++ [w], w3s ++ [w], w4s ++ [w])- where w = rotL (foldr1 xor [w1, w2, w3, w4]) 1--get_word_32s :: String -> [Word32]-get_word_32s "" = []-get_word_32s ss = this:rest- where (s, ss') = takeDrop 4 ss- this = sum $ zipWith shiftL (map (fromIntegral.ord) s) [24, 16, 8, 0]- rest = get_word_32s ss'--takeDrop :: Int -> [a] -> ([a], [a])-takeDrop _ [] = ([], [])-takeDrop 0 xs = ([], xs)-takeDrop n (x:xs) = (x:ys, zs)- where (ys, zs) = takeDrop (n-1) xs--sha1_step_5_display :: ABCDE -> String-sha1_step_5_display (a, b, c, d, e)- = foldr (\x y -> display_32bits_as_hex x ++ y) "" [a, b, c, d, e]--display_32bits_as_hex :: Word32 -> String-display_32bits_as_hex x0 = map getc [y8,y7,y6,y5,y4,y3,y2,y1]- where (x1, y1) = divMod x0 16- (x2, y2) = divMod x1 16- (x3, y3) = divMod x2 16- (x4, y4) = divMod x3 16- (x5, y5) = divMod x4 16- (x6, y6) = divMod x5 16- (y8, y7) = divMod x6 16- getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n)--rotL :: Word32 -> Rotation -> Word32-rotL a s = shiftL a s .|. shiftL a (s-32)-
+ Data/Digest/SHA2.hs view
@@ -0,0 +1,285 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Digest.SHA2+-- Copyright : (c) Russell O'Connor 2006+-- License : BSD-style (see the file ReadMe.tex)+-- +-- Implements SHA-256, SHA-384, SHA-512, and SHA-224 as defined in FIPS 180-2+-- <http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>.+--+-----------------------------------------------------------------------------++module Data.Digest.SHA2 (sha256, sha256Ascii, Hash256+ ,sha512, sha512Ascii, Hash512+ ,sha384, sha384Ascii, Hash384+ ,sha224, sha224Ascii, Hash224+ ,toOctets) where++import Data.Word+import Data.Bits+import Data.List+import Numeric+import Test.HUnit++ch x y z = (x .&. y) `xor` (complement x .&. z)+maj x y z = (x .&. y) `xor` (x .&. z) `xor` (y .&. z)++class (Bits w) => ShaData w where+ bigSigma0 :: w -> w+ bigSigma1 :: w -> w+ smallSigma0 :: w -> w+ smallSigma1 :: w -> w+ ks :: [w]++instance ShaData Word32 where+ bigSigma0 x = rotateR x 2 `xor` rotateR x 13 `xor` rotateR x 22+ bigSigma1 x = rotateR x 6 `xor` rotateR x 11 `xor` rotateR x 25+ smallSigma0 x = rotateR x 7 `xor` rotateR x 18 `xor` shiftR x 3+ smallSigma1 x = rotateR x 17 `xor` rotateR x 19 `xor` shiftR x 10+ ks = + [0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5+ ,0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174+ ,0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da+ ,0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967+ ,0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85+ ,0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070+ ,0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3+ ,0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2]++instance ShaData Word64 where+ bigSigma0 x = rotateR x 28 `xor` rotateR x 34 `xor` rotateR x 39+ bigSigma1 x = rotateR x 14 `xor` rotateR x 18 `xor` rotateR x 41+ smallSigma0 x = rotateR x 1 `xor` rotateR x 8 `xor` shiftR x 7+ smallSigma1 x = rotateR x 19 `xor` rotateR x 61 `xor` shiftR x 6+ ks = + [0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f, 0xe9b5dba58189dbbc+ ,0x3956c25bf348b538, 0x59f111f1b605d019, 0x923f82a4af194f9b, 0xab1c5ed5da6d8118+ ,0xd807aa98a3030242, 0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2+ ,0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235, 0xc19bf174cf692694+ ,0xe49b69c19ef14ad2, 0xefbe4786384f25e3, 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65+ ,0x2de92c6f592b0275, 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5+ ,0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f, 0xbf597fc7beef0ee4+ ,0xc6e00bf33da88fc2, 0xd5a79147930aa725, 0x06ca6351e003826f, 0x142929670a0e6e70+ ,0x27b70a8546d22ffc, 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df+ ,0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6, 0x92722c851482353b+ ,0xa2bfe8a14cf10364, 0xa81a664bbc423001, 0xc24b8b70d0f89791, 0xc76c51a30654be30+ ,0xd192e819d6ef5218, 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8+ ,0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99, 0x34b0bcb5e19b48a8+ ,0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb, 0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3+ ,0x748f82ee5defb2fc, 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec+ ,0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915, 0xc67178f2e372532b+ ,0xca273eceea26619c, 0xd186b8c721c0c207, 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178+ ,0x06f067aa72176fba, 0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b+ ,0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc, 0x431d67c49c100d4c+ ,0x4cc5d4becb3e42b6, 0x597f299cfc657e2a, 0x5fcb6fab3ad6faec, 0x6c44198c4a475817]++blockSize = 16++-----------------------------------------------------------------------------+-- | 'padding' currently requires that the bitSize of @a@ divide the bitSize +-- of @w@+-----------------------------------------------------------------------------+padding :: (ShaData w, Bits a, Integral a) => [a] -> [[w]]+padding x = unfoldr block $ paddingHelper x 0 (0::Int) (0::Integer)+ where+ block [] = Nothing+ block x = Just $ splitAt blockSize x+ paddingHelper x o on n | on == (bitSize o) = o:paddingHelper x 0 0 n+ paddingHelper (x:xs) o on n | on < (bitSize o) =+ paddingHelper xs ((shiftL o bs) .|. (fromIntegral x)) (on+bs) $! (n+fromIntegral bs)+ where+ bs = bitSize x+ paddingHelper [] o on n = (shiftL (shiftL o 1 .|. 1) (bso-on-1)):+ (zeros ((-(fromIntegral n-on+3*bso)) `mod` (blockSize*bso)))+ [fromIntegral (shiftR n bso), fromIntegral n]+ where+ bso = bitSize o+ zeros 0 = id+ zeros n | 0 < n = let z=0 in (z:) . (zeros (n-bitSize z))++data Hash8 w = Hash8 !w !w !w !w !w !w !w !w deriving (Eq, Ord)++type Hash256 = Hash8 Word32+type Hash512 = Hash8 Word64++data Hash384 = Hash384 !Word64 !Word64 !Word64 !Word64 !Word64 !Word64 deriving (Eq, Ord)+data Hash224 = Hash224 !Word32 !Word32 !Word32 !Word32 !Word32 !Word32 !Word32 deriving (Eq, Ord)++instance (Integral a) => Show (Hash8 a) where+ showsPrec _ (Hash8 a b c d e f g h) =+ (showHex a) . (' ':) .+ (showHex b) . (' ':) .+ (showHex c) . (' ':) .+ (showHex d) . (' ':) .+ (showHex e) . (' ':) .+ (showHex f) . (' ':) .+ (showHex g) . (' ':) .+ (showHex h)++instance Show Hash384 where+ showsPrec _ (Hash384 a b c d e f) =+ (showHex a) . (' ':) .+ (showHex b) . (' ':) .+ (showHex c) . (' ':) .+ (showHex d) . (' ':) .+ (showHex e) . (' ':) .+ (showHex f)++instance Show Hash224 where+ showsPrec _ (Hash224 a b c d e f g) =+ (showHex a) . (' ':) .+ (showHex b) . (' ':) .+ (showHex c) . (' ':) .+ (showHex d) . (' ':) .+ (showHex e) . (' ':) .+ (showHex f) . (' ':) .+ (showHex g)++class (Eq h, Ord h, Show h) => Hash h where+ toOctets :: h -> [Word8]++bitsToOctets x = helper (bitSize x) x []+ where+ helper s x r | s <= 0 = r+ | otherwise = helper (s-bs) (shiftR x bs) ((fromIntegral x):r)+ where+ bs = bitSize (head r)++instance (Integral h, Bits h) => Hash (Hash8 h) where+ toOctets (Hash8 x0 x1 x2 x3 x4 x5 x6 x7) = bitsToOctets =<< [x0, x1, x2, x3, x4, x5, x6, x7]++instance Hash Hash384 where+ toOctets (Hash384 x0 x1 x2 x3 x4 x5) = bitsToOctets =<< [x0, x1, x2, x3, x4, x5]++instance Hash Hash224 where+ toOctets (Hash224 x0 x1 x2 x3 x4 x5 x6) = bitsToOctets =<< [x0, x1, x2, x3, x4, x5, x6]++shaStep :: (ShaData w) => Hash8 w -> [w] -> Hash8 w+shaStep h m = (foldl' (flip id) h (zipWith mkStep3 ks ws)) `plus` h+ where+ ws = m++zipWith4 smallSigma (drop (blockSize-2) ws) (drop (blockSize-7) ws)+ (drop (blockSize-15) ws) (drop (blockSize-16) ws)+ where+ smallSigma a b c d = smallSigma1 a + b + smallSigma0 c + d+ mkStep3 k w (Hash8 a b c d e f g h) = Hash8 (t1+t2) a b c (d+t1) e f g+ where+ t1 = h + bigSigma1 e + ch e f g + k + w+ t2 = bigSigma0 a + maj a b c+ (Hash8 x0 x1 x2 x3 x4 x5 x6 x7) `plus` (Hash8 y0 y1 y2 y3 y4 y5 y6 y7) =+ Hash8 (x0+y0) (x1+y1) (x2+y2) (x3+y3) (x4+y4) (x5+y5) (x6+y6) (x7+y7)++-----------------------------------------------------------------------------+-- | Due to the limitations of 'padding', 'sha' currently requires that the+-- bitSize of @a@ divide the bitSize of @w@+-----------------------------------------------------------------------------+sha :: (ShaData w, Bits a, Integral a) => Hash8 w -> [a] -> Hash8 w+sha h0 x = foldl' shaStep h0 $ padding x++stringToOctets :: String -> [Word8]+stringToOctets = map (fromIntegral . fromEnum)++-----------------------------------------------------------------------------+-- | 'sha256' currently requires that the bitSize of @a@ divide 32+-----------------------------------------------------------------------------+sha256 :: (Bits a, Integral a) => [a] -> Hash256+sha256 = sha $+ Hash8 0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a 0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19++-----------------------------------------------------------------------------+-- | 'sha384' currently requires that the bitSize of @a@ divide 64+-----------------------------------------------------------------------------+sha384 :: (Bits a, Integral a) => [a] -> Hash384+sha384 x = Hash384 x0 x1 x2 x3 x4 x5+ where+ Hash8 x0 x1 x2 x3 x4 x5 x6 x7 = flip sha x $+ Hash8 0xcbbb9d5dc1059ed8 0x629a292a367cd507 0x9159015a3070dd17 0x152fecd8f70e5939+ 0x67332667ffc00b31 0x8eb44a8768581511 0xdb0c2e0d64f98fa7 0x47b5481dbefa4fa4++-----------------------------------------------------------------------------+-- | 'sha384' currently requires that the bitSize of @a@ divide 64+-----------------------------------------------------------------------------+sha512 :: (Bits a, Integral a) => [a] -> Hash512+sha512 = sha $+ Hash8 0x6a09e667f3bcc908 0xbb67ae8584caa73b 0x3c6ef372fe94f82b 0xa54ff53a5f1d36f1+ 0x510e527fade682d1 0x9b05688c2b3e6c1f 0x1f83d9abfb41bd6b 0x5be0cd19137e2179++-----------------------------------------------------------------------------+-- | 'sha224' currently requires that the bitSize of @a@ divide 32+-----------------------------------------------------------------------------+sha224 :: (Bits a, Integral a) => [a] -> Hash224+sha224 x = Hash224 x0 x1 x2 x3 x4 x5 x6+ where+ Hash8 x0 x1 x2 x3 x4 x5 x6 x7 = flip sha x $+ Hash8 0xc1059ed8 0x367cd507 0x3070dd17 0xf70e5939 0xffc00b31 0x68581511 0x64f98fa7 0xbefa4fa4++-----------------------------------------------------------------------------+-- ** Hashing Strings+-- | @shaXXXAscii@ assumes that all characters of the strings are +-- ISO-latin-1 characters. ie. each characters fits in one octet.+-----------------------------------------------------------------------------+sha256Ascii :: String -> Hash256+sha256Ascii = sha256 . stringToOctets++sha384Ascii :: String -> Hash384+sha384Ascii = sha384 . stringToOctets++sha512Ascii :: String -> Hash512+sha512Ascii = sha512 . stringToOctets++sha224Ascii :: String -> Hash224+sha224Ascii = sha224 . stringToOctets++-----------------------------------------------------------------------------+-- ** Test cases+-- | Below are test cases from the FIPS 180-2 document+-----------------------------------------------------------------------------++-- Should this go into it's own module?++test_sha256 = "SHA-256" ~: test+ [sha256Ascii "abc" ~?=+ Hash8 0xba7816bf 0x8f01cfea 0x414140de 0x5dae2223 0xb00361a3 0x96177a9c 0xb410ff61 0xf20015ad+ ,sha256Ascii "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" ~?=+ Hash8 0x248d6a61 0xd20638b8 0xe5c02693 0x0c3e6039 0xa33ce459 0x64ff2167 0xf6ecedd4 0x19db06c1+ ,sha256Ascii (replicate 1000000 'a') ~?=+ Hash8 0xcdc76e5c 0x9914fb92 0x81a1c7e2 0x84d73e67 0xf1809a48 0xa497200e 0x046d39cc 0xc7112cd0]++test_sha512 = "SHA-512" ~: test+ [sha512Ascii "abc" ~?=+ Hash8 0xddaf35a193617aba 0xcc417349ae204131 0x12e6fa4e89a97ea2 0x0a9eeee64b55d39a+ 0x2192992a274fc1a8 0x36ba3c23a3feebbd 0x454d4423643ce80e 0x2a9ac94fa54ca49f+ ,sha512Ascii ("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmn"+++ "hijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu") ~?=+ Hash8 0x8e959b75dae313da 0x8cf4f72814fc143f 0x8f7779c6eb9f7fa1 0x7299aeadb6889018+ 0x501d289e4900f7e4 0x331b99dec4b5433a 0xc7d329eeb6dd2654 0x5e96e55b874be909+ ,sha512Ascii (replicate 1000000 'a') ~?=+ Hash8 0xe718483d0ce76964 0x4e2e42c7bc15b463 0x8e1f98b13b204428 0x5632a803afa973eb+ 0xde0ff244877ea60a 0x4cb0432ce577c31b 0xeb009c5c2c49aa2e 0x4eadb217ad8cc09b]++test_sha384 = "SHA-384" ~: test+ [sha384Ascii "abc" ~?=+ Hash384 0xcb00753f45a35e8b 0xb5a03d699ac65007 0x272c32ab0eded163 0x1a8b605a43ff5bed+ 0x8086072ba1e7cc23 0x58baeca134c825a7+ ,sha384Ascii ("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmn"+++ "hijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu") ~?=+ Hash384 0x09330c33f71147e8 0x3d192fc782cd1b47 0x53111b173b3b05d2 0x2fa08086e3b0f712+ 0xfcc7c71a557e2db9 0x66c3e9fa91746039+ ,sha384Ascii (replicate 1000000 'a') ~?=+ Hash384 0x9d0e1809716474cb 0x086e834e310a4a1c 0xed149e9c00f24852 0x7972cec5704c2a5b+ 0x07b8b3dc38ecc4eb 0xae97ddd87f3d8985]++test_sha224 = "SHA-224" ~: test + [sha224Ascii "abc" ~?=+ Hash224 0x23097d22 0x3405d822 0x8642a477 0xbda255b3 0x2aadbce4 0xbda0b3f7 0xe36c9da7+ ,sha224Ascii "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" ~?=+ Hash224 0x75388b16 0x512776cc 0x5dba5da1 0xfd890150 0xb0c6455c 0xb4f58b19 0x52522525+ ,sha224Ascii (replicate 1000000 'a') ~?=+ Hash224 0x20794655 0x980c91d8 0xbbb4c1ea 0x97618a4b 0xf03f4258 0x1948b2ee 0x4ee7ad67]++test_sha2 = "SHA-2" ~: test+ [test_sha256, test_sha512, test_sha384, test_sha224]++-- Test with:+-- ghc -no-recomp -O --make Data/Digest/SHA2.hs -main-is Data.Digest.SHA2.moduleTest -o moduleTest && ./moduleTest && rm moduleTest+moduleTest = runTestTT test_sha2
+ Data/Digest/SHA224.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Digest.SHA224+-- Copyright : (c) Russell O'Connor 2006+-- License : BSD-style (see the file ReadMe.tex)+-- +-- Takes the SHA2 module supplied and wraps it so it+-- takes [Octet] and returns [Octet] where the length of the result+-- is always 28.+-- and <http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>.+--+-----------------------------------------------------------------------------++module Data.Digest.SHA224 (+ -- * Function Types+ hash) where++import Data.Digest.SHA2 as SHA2+import Codec.Utils++-- | Take [Octet] and return [Octet] according to the standard.+-- The length of the result is always 28 octets or 224 bits as required+-- by the standard.++hash :: [Octet] -> [Octet]+hash = SHA2.toOctets . SHA2.sha224
+ Data/Digest/SHA256.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Digest.SHA256+-- Copyright : (c) Russell O'Connor 2006+-- License : BSD-style (see the file ReadMe.tex)+-- +-- Takes the SHA2 module supplied and wraps it so it+-- takes [Octet] and returns [Octet] where the length of the result+-- is always 32.+-- and <http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>.+--+-----------------------------------------------------------------------------++module Data.Digest.SHA256 (+ -- * Function Types+ hash) where++import Data.Digest.SHA2 as SHA2+import Codec.Utils++-- | Take [Octet] and return [Octet] according to the standard.+-- The length of the result is always 32 octets or 256 bits as required+-- by the standard.++hash :: [Octet] -> [Octet]+hash = SHA2.toOctets . SHA2.sha256
+ Data/Digest/SHA384.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Digest.SHA384+-- Copyright : (c) Russell O'Connor 2006+-- License : BSD-style (see the file ReadMe.tex)+-- +-- Takes the SHA2 module supplied and wraps it so it+-- takes [Octet] and returns [Octet] where the length of the result+-- is always 48.+-- and <http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>.+--+-----------------------------------------------------------------------------++module Data.Digest.SHA384 (+ -- * Function Types+ hash) where++import Data.Digest.SHA2 as SHA2+import Codec.Utils++-- | Take [Octet] and return [Octet] according to the standard.+-- The length of the result is always 48 octets or 384 bits as required+-- by the standard.++hash :: [Octet] -> [Octet]+hash = SHA2.toOctets . SHA2.sha384
+ Data/Digest/SHA512.hs view
@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Digest.SHA512+-- Copyright : (c) Russell O'Connor 2006+-- License : BSD-style (see the file ReadMe.tex)+-- +-- Takes the SHA2 module supplied and wraps it so it+-- takes [Octet] and returns [Octet] where the length of the result+-- is always 64.+-- and <http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>.+--+-----------------------------------------------------------------------------++module Data.Digest.SHA512 (+ -- * Function Types+ hash) where++import Data.Digest.SHA2 as SHA2+import Codec.Utils++-- | Take [Octet] and return [Octet] according to the standard.+-- The length of the result is always 64 octets or 512 bits as required+-- by the standard.++hash :: [Octet] -> [Octet]+hash = SHA2.toOctets . SHA2.sha512
+ Data/HMAC.hs view
@@ -0,0 +1,118 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HMAC+-- Copyright : (c) Greg Heartsfield 2007+-- License : BSD-style (see the file ReadMe.tex)+--+-- Implements HMAC (hashed message authentication code) as defined in FIPS 198+-- <http://csrc.nist.gov/publications/fips/fips198/fips-198a.pdf>.+--+-----------------------------------------------------------------------------++module Data.HMAC(+ -- * Function Types+ hmac, hmac_sha1, hmac_md5,+ -- * Data Types+ HashMethod(HashMethod, digest, input_blocksize),+ ) where++import Data.Digest.SHA1 as SHA1+import Data.Digest.MD5 as MD5+import Data.Word (Word32)+import Data.Bits (shiftR, xor, bitSize, Bits)+import Codec.Utils (Octet)++-- | HMAC works over any hash function, which is represented by+-- HashMethod. A hash function and input block size must+-- be specified.++data HashMethod =+ HashMethod { -- | An arbitrary hash function+ digest :: [Octet] -> [Octet],+ -- | Bit size of an input block to the hash function+ input_blocksize :: Int}++-- Some useful digest functions for use with HMAC.++sha1_hm = HashMethod (w160_to_w8s . SHA1.hash) 512+md5_hm = HashMethod MD5.hash 512++-- | Compute an HMAC using SHA-1 as the underlying hash function.++hmac_sha1 :: [Octet] -- ^ Secret key+ -> [Octet] -- ^ Message text+ -> [Octet] -- ^ Resulting HMAC-SHA1 value+hmac_sha1 = hmac sha1_hm++-- | Compute an HMAC using MD5 as the underlying hash function.++hmac_md5 :: [Octet] -- ^ Secret key+ -> [Octet] -- ^ Message text+ -> [Octet] -- ^ Resulting HMAC-SHA1 value+hmac_md5 = hmac md5_hm++w160_to_w8s :: Word160 -> [Octet]+w160_to_w8s w = concat $ map w32_to_w8s (w160_to_w32s w)++w160_to_w32s :: Word160 -> [Word32]+w160_to_w32s (Word160 a b c d e) = a : b : c : d : e : []++w32_to_w8s :: Word32 -> [Octet]+w32_to_w8s a = (fromIntegral (shiftR a 24)) :+ (fromIntegral (shiftR a 16)) :+ (fromIntegral (shiftR a 8)) :+ (fromIntegral a) : []++-- | Generalized function for creating HMACs on a specified+-- hash function.++hmac :: HashMethod -- ^ Hash function and associated block size+ -> [Octet] -- ^ Secret key+ -> [Octet] -- ^ Message text+ -> [Octet] -- ^ Resulting HMAC value+hmac h uk m = hash (opad ++ (hash (ipad ++ m)))+ where hash = digest h+ (opad, ipad) = process_pads key+ (make_start_pad bs opad_pattern)+ (make_start_pad bs ipad_pattern)+ bs = input_blocksize h+ key = key_from_user h uk++-- Create a key of the proper size from the user-supplied key.+-- Keys greater than blocksize get hashed and padded with zeroes.+-- Keys same as blocksize are used as is.+-- Keys shorter than blocksize are padding with zeroes.++key_from_user :: HashMethod -> [Octet] -> [Octet]+key_from_user h uk =+ case (compare (bitcount uk) (input_blocksize h)) of+ GT -> fill_key ((digest h) uk)+ LT -> fill_key uk+ EQ -> uk+ where fill_key kd =+ kd ++ (take (((input_blocksize h) - (bitcount kd)) `div` 8)+ (repeat 0x0))++-- Create the inner/outer pad values by XOR'ing with the key.++process_pads :: [Octet] -- Key+ -> [Octet] -- opad+ -> [Octet] -- ipad+ -> ([Octet], [Octet]) -- new opad, new ipad+process_pads ks os is =+ unzip $ zipWith3 (\k o i -> (k `xor` o, k `xor` i)) ks os is++-- Create padding values for a hash of a given bit size.++make_start_pad :: Int -> Octet -> [Octet]+make_start_pad size pad = take (size `div` (bitSize pad)) $ repeat pad++-- Padding constants, per the spec.++opad_pattern = 0x5c :: Octet+ipad_pattern = 0x36 :: Octet++-- Bit count of byte array.++bitcount :: [Octet] -> Int+bitcount k = (length k) * (bitSize (head k))
Data/LargeWord.hs view
@@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- module Data.LargeWord- (Word128,Word192,Word256) where+ (LargeKey,Word96,Word128,Word160,Word192,Word224,Word256) where import Data.Word import Data.Bits@@ -32,6 +32,18 @@ largeWordShift :: a -> Int -> a largeWordXor :: a -> a -> a largeBitSize :: a -> Int++-- Word32 is a key in the obvious way.++instance LargeWord Word32 where+ largeWordToInteger = toInteger+ integerToLargeWord = fromInteger+ largeWordPlus = (+)+ largeWordAnd = (.&.)+ largeWordOr = (.|.)+ largeWordShift = shift+ largeWordXor = xor+ largeBitSize = bitSize -- Word64 is a key in the obvious way.
+ HMACTest.hs view
@@ -0,0 +1,183 @@+module Main(main) where++import Data.HMAC+import Test.HUnit+import Codec.Utils (Octet)+import Data.Char(ord)++-- HMAC-SHA1 tests from+-- <http://csrc.nist.gov/publications/fips/fips198/fips-198a.pdf>++-- HMAC-MD5 tests from+-- <http://www.ietf.org/rfc/rfc2104.txt>++-- Test #1: SHA-1 64-byte key (single block)++hmacTest1 =+ TestCase (+ assertEqual "Test HMAC-SHA1 #1 with 64-byte key"+ hmac_1 (hmac_sha1 key_1 message_1)+ )++message_1 = string2words "Sample #1"++key_1 :: [Octet]+key_1 =+ [0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,+ 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,+ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,+ 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27,+ 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f,+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,+ 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f]++hmac_1 :: [Octet]+hmac_1 =+ [0x4f, 0x4c, 0xa3, 0xd5, 0xd6, 0x8b, 0xa7, 0xcc,+ 0x0a, 0x12, 0x08, 0xc9, 0xc6, 0x1e, 0x9c, 0x5d,+ 0xa0, 0x40, 0x3c, 0x0a]+++-- Test #2: SHA 20-byte key (short block)++hmacTest2 =+ TestCase (+ assertEqual "Test HMAC-SHA1 #2 with 20-byte key"+ hmac_2 (hmac_sha1 key_2 message_2)+ )++message_2 = string2words "Sample #2"++key_2 :: [Octet]+key_2 =+ [0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,+ 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f,+ 0x40, 0x41, 0x42, 0x43]++hmac_2 :: [Octet]+hmac_2 =+ [0x09, 0x22, 0xd3, 0x40, 0x5f, 0xaa, 0x3d, 0x19,+ 0x4f, 0x82, 0xa4, 0x58, 0x30, 0x73, 0x7d, 0x5c,+ 0xc6, 0xc7, 0x5d, 0x24]++-- Test #3: SHA 100-byte key (multi-block)++hmacTest3 =+ TestCase (+ assertEqual "Test HMAC-SHA1 #3 with 100-byte key"+ hmac_3 (hmac_sha1 key_3 message_3)+ )++message_3 = string2words "Sample #3"++key_3 :: [Octet]+key_3 =+ [0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57,+ 0x58, 0x59, 0x5a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f,+ 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,+ 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f,+ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77,+ 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f,+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,+ 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f,+ 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97,+ 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f,+ 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7,+ 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf,+ 0xb0, 0xb1, 0xb2, 0xb3]++hmac_3 :: [Octet]+hmac_3 =+ [0xbc, 0xf4, 0x1e, 0xab, 0x8b, 0xb2, 0xd8, 0x02,+ 0xf3, 0xd0, 0x5c, 0xaf, 0x7c, 0xb0, 0x92, 0xec,+ 0xf8, 0xd1, 0xa3, 0xaa]++-- Test #4: SHA 49-byte key (truncated to 12-byte HMAC)++hmacTest4 =+ TestCase (+ assertEqual "Test HMAC-SHA1 #4 with 49-byte key, truncated to 12-bytes"+ hmac_4 (take 12 (hmac_sha1 key_4 message_4))+ )++message_4 = string2words "Sample #4"++key_4 :: [Octet]+key_4 =+ [0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77,+ 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f,+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,+ 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f,+ 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97,+ 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f,+ 0xa0]++hmac_4 :: [Octet]+hmac_4 =+ [0x9e, 0xa8, 0x86, 0xef, 0xe2, 0x68, 0xdb, 0xec,+ 0xce, 0x42, 0x0c, 0x75]++-- Test #5: MD5 Test from rfc 2104 (16-byte key)++hmacTest5 =+ TestCase (+ assertEqual "Test HMAC-MD5 with 16-byte key"+ hmac_5 (hmac_md5 key_5 message_5)+ )++message_5 = string2words "Hi There"++key_5 :: [Octet]+key_5 = take 16 (repeat 0xb)++hmac_5 :: [Octet]+hmac_5 = [0x92, 0x94, 0x72, 0x7a, 0x36, 0x38, 0xbb, 0x1c,+ 0x13, 0xf4, 0x8e, 0xf8, 0x15, 0x8b, 0xfc, 0x9d]++-- Test #6: MD5 Test from rfc 2104 (28-byte key)++hmacTest6 =+ TestCase (+ assertEqual "Test HMAC-MD5 with 28-byte key"+ hmac_6 (hmac_md5 key_6 message_6)+ )++message_6 = string2words "what do ya want for nothing?"++key_6 :: [Octet]+key_6 = string2words "Jefe"++hmac_6 :: [Octet]+hmac_6 = [0x75, 0x0c, 0x78, 0x3e, 0x6a, 0xb0, 0xb5, 0x03,+ 0xea, 0xa8, 0x6e, 0x31, 0x0a, 0x5d, 0xb7, 0x38]++-- Test #7: MD5 Test from rfc 2104 (16-byte key)++hmacTest7 =+ TestCase (+ assertEqual "Test HMAC-MD5 with 16-byte key"+ hmac_7 (hmac_md5 key_7 message_7)+ )++message_7 = take 50 (repeat 0xdd)++key_7 :: [Octet]+key_7 = take 16 (repeat 0xaa)++hmac_7 :: [Octet]+hmac_7 = [0x56, 0xbe, 0x34, 0x52, 0x1d, 0x14, 0x4c, 0x88,+ 0xdb, 0xb8, 0xc7, 0x33, 0xf0, 0xe8, 0xb3, 0xf6]+++string2words :: String -> [Octet]+string2words = map (fromIntegral . ord)++-- Run the tests++tests =+ TestList [hmacTest1, hmacTest2, hmacTest3, hmacTest4,+ hmacTest5, hmacTest6, hmacTest7]++main = runTestTT tests+
− PKCS8Example.hs
@@ -1,117 +0,0 @@-module Main(main) where--import System.IO-import System.Environment-import Control.Monad.Error-import Control.Monad.State-import Data.Maybe-import Data.List (- unfoldr,- intersperse- )-import Numeric (- showHex- )-import NewBinary.Binary-import Codec.Utils (- toOctets- )-import Codec.ASN1.BER-import Codec.ASN1-import Codec.ASN1.TLV-import Codec.ASN1.PKCS8-import Codec.ASN1.X509 (- algorithm1, - parameters1- )-import Text.PrettyPrint--pp pki rsapk =- render (- ppLabelString "Version" (show (version2 pki))- $$- ppLabelDoc "Private Key Algorithm" algid- $$- ppLabelDoc "Private Key" rs- )- where- algid =- ppLabelString "Algorithm" (show (algorithm1 al))- $$- ppLabelString "Parameters" (show (parameters1 al))- al = privateKeyAlgorithm pki- rs = ppLabelString "Version" (show (version1 rsapk))- $$- mod- $$- ppLabelDoc "Public Exponent" puE- $$- ppLabelDoc "Private Exponent" prE- $$- ppLabelDoc "Prime 1" p1- $$- ppLabelDoc "Prime 2" p2- $$- ppLabelDoc "Exponent 1" e1- $$- ppLabelDoc "Exponent 2" e2- $$- ppLabelDoc "Coefficient" co- bar = map (map sh) (split 16 (toOctets 256 (modulus rsapk)))- sh x | x < 16 = showHex x "0"- | otherwise = showHex x ""- split :: Int -> [a] -> [[a]]- split n xs = unfoldr (g n) xs- g :: Int -> [a] -> Maybe ([a],[a])- g n y- | length y == 0 = Nothing- | otherwise = Just (splitAt n y)- mods1 :: [[Doc]]- mods1 = map (intersperse colon) (map (map text) bar)- mods2 :: [Doc]- mods2 = map hcat mods1- mod = ppLabelDoc "Modulus" (vcat mods2)- puE = hexify (publicExponent rsapk)- prE = hexify (privateExponent rsapk)- p1 = hexify (prime1 rsapk)- p2 = hexify (prime2 rsapk)- e1 = hexify (exponent1 rsapk)- e2 = hexify (exponent2 rsapk)- co = hexify (coefficient rsapk)- hexify :: Integral a => a -> Doc- hexify n =- let bar = map (map sh) (split 16 (toOctets 256 n))- foo = map (intersperse colon) (map (map text) bar)- baz = vcat (map hcat foo)- in baz--ppLabelString :: String -> String -> Doc-ppLabelString l x =- text l <> colon <> space <> (text x)--ppLabelDoc :: String -> Doc -> Doc-ppLabelDoc l d =- text l <> colon- $$- nest 3 d--test fileName = - do h <- openFile fileName ReadMode- bin <- openBinIO_ h- (l,x) <- tlvIO bin- (w,y) <- typeCheck privateKeyInfo x- let (_ ::= c) = w- pk = (decode c (Just y))::(Maybe PrivateKeyInfo)- (OctetString xs) = privateKey1 $ fromJust pk- (l',x') = tlv xs- (v,z) <- typeCheck rsaPrivateKey x'- let (_ ::= e) = v- rsapk = (decode e (Just z))::(Maybe RSAPrivateKey)- putStrLn (pp (fromJust pk) (fromJust rsapk))--main = - do progName <- getProgName- args <- getArgs- if length args /= 1- then putStrLn ("Usage: " ++ progName ++ " <fileName>")- else test (args!!0)
QuickTest.hs view
@@ -5,7 +5,6 @@ import Codec.Encryption.AES as AES import Codec.Encryption.Modes import Codec.Encryption.Padding-import Codec.Binary.Base64 import Data.LargeWord import Data.Word import Data.Bits@@ -64,19 +63,7 @@ g = do n <- choose (minBound::Int,maxBound::Int) return (13*n) -prop_base64 os =- os == g os- where types = (os :: [Word8])- g = decode . encode--prop_chop72 os =- os == g os- where types = (os :: [Word8])- g = decode . chop72 . encode--main = do quickCheck prop_base64- quickCheck prop_chop72- quickCheck prop_decryptEncrypt+main = do quickCheck prop_decryptEncrypt quickCheck prop_AESIdempotent quickCheck prop_unCbcCbc quickCheck prop_unPkcs5Pkcs5
− RSAEncryptionExample.hs
@@ -1,104 +0,0 @@-module Main(main) where--import System.IO-import Data.Char-import Data.List-import System.Environment-import System.Console.GetOpt-import Data.Maybe-import Codec.ASN1-import Codec.Utils-import Data.Digest.SHA1-import Codec.Encryption.RSA.MGF-import qualified Codec.Encryption.RSA.EMEOAEP as E-import Codec.Encryption.RSA-import Codec.ASN1.TLV-import Codec.ASN1.X509-import Codec.ASN1.BER-import NewBinary.Binary-import Control.Monad.State--randomSeed :: [Octet]-randomSeed = hash [3]--ciphertext :: [Octet] -> [Octet] -> String -> [Octet]-ciphertext n d x =- encrypt (n,d) $- E.encode mgf hash [] randomSeed n $- map (fromIntegral . ord) x--encryptWith certFile plainTextFile cipherTextFile = -{--certFile should contain an X.509 certificate.--}- do hcert <- openFile certFile ReadMode- hplain <- openFile plainTextFile ReadMode- ptext <- hGetContents hplain- bin <- openBinIO_ hcert- (_,x) <- tlvIO bin-{--Typecheck this is really a signed certificate.--}- (q,sc) <- typeCheck signedCertificate x-{--If it is then decode it and extract the bitstring containing the RSA-public key.--}- let (_ ::= c) = q- d = (decode c (Just sc))::(Maybe SignedCertificate)- d1 = certificate1 (fromJust d)- d2 = subjectPublicKeyInfo2 d1- d3 = subjectPublicKeyInfo1 d2- (BitString e) = d3- (_,x') = tlv e-{--Typecheck this really is an RSA public key.--}- (q',rpk) <- typeCheck rsaPublicKey x'-{--If it is then decode it and extract the modulus and the public-exponent.--}- let (_ ::= r) = q'- s = (decode r (Just rpk))- ct = ciphertext (toOctets 256 $ modulus1 $ fromJust s) - (toOctets 256 $ publicExponent1 $ fromJust s)- ptext-{--Write out the encrypted text.--}- ofh <- openFile cipherTextFile WriteMode- hPutStr ofh (map (chr . fromIntegral) ct)- hClose ofh--main = do pn <- getProgName- args <- getArgs- (fs,ss) <- opts pn args- let sfs = sort fs- (Cert e) = sfs!!0- (Input i) = sfs!!1- (Output o) = sfs!!2- encryptWith e i o--data Flag = Cert String | Input String | Output String - deriving (Show,Eq,Ord)--options = [- Option ['e'] ["cert","certificate"] (ReqArg Cert "CERT")- "Certificate File",- Option ['p'] ["plain","plaintext"] (ReqArg Input "INPUT")- "Plaintext File",- Option ['c'] ["cipher","ciphertext"] (ReqArg Output "OUTPUT")- "Ciphertext Fileoutput"- ]- -opts :: String -> [String] -> IO ([Flag], [String])-opts progName argv = - case getOpt Permute options argv of- (o,n,[] ) -> - if length o == 3- then return (o,n)- else ioError (userError (usageInfo header options))- (_,_,errs) -> - ioError (userError (concat errs ++ usageInfo header options))- where header = "Usage: " ++ progName ++ " [OPTION...] files..."
RSATest.hs view
@@ -1,7 +1,7 @@ module Main(main) where import Codec.Utils-import Data.Digest.SHA1+import Data.Digest.SHA1(hash,Word160(Word160)) import Codec.Encryption.RSA.MGF import Codec.Encryption.RSA.EMEOAEP import Codec.Encryption.RSA@@ -112,10 +112,12 @@ e :: [Octet] e = [0x11] -encodedText = encode mgf hash [] seed n m+hash' xs = let (Word160 a b c d e) = hash xs in concatMap (toOctets 256) [a,b,c,d,e] -decodedText = decode mgf hash [] encodedText+encodedText = encode mgf hash' [] seed n m +decodedText = decode mgf hash' [] encodedText+ encodingTest = TestCase ( assertEqual "Encoding / Decoding" m decodedText@@ -125,7 +127,7 @@ plainText = decrypt (n,d) cipherText -decodedText' = decode mgf hash [] plainText+decodedText' = decode mgf hash' [] plainText encryptionTest = TestCase (
− RSAVerifyExample.hs
@@ -1,112 +0,0 @@-module Main(main) where--import System.IO-import Data.Char-import Data.List-import System.Environment-import System.Console.GetOpt-import Data.Maybe-import Codec.ASN1-import Codec.Utils-import Data.Digest.SHA1-import Codec.Encryption.RSA-import Codec.ASN1.TLV-import Codec.ASN1.X509-import Codec.ASN1.BER-import NewBinary.Binary-import qualified Codec.ASN1.PKCS1v15 as V15--verifyWith certFile plainTextFile signedFile = -{--certFile should contain an X.509 certificate.--}- do hcert <- openFile certFile ReadMode- hplain <- openFile plainTextFile ReadMode- hsign <- openFile signedFile ReadMode- ptext <- hGetContents hplain- psign <- hGetContents hsign- bin <- openBinIO_ hcert- (_,x) <- tlvIO bin-{--Typecheck this is really a signed certificate.--}- (w,sc) <- typeCheck signedCertificate x-{--If it is then decode it and extract the bitstring containing the RSA-public key.--}- let (_ ::= c) = w- d = decode c (Just sc)- d1 = certificate1 (fromJust d)- d2 = subjectPublicKeyInfo2 d1- d3 = subjectPublicKeyInfo1 d2- (BitString e) = d3- (_,x') = tlv e-{--Typecheck this really is an RSA public key.--}- (w',rpk) <- typeCheck rsaPublicKey x'-{--If it is then decode it and extract the modulus and the public-exponent.--}- let (_ ::= r) = w'- s = (decode r (Just rpk))- n = toOctets 256 $ modulus1 $ fromJust s - d = toOctets 256 $ publicExponent1 $ fromJust s-{--Decrypt the signature.--}- sd = decrypt (n,d) (map (fromIntegral . ord) psign)- md = V15.decode sd- di = fromJust md- (l,v) = tlv $ di- if md == Nothing - then error "Decryption error"- else do (w'',w) <- typeCheck V15.digestInfo v- let (_ ::= d) = w''- e = decode d (Just w)- putStrLn (show (V15.digestAlgorithm1 (fromJust e)))- putStrLn ("Given digest: " ++ (show (V15.digest (fromJust e))))-{--Compute the hash of the plaintext file which the signature is-purported to have signed.--}- let h = hash $ map (fromIntegral . ord) ptext- g = OctetString h- putStrLn ("Calculated digest: " ++ (show g))- if (V15.digest (fromJust e) == g)- then putStrLn "Verified"- else putStrLn "Unable to verify"--main = do pn <- getProgName- args <- getArgs- (fs,ss) <- opts pn args- let sfs = sort fs- (Cert e) = sfs!!0- (Input i) = sfs!!1- (Sig s) = sfs!!2- verifyWith e i s--data Flag = Cert String | Input String | Sig String - deriving (Show,Eq,Ord)--options = [- Option ['e'] ["cert","certificate"] (ReqArg Cert "CERT")- "Certificate File",- Option ['p'] ["plain","plaintext"] (ReqArg Input "INPUT")- "Plaintext File",- Option ['s'] ["sig","signature"] (ReqArg Sig "SIGNATURE")- "Signature File"- ]- -opts :: String -> [String] -> IO ([Flag], [String])-opts progName argv = - case getOpt Permute options argv of- (o,n,[] ) -> - if length o == 3- then return (o,n)- else ioError (userError (usageInfo header options))- (_,_,errs) -> - ioError (userError (concat errs ++ usageInfo header options))- where header = "Usage: " ++ progName ++ " [OPTION...] files..."
ReadMe.tex view
@@ -20,7 +20,7 @@ \setlength{\parskip}{\medskipamount} \setlength{\parindent}{0pt} -\title{Haskell Cryptographic Library 3.0.3}+\title{Haskell Cryptographic Library 4.1.0} \author{Dominic Steinitz} \begin{document}@@ -29,30 +29,27 @@ The \htmladdnormallinkfoot-{Haskell Cryptographic Library 3.0.3}+{Haskell Cryptographic Library 4.1.0} {http://www.haskell.org/crypto} collects together existing Haskell cryptographic functions into one cabalized package, together with HUnit tests,-QuickCheck property tests, examples showing how to interwork with-other cryptographic implementations and examples showing how to -handle other ASN.1 definitions.+QuickCheck property tests and examples. It is a significant+change from previous versions and now only contains cryptographic+functions; the functions for dealing with ASN.1, X.509 certificates+and PKCS\#8 will be provided by an entirely separate library reducing+the number of dependencies. This release contains: \begin{itemize} \item DES \item Blowfish \item AES+\item TEA \item Cipher Block Chaining (CBC) \item PKCS\#5 and nulls padding \item SHA-1 \item MD5 \item RSA-\item OAEP-based encryption (Bellare-Rogaway)-\item PKCS\#1v1.5 signature scheme-\item ASN.1-\item PKCS\#8-\item X.509 Identity Certificates-\item X.509 Attribute Certificates \end{itemize} Haddock documentation for the library is available@@ -65,20 +62,12 @@ \begin{itemize} \item-The code has been tested on GHC 6.4.-It does not currently work with Hugs or NHC. +The code has been tested on GHC 6.6 and Hugs Version September 2006.+It does not currently work with YHC because of the lack of {\tt Data.Word}+and {\tt Data.Bits}. \item-It requires the use of-\htmladdnormallinkfoot-{{\tt NewBinary.Binary}}-{http://www.n-heptane.com/nhlab/repos/NewBinary}-.-This uses an old version of cabal and you will need to download -\htmladdnormallinkfoot-{this}-{http://www.haskell.org/crypto/downloads/NewBinary.cabal}-this-in order to build and install it.+It {\em no longer} requires the use of+{\tt NewBinary.Binary}. \end{itemize} \section{Installation Instructions}@@ -87,7 +76,7 @@ \lstset{language=shell,basicstyle=\ttfamily\small} \begin{lstlisting}[frame=single]-darcs get --tag "3.0.3" http://www.haskell.org/crypto/src+darcs get --tag "4.1.0" http://www.haskell.org/crypto/src \end{lstlisting} Build and install ready for testing:@@ -103,7 +92,6 @@ \begin{lstlisting}[frame=single] cd /my/chosen/dir/bin-./BERTest ./RSATest ./SymmetricTest ./QuickTest@@ -122,428 +110,40 @@ ./Setup install \end{lstlisting} -\section{Asymmetric Encryption and Digital Signing}--\subsection{Preliminaries}--First of all, create a self-signed (identity) certificate and private key.-Be careful as not all OIDs are supported (although they are easy to add).--\lstset{language=shell,basicstyle=\ttfamily\small}-\begin{lstlisting}[frame=single]-openssl req -new -nodes -x509 -outform PEM -out cert.pem \--keyout key.pem -days 365 -subj "/C=UK/L=Tooting/CN=Dan"-\end{lstlisting}--Copy the certificate and save it-using the-Distinguished Encoding Rules (DER) format.--\begin{lstlisting}[frame=single]-openssl x509 -inform PEM -outform DER -in cert.pem \--out cert.der-\end{lstlisting}--Extract the public key from the certificate.--\begin{lstlisting}[frame=single]-openssl x509 -in cert.pem -pubkey -noout > pubkey.pem-\end{lstlisting}--Copy the private key and store it using DER.--\begin{lstlisting}[frame=single]-openssl pkcs8 -topk8 -inform PEM -outform DER -in key.pem \--nocrypt -out key.der-\end{lstlisting}--Notes:-\begin{itemize}-\item-The private key is produced in PKCS\#8 format.-You can look at it with Peter Gutmann's ASN.1 -\htmladdnormallinkfoot-{object dump program}-{http://www.cs.auckland.ac.nz/~pgut001/dumpasn1.c}-if required. -\item-The private key is unencrypted. Storing private keys in clear -is not good security practice. The current implementation does not support -encrypted private keys but this should be straightforward to add.-\end{itemize}--Run the examples to examine your private and public keys.--\begin{lstlisting}[frame=single]-PKCS8Example key.der-X509Example cert.der-\end{lstlisting}--\subsection{Attribute Certificates}--\htmladdnormallinkfoot-{PERMIS}-{http://sec.isi.salford.ac.uk/permis}-provides facilities for generating attribute certificates using-the-\htmladdnormallinkfoot-{Attribute Certicate Manager}-{http://sec.isi.salford.ac.uk/permis/private/wip.html\#ACM}-.--Run the example to examine your certificate.--\begin{lstlisting}[frame=single]-AttributeCertificate attCert.der-\end{lstlisting}--\subsection{Encryption}--Run the example to encrypt using Haskell and decrypt using openssl. Note-that only OAEP is supported currently. This is not the default for openssl-so you must remember to add the correct option.--\begin{lstlisting}[frame=single]-echo plaintext > plaintext--RSAEncryptionExample --cert=cert.der --plain=plaintext \---cipher=ciphertext--openssl rsautl -decrypt -inkey key.pem -in ciphertext \ --out unciphertext -oaep-\end{lstlisting}--\subsection{Signing and Verification}--Signing is more complicated than encryption so it is best to check-that you are using signatures correctly before using the library.--You can sign a "small" amount of data with -\begin{tt}openssl rsautl\end{tt}.-Doing this with more data than allowed by the encryption algorithm-will result in error messages. It's important to understand-that this operation signs the raw data and does not digest it-beforehand. However, the operation does apply the padding algorithm-described in the-\htmladdnormallinkfoot-{PKCS \#1 v2.1: RSA Cryptography Standard}-{ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-1/pkcs-1v2-1.pdf}-and in-\htmladdnormallinkfoot-{PKCS \#1: RSA Encryption Standard: An RSA Laboratories Technical Note -Version 1.5 Revised November 1, 1993}-{ftp://ftp.rsasecurity.com/pub/pkcs/ps/pkcs-1.ps}-. This prepends the data to be signed with -\begin{tt}00 01 ff \ldots ff 00\end{tt} as can be seen below.--\begin{lstlisting}[frame=single]-echo small > small.txt--openssl rsautl -in small.txt -inkey key.pem -sign -out small.sgn--openssl rsautl -verify -in small.sgn -inkey pubkey.pem -pubin \--hexdump -raw-\end{lstlisting}--\begin{lstlisting}-0000 - 00 01 ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0010 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0020 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0030 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0040 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0050 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0060 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0070 - ff ff ff ff ff ff ff ff-ff 00 73 6d 61 6c 6c 0a ..........small.-\end{lstlisting}--You can sign larger amounts of data with -\begin{tt}openssl dgst\end{tt}.-In contrast to -\begin{tt}openssl rsautl\end{tt}-this digests-the data, encodes the digest in--\lstset{language=ASN1}-\begin{lstlisting}[frame=single]-DigestInfo ::= SEQUENCE {- digestAlgorithm DigestAlgorithm,- digest OCTET STRING-}-\end{lstlisting}--as DER and then encrypts it with the the private key.-Again, this DER is prepended with -\begin{tt}00 01 ff \ldots ff 00\end{tt} as can be seen below.--\lstset{language=shell,basicstyle=\ttfamily\small}-\begin{lstlisting}[frame=single]-openssl dgst -sha1 -sign key.pem -out ReadMe.sgn ReadMe.tex--openssl rsautl -verify -in ReadMe.sgn -inkey pubkey.pem -pubin \--hexdump -raw-\end{lstlisting}--\begin{lstlisting}-0000 - 00 01 ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0010 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0020 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0030 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0040 - ff ff ff ff ff ff ff ff-ff ff ff ff ff ff ff ff ................-0050 - ff ff ff ff ff ff ff ff-ff ff ff ff 00 30 21 30 .............0!0-0060 - 09 06 05 2b 0e 03 02 1a-05 00 04 14 90 d0 00 b2 ...+............-0070 - f6 b3 d7 2f 2c ab e7 40-6a 75 89 7c bb 56 54 19 .../,..@ju.|.VT.-\end{lstlisting}--The ASN.1 can be parsed using the following command.--\begin{lstlisting}[frame=single]-openssl rsautl -in ReadMe.sgn -verify -asn1parse \--inkey pubkey.pem -pubin-\end{lstlisting}--\begin{lstlisting}- 0:d=0 hl=2 l= 33 cons: SEQUENCE- 2:d=1 hl=2 l= 9 cons: SEQUENCE- 4:d=2 hl=2 l= 5 prim: OBJECT :sha1-11:d=2 hl=2 l= 0 prim: NULL-13:d=1 hl=2 l= 20 prim: OCTET STRING-0000 - 90 d0 00 b2 f6 b3 d7 2f-2c ab e7 40 6a 75 89 7c ......./,..@ju.|-0010 - bb 56 54 19 .VT.-\end{lstlisting}--As a final verification, compare the parsed digest against a digest-of the plaintext file.--\begin{lstlisting}[frame=single]-openssl dgst -sha1 ReadMe.tex-SHA1(ReadMe.tex)= 90d000b2f6b3d72f2cabe7406a75897cbb565419--sha1sum ReadMe.tex-90d000b2f6b3d72f2cabe7406a75897cbb565419 ReadMe.tex-\end{lstlisting}--Now that you have confirmed that signatures are working satisfactorily,-you can verify one using the Haskell example.--\begin{lstlisting}[frame=single]-RSAVerifyExample -ecert.der -pReadMe.tex -sReadMe.sgn-\end{lstlisting}--\begin{lstlisting}-AlgorithmIdentifier {algorithm1 = OID [1,3,14,3,2,26], parameters1 = Nothing}-Given digest: OctetString [144,208,0,178,246,179,215,47,44, \- 171,231,64,106,117,137,124,187,86,84,25]-Calculated digest: OctetString [144,208,0,178,246,179,215,47,44,171, \- 231,64,106,117,137,124,187,86,84,25]-Verified-\end{lstlisting}--\section{ASN.1 Support}--The package contains some enough general ASN.1 support to decode PKCS\#8 and-X.509 identity and attribute certificates encoded using BER. See the examples that-are provided with the package: \begin{tt}X509Example\end{tt},-\begin{tt}PKCS8Example\end{tt}, and \begin{tt}AttributeCertificate\end{tt}.--Here's a further example.--Suppose you have an ASN.1 module and have checked that it conforms to-the standard using, for example, -the on-line tool, -\htmladdnormallinkfoot{Asnp}{http://asn1.elibel.tm.fr/en/tools/asnp/index.htm}-\footnote{Definitions using ANY DEFINED BY have to be checked with -1990.}-\footnote{Asnp was developed in Objective Caml.}--\lstset{language=ASN1}-\begin{lstlisting}[frame=single]-FooBar {1 2 0 0 6 1} DEFINITIONS ::= - BEGIN - Journey ::= SEQUENCE {- origin IA5String,- stop1 [0] IA5String OPTIONAL,- stop2 [1] IA5String OPTIONAL,- destination IA5String- }- Odyssey ::= SEQUENCE {- start Journey,- trip1 [0] Journey OPTIONAL,- trip2 [1] Journey OPTIONAL,- trip3 [2] Journey OPTIONAL,- end Journey- }- END -\end{lstlisting}--Create abstract Haskell representations of the ASN.1 types.--\lstset{language=Haskell}-\begin{lstlisting}[frame=single]-journey =- "Journey" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "origin" :>: - (Nothing :@: absIA5String)),- Optional (Just "stop1" :>: - (Just 0 :@: absIA5String)),- Optional (Just "stop2" :>: - (Just 1 :@: absIA5String)),- Regular (Just "destination" :>: - (Nothing :@: absIA5String))- ]--odyssey =- "Odyssey" ::=- AbsSeq Universal 16 Implicit [- Regular (Just "start" :>: (Nothing :@: journey)),- Optional (Just "trip1" :>: (Just 0 :@: journey)),- Optional (Just "trip2" :>: (Just 1 :@: journey)),- Optional (Just "trip3" :>: (Just 2 :@: journey)),- Regular (Just "end" :>: (Nothing :@: journey))- ]-\end{lstlisting}--Then you can check that (abstract representations of) BER values conform-to these types.--\begin{lstlisting}[frame=single]-module Main(main) where--import Codec.ASN1.BER-import Codec.ASN1---- Other definitions--main = - do (w,y) <- typeCheck odyssey berValue- putStrLn (show w)-\end{lstlisting}--Now suppose that the BER value conforms to the ASN.1 type and that-you wish to manipulate the various values in the encoding. First-create some Haskell types to hold the decoded values.--\begin{lstlisting}[frame=single]-data Journey =- Journey {- origin :: IA5String,- stop1 :: Maybe IA5String,- stop2 :: Maybe IA5String,- destination :: IA5String- }- deriving (Eq,Show)--data Odyssey =- Odyssey {- start :: Journey,- trip1 :: Maybe Journey,- trip2 :: Maybe Journey,- trip3 :: Maybe Journey,- end :: Journey- }- deriving (Eq,Show)-\end{lstlisting}--Then make them instances of the class {\begin{tt}Encode\end{tt}}.--\begin{lstlisting}[frame=single]--instance Encode Journey where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- Journey {- origin = fromJust (decode (as!!0) (bs!!0)),- stop1 = do decode (as!!1) (bs!!1),- stop2 = do decode (as!!2) (bs!!2),- destination = fromJust (decode (as!!3) (bs!!3))- }--instance Encode Odyssey where- decode a b =- do x <- b- let as = absSeqComponents a- bs = encodedDefComps x- return $- Odyssey {- start = fromJust (decode (as!!0) (bs!!0)),- trip1 = do decode (as!!1) (bs!!1),- trip2 = do decode (as!!2) (bs!!2),- trip3 = do decode (as!!3) (bs!!3),- end = fromJust (decode (as!!4) (bs!!4))- }--\end{lstlisting}--Finally, you can extract values from the decoded value.--\begin{lstlisting}[frame=single]-module Main(main) where--import Codec.ASN1.BER-import Codec.ASN1---- Other definitions--main = - do (w,y) <- typeCheck odyssey berValue- let (_ ::= c) = w- d = decode c (Just y)- (Just x) = d- putStrLn . show . start $ x-\end{lstlisting}--Further examples can be found in {\tt BERTest.hs}- \section{To Do} In no particular order: \begin{itemize} \item-Read and generate PKCS12 private keys so that it is easy to inter-work -with other RSA implementations.-\item Incorporate other symmetric key algorithms already coded in Haskell. \item Performance analysis as Blowfish ought to run more quickly than DES. \item Other modes / padding schemes. \item-Fix the known issue with ASN.1 CHOICE types where an error in one-of the choices will give an error message which indicates that no valid-choice was found. It would be better to report an error indicating the-problem in choice.-\item-Although support for-{\begin{tt}ANY DEFINED BY\end{tt}} has been improved, it and its replacement-in later versions of the ASN.1 standards need yet further improvement.-In particular, replace the index-number by a label and do not treat as equivalent to {\tt OPTIONAL} or-{\tt DEFAULT}.-\item Extend typechecking to ensure that only the appropriate key sizes are used for a given algorithm. \item-Although some -ASN.1 definitions have been put into more appropriate modules, more work-needs to be done, for example,-{\tt AlgorithmIdentifier}.-\item-Check lengths for correctness when decoding BER. See the Codec.ASN1.TLV-source for more on this.+Improve performance, for example, for SHA1. This +\htmladdnormallinkfoot+{code}+{http://www.abridgegame.org/repos/darcs-unstable}+runs an order of magnitude faster but, with respect to the authors, doesn't+feel that functional. \item-Improve the error messages when checking a BER encoding against its ASN.1-specification. Currently the messages say what has failed but does not-give the context.+Get rid of the GPL code. \end{itemize} \section{Contact} All questions, comments, bug reports, flames, requests for -updates / changes and suggestions should be directed to Dominic Steinitz.-+updates / changes and suggestions should be directed to Dominic Steinitz and+logged+\htmladdnormallinkfoot+{here}+{http://hackage.haskell.org/trac/crypto}+. \section{Licensing} The modules in the library come from different authors and have been @@ -551,42 +151,11 @@ \subsection{Contributors} -\subsubsection{Codec.ASN1}-\begin{tabular}{|p{6cm}|p{3cm}|p{3cm}|p{1cm}|}-\hline\hline-Codec.ASN1 & Dominic Steinitz & -Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline-Codec.ASN1.BER & Dominic Steinitz & -Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline-Codec.ASN1.PKCS8 & Dominic Steinitz & -Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline-Codec.ASN1.PKCS1v15 & Dominic Steinitz & -Copyright \copyright\ 2006, All rights reserved & BSD \\-\hline-Codec.ASN1.TLV & Dominic Steinitz & -Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline-Codec.ASN1.X509 & Dominic Steinitz & -Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline-Codec.ASN1.X509.Information\-Framework-& Dominic Steinitz &-Copyright \copyright\ 2006, All rights reserved & BSD \\-\hline-Codec.ASN1.X509.Attribute\-Certificate\-Definitions-& Dominic Steinitz &-Copyright \copyright\ 2006, All rights reserved & BSD \\-\hline\hline-\end{tabular}- \subsubsection{Codec.Binary} \begin{tabular}{|p{6cm}|p{3cm}|p{3cm}|p{1cm}|} \hline\hline-Codec.Binary.Base64 & Warrick Gray & -Copyright \copyright\ 2005, All rights reserved & BSD \\+Codec.Binary.BubbleBabble & John Meacham &+Copyright \copyright\ 2008, All rights reserved & BSD \\ \hline\hline \end{tabular} @@ -613,6 +182,9 @@ Codec.Encryption.BlowfishAux & Dominic Steinitz & Copyright \copyright\ 2005, All rights reserved & BSD \\ \hline+Codec.Encryption.TEA & John Meacham &+Copyright \copyright\ 2008, All rights reserved & BSD \\+\hline Codec.Encryption.DES & Ian Lynagh & Copyright \copyright\ 2005, All rights reserved & BSD \\ \hline@@ -658,9 +230,6 @@ \hline Data.Digest.SHA1 & Dominic Steinitz & Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline-Data.Digest.SHA1Aux & Ian Lynagh &-Copyright \copyright\ 2005, All rights reserved & BSD \\ \hline\hline \end{tabular} @@ -676,18 +245,10 @@ \subsubsection{Tests and Examples} \begin{tabular}{|p{6cm}|p{3cm}|p{3cm}|p{1cm}|} \hline\hline-BERTest-& Dominic Steinitz &-Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline RSATest & Dominic Steinitz & Copyright \copyright\ 2005, All rights reserved & BSD \\ \hline-X509Example-& Dominic Steinitz &-Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline QuickTest & Dominic Steinitz & Copyright \copyright\ 2005, All rights reserved & BSD \\@@ -695,22 +256,6 @@ SymmetricTest & Dominic Steinitz & Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline-PKCS8Example-& Dominic Steinitz &-Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline-RSAEncryptionExample-& Dominic Steinitz &-Copyright \copyright\ 2005, All rights reserved & BSD \\-\hline-AttributeCertificate-& Dominic Steinitz &-Copyright \copyright\ 2006, All rights reserved & BSD \\-\hline-RSAVerifyExample-& Dominic Steinitz &-Copyright \copyright\ 2006, All rights reserved & BSD \\ \hline\hline \end{tabular} @@ -796,6 +341,8 @@ \item Doug Hoyte (HardCore SoftWare) \item+Anatoly Zaretsky+\item \htmladdnormallinkfoot {Ian Lynagh} {http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh}@@ -813,9 +360,15 @@ \htmladdnormallinkfoot {Warrick Gray} {http://homepages.paradise.net.nz/warrickg/haskell/http/}+\item+\htmladdnormallinkfoot +{Russell O'Connor}+{http://r6.ca}+\item+Spencer Janssen \end{itemize} -This document was last updated on 1st April 2006.-\copyright\ 2006 Dominic Steinitz. +This document was last updated on 1st April 2007.+\copyright\ 2006--2007 Dominic Steinitz. \end{document}
+ SHA1Test.hs view
@@ -0,0 +1,35 @@+import Test.HUnit+import Codec.Text.Raw (hexdumpBy)+import Data.Digest.SHA1 (hash,Word160(Word160))+import Text.PrettyPrint+import Data.Char (ord)+import Codec.Utils (toOctets)++testCases =+ [ ("Hello" , "f7ff9e8b7bb2e09b70935a5d785e0cc5d9d0abf0")+ , ("haskell" , "f0234175f95a989496bf7f5ba03dea4dbc773e58")+ , ("Cryptography" , "b804ec5a0d83d19d8db908572f51196505d09f98")+ , ("Message Digest", "d52066b0fa1d68ef07eeab73031c3a3671298417")+ ]++testCases' =+ [ ([] , "da39a3ee5e6b4b0d3255bfef95601890afd80709")+ , ([0xa8] , "99f2aa95e36f95c2acb0eaf23998f030638f3f15")+ , (toOctets 256 0x7e3a4c325cb9c52b88387f93d01ae86d42098f5efa7f9457388b5e74b6d28b2438d42d8b64703324d4aa25ab6aad153ae30cd2b2af4d5e5c00a8a2d0220c6116, "a3054427cdb13f164a610b348702724c808a0dcc")+ , (toOctets 256 0xec29561244ede706b6eb30a1c371d74450a105c3f9735f7fa9fe38cf67f304a5736a106e92e17139a6813b1c81a4f3d3fb9546ab4296fa9f722826c066869edacd73b2548035185813e22634a9da44000d95a281ff9f264ecce0a931222162d021cca28db5f3c2aa24945ab1e31cb413ae29810fd794cad5dfaf29ec43cb38d198fe4ae1da2359780221405bd6712a5305da4b1b737fce7cd21c0eb7728d08235a9011, "970111c4e77bcc88cc20459c02b69b4aa8f58217")+ , (toOctets 256 0x4893f1c763625f2c6ce53aacf28026f14b3cd8687e1a1d3b60a81e80fcd1e2b038f9145ab64a0718f948f7c3c9ac92e3d86fb669a5257da1a18c776291653688338210a3242120f101788e8acc9110db9258b1554bf3d26602516ea93606a25a7f566c0c758fb39ecd9d876bc5d8abc1c3205095382c2474cb1f8bbdb45c2c0e659cb0fc703ec607a5de6bcc7a28687db1ee1c8f34797bb2441d5706d210df8c2d7d65dbded36414d063c117b52a51f7a4eb9cac0782e008b47459ed5acac0bc1f20121087f992ad985511b33c866d18e63f585478ee5a5e654b19d81231d98683ae3f0533565aba43dce408d7e3c4c6be11d8f05165f29c9dcb2030c4ee31d3a04e7421aa92c3231a1fc07e50e95fea7389a5e65891afaba51cf55e36a9d089bf293accb356d5d06547307d6e41456d4ed146a056179971c56521c83109bf922866186e184a99a96c7bb96df8937e35970e438412a2b8d744cf2ad87cb605d4232e976f9f15169776e4e5b6b786132c966b25fc56d815c56c819af5e159aa39f8a93d38115f5580cda93bc073c30b39920e726fe861b72483a3f886269ab7a8eefe952f35d25c4eb7f443f4f3f26e43d51fb54591e6a6dad25fcdf5142033084e5624bdd51435e77dea86b8, "dc5859dd5163c4354d5d577b855fa98e37f04384")+ , (toOctets 256 0xcf494c18a4e17bf03910631471bca5ba7edea8b9a63381e3463517961749848eb03abefd4ce676dece3740860255f57c261a558aa9c7f11432f549a9e4ce31d8e17c79450ce2ccfc148ad904aedfb138219d7052088520495355dadd90f72e6f69f9c6176d3d45f113f275b7fbc2a295784d41384cd7d629b23d1459a22e45fd5097ec9bf65fa965d3555ec77367903c32141065fc24da5c56963d46a2da3c279e4035fb2fb1c0025d9dda5b9e3443d457d92401a0d3f58b48469ecb1862dc975cdbe75ca099526db8b0329b03928206f084c633c04eef5e8e377f118d30edf592504be9d2802651ec78aeb02aea167a03fc3e23e5fc907c324f283f89ab37e84687a9c74ccf055402db95c29ba2c8d79b2bd4fa96459f8e3b78e07e923b81198267492196ecb71e01c331f8df245ec5bdf8d0e05c91e63bb299f0f6324895304dda721d39410458f117c87b7dd6a0ee734b79fcbe482b2c9e9aa0cef03a39d4b0c86de3bc34b4aadabfa373fd2258f7c40c187744d237080762382f547a36adb117839ca72f8ebbc5a20a07e86f4c8bb923f5787698d278f6db0040e76e54645bb0f97083995b34b9aa445fc424455058795828dd00c32471ec402a307f5aa1b37b1a86d6dae3bcbfbe9ba41cab0beeabf489af0073d4b3837d3f14b815120bc3602d072b5aeefcdec655fe756b660eba7dcf34675acbce317746270599424b9248791a0780449c1eabbb9459cc1e588bfd74df9b1b711c85c09d8aa171b309281947e8f4b6ac438753158f4f36fa, "4c17926feb6e87f5bca7890d8a5cde744f231dab")+ , (toOctets 256 0xe79701ff44ecfe5a7e97306a9c93791a2b4a6948e0aa06797f7cc8cbfbf1e82bdf7edbc7ecea19c604a62237475cc3487bca95b9b1d1c89025c91e0d67183ae0b8031b9ab7c4e4623ddcdee985aabfa0903d2d28c7677e09e312c2a80ad703733acdcb5feb9fe794f0e26b669fa5f6883149377c6c93b04e7fffba822d57ca4b2d85f2fed1a6abc5e75fd198dd74ef692896bd9fe57de7c6c137108517c017d059d2995eb1feb75ee8fc1966864032ac3bcdc6787d4eaad97363cc981239736a865dc769d3d293c5bc614ab7e43048b733965bef7b2e82ef5b2af4a264ea64817bce84067e48c8642b356c753d6db8f4d79883ec2644f6704335928d56fc747d01ccd81dfc88dda2fc208887da1e0ac9f17c4657c8b98ec4f12cad4030972bc6e0ffcc9793bb5ae6f9cca4d5036cc7a047e9ac18a7b4d2542db54ea33ae210c4e010675a8c09c89ae8decb47ff7f76e0a388be180b5e4b86c17b7c9ebc06abe0c8a7b24f2f99ad25920102c5187e9ff1cb01833d3edf80c373243f19fd2b8480626bb35ec39494efbfdb53379491cb3b87fb0370875ef9740d599ffc4677240e74057470922102603614c585bce28026a11f479a2d033fff55c1a52fdf1512f0c71cfd6be26981e0c1556097d896491adf1456a179f8d9ce1405589a102bd69023595439fc9498d726462d5530d8ab7f0b82396fb3624f4711ccc12621e2f954506483c028c9d0ad2e8e33a80bce30bdeb13f6ea236c2ad416bfe6b9596102a615e492eaad30afcaa1d57b76b3a05f3c486d97fc103bf1dce986d13c01d179ed3b82879dd5f2bf9647c50ba96e77c064e938238cc4fa2cc753c88a986159e6908be56cc3e637887ae804ed27857bdc9e981da38185cf64fc1c2d17b3c122d2f9cab54843292691dc4b3a29da40d33a501bc31ec59ce21fe50c5f82776953c58fc39c2405e6e862253910c5a8e6a863e43bd49c3f515ce8e9eb03d3cba01545ba3d4007f165a483be7a2dcb7bc121ddc0c0f526d7eb65447080c41096b090dce2ff49f9efed837d0dd63b423a1767324e72d0c275b424bde2944743c2dfeb116fd26003e7c7add67c15df33cd31a1e9f4190d7b01f2c2daa8ef377336764f6cc97e2d2bc13c491972fec3a51b57f88b1c7c545663ee672328593aa9dabce37659cb577b659280cb575a8fa00ed0949f2d644b5d84f03921cb9af8ec96fbd0b6858187fbbb11797692f1eb2d8de69cad8f999d974a3f635bf9791b4452793db5b66764b2ac035da18d8b7d5281df383ea9e3f00c9e250b5a1bc048b9f68053f9554697a81eae53d5aff0f019d00492d9e50aedc569e85aa4973529546a56390cc8e6c7e5fa5c849960e7ea8a639dcf06aad53bc991d177c3d7a1661c96431876790f9d7229531775083a13ac22f21a4d610d822000288a3f41cba71a639118bdce89c05692db35f10faf1587f54a9937707a6cd39c35bd9e3f7d9354b786606b311bda991c3e0696de0f9523c5ef744b40e49fe94f3f366a387dd2d47c6c1907098f9044b1c2b1ebdb213e897827d4113913c36aff901d2a94940da298896a1abeab8c5d38b15f796fafb5c0f83be112c3cf815f966e9b67ba8aecc4f5267c2bb83876ef985137c6027fa5d02b73c2d547df81cffb22d8a814271644798a77c25efdf5ffbbeb625cfd5bb4c2fb16a0e32b0c6ac216f4fb75093334290eff82681ac4b29788c607c3c6098a9d4f6ea2c2d91ee440cf2b2c560175ed7c9bcbc5a3535355bee72c4f81c751d0690ec1f1fcb7dd99520e1195d464b6ea44073769fe7273857dc063622067fd2e2e2258b4192f102effbbec5b769bbed2893c8b96feddeceadbfbb467280dd34bf5727b149fa8814e50be05a9c50c554e54210f732dfd862de08167861f239dd0c5e67139188af69f4bffa4a548204306ac9e0b29123a09f69438c4e98f102164a766844a0b3c38c9fa671177873f4fa1999bc6df35fd3cec000913b5ff3c28b0a2dafa6f01280f7565dc93480ad243c8230089be1face8b82bdc9b15f80f795cbe2a1cd281b5424b934773405a3fe52253b59cee57b1d5021d9aa52f01f1de0f033f3298134b9bf28c91fa86fef0fe5830a347966572cb71df29792ba24a1d717aff84ec3f52e01358a06d437e4b5511c2b0d2dfd25992ad78735f326382ff2b2a5359f48e32da55005e179e63bab4f612c584f025ccf15ff05f9f6ccd014ce51c23fbd8875451618bb23fc033a4e1ae27cba6f2e635b22f50d48000672fcc465658b0c1b31e0dde01832cd07971a5e20aa8800c9efb9bc49fbc4b16b97546f7e2d8c1d798f9d5756abb27f7ba88c83ac1465a67d48675c7e5fe49d84c3984a0c88d7641c04e72cecf41785d8053125d568b7c2a103e07df2a82bf6ca7e44ce80e5e1628b383ad9037fd672952394bf4d0612d7eda8b1bb57730f8fa53df6777be32ebb3f7024c63abd73c84b9a23aa638afb78bbbd577f0d3f03babd6919df6dff33b0b163117f132b73e953cf6a81c955d60783a84e43947aacfa6ba61b50d7a884f57987ad8dfd485b685639e5dfeef52716ee0002a38da46fd1486b9796396d96fc0034455d89929ec7bb60021f34f78319433b1119494ac0d1dc300afa13bcee26ee1f657828a8b28a0be85bca3bcb6ea13bd0061f67dc447e8f89d206e714ff288b9faa685ae94b21b0295f5b73ef4e2120653e1059e77f29eadfa94734144e53614b70a8a0e2ad1150a9995d7dd1a63ba94135a6afeab58666b7ed358b29504a279954b39b036cfb65ff765aaa211b332f1a995cca549bf69b891a4c4cd2a97f170fc30399ea1f22588192ad994bf1aa3a57b57d49c3a70cf1f9bd05f99ebe64e81548333e051838b0d65af0bbb0de23536f36b2aea64b3bf250420d21ec138df35050ace7c30c90f7745bbe920e3510f2e78987597b1d061543559c56492d7cc13778eb37c250eda4d20151bca2ab15a1571a55dac080ede339446df7448093ea413d689e7179813175e8648c1c8483d71485b8c3050b65e4a8aaec955c9175d6e3facf9c6f0b1e35e66d6180ea75fe1cc6482a72b7310082280582b0fff4950fb64d6ab20979f72a8a2cd35b8ad3d6ead2de259a658640542dc0dababd0e640d3eb1d46fdf4aae780793244c7c42c0b9d0b4247a7e7fa7d320795f4302638547c3a497366ef1c6b6b53cff044d372e023666b1c390819977b6ab8aca6e885b580bb22d961703b25f3986ade36c25816c7a6267e61a30b7ba46c3e7c15fe168a67d56f21f95f513e9fb1ccb9a57926d51133391629a016523574ee0b864f33fcb7effaf233a4a4ddf704bd279adf24448a766c8b98e78344b7ec910200c52333fa7389f519277c2b84fa05d01bde9a8cb9d58985b6619a78b13bef088c473056b7c8e5d1b2d12350cdfc6b5e335dcfd426b956ae8cf4a217abc9d0c631bea08d7756d62f0688e0735b70b876e7450c455a8b9dab2189e5482dfefce3f710bc02c18524b71e35fabcb4bfb4c2417c9907dcb124277e09a934c0423a08e626ccda1dbd961001c1ba54625227ea48ebbe413495b4c8a95a3702ebfd54dd07, "0eb8d69f6661b8124ddf76a635dc2821cbac32d7")+ ]++genTests' cases = + "SHA1" ~: map f cases+ where f (val, dgst) = dgst ~=? hexHash' val++hexHash' x = + let (Word160 a b c d e) = hash x in + render . (hexdumpBy "" 20) . concatMap (toOctets 256) $ [a,b,c,d,e]++main = runTestTT $ genTests' testCases'++
− X509Example.hs
@@ -1,120 +0,0 @@-module Main(main) where--import System.IO-import System.Environment-import Control.Monad.Error-import Data.Maybe-import Data.List-import Numeric-import NewBinary.Binary-import Codec.ASN1.BER-import Codec.ASN1-import Codec.ASN1.TLV-import Codec.ASN1.X509-import Codec.Utils-import Text.PrettyPrint-import Control.Monad.State--pp :: SignedCertificate -> RSAPublicKey -> String-pp sc rsapk = - render (- ppLabelString "Version" (show (version3 (certificate1 sc)))- $$- ppLabelString "Serial Number" (show (serialNumber (certificate1 sc)))- $$- ppLabelDoc "Algorithm Identifier" algid- $$- ppLabelDoc "Issuer" iss- $$- ppLabelDoc "Validity" valid- $$- ppLabelDoc "Subject" sub- $$- ppLabelDoc "Subject Public Key Info" kk- )- where- algid = - ppLabelString "Algorithm" - (show (algorithm1 (signature (certificate1 sc))))- $$- ppLabelString "Parameters"- (show (parameters1 (signature (certificate1 sc))))- iss = vcat (rdns issuer)- sub = vcat (rdns subject)- rdns select = (- (map (\x -> (text (show (fst x)) <> - space <> - text (unDirectoryString (snd x))))) .- (map (\x -> (type1 (head x),value (head x)))) .- (map unSetOf) .- (map unRelativeDistinguishedName) .- unName .- select .- certificate1- ) sc- valid = - ppLabelString "NotBefore" nb- $$- ppLabelString "NotAfter" na- nb = unVisibleString (unTime (notBefore (validity1 (certificate1 sc))))- na = unVisibleString (unTime (notAfter (validity1 (certificate1 sc))))- ki = subjectPublicKeyInfo2 (certificate1 sc)- al = algorithm2 ki- kj = subjectPublicKeyInfo1 ki- algid1 = - ppLabelString "Algorithm" (show (algorithm1 al))- $$- ppLabelString "Parameters" (show (parameters1 al))- kk = ppLabelDoc "Algorithm" algid1- $$- ppLabelDoc "Subject Public Key Info" spki- spki = mod $$ exp- exp = ppLabelString "Exponent" (show (publicExponent1 rsapk))- bar = map (map sh) (split 16 (toOctets 256 (modulus1 rsapk)))- sh x | x < 16 = showHex x "0"- | otherwise = showHex x ""- split :: Int -> [a] -> [[a]]- split n xs = unfoldr (g n) xs- g :: Int -> [a] -> Maybe ([a],[a])- g n y - | length y == 0 = Nothing- | otherwise = Just (splitAt n y)- mods1 :: [[Doc]]- mods1 = map (intersperse colon) (map (map text) bar)- mods2 :: [Doc]- mods2 = map hcat mods1- mod = ppLabelDoc "Modulus" (vcat mods2)--ppLabelString :: String -> String -> Doc-ppLabelString l x = - text l <> colon <> space <> (text x)--ppLabelDoc :: String -> Doc -> Doc-ppLabelDoc l d = - text l <> colon- $$- nest 3 d--test fileName = - do h <- openFile fileName ReadMode- bin <- openBinIO_ h- (l,x) <- tlvIO bin- (w,y) <- typeCheck signedCertificate x- let (_ ::= c) = w- let d = (decode c (Just y))::(Maybe SignedCertificate)- let d1 = certificate1 (fromJust d)- let d2 = subjectPublicKeyInfo2 d1- let d3 = subjectPublicKeyInfo1 d2- let (BitString e) = d3- let (l',x') = tlv e- (w',y') <- typeCheck rsaPublicKey x'- let (_ ::= r) = w'- let s = (decode r (Just y'))::(Maybe RSAPublicKey)- putStrLn (pp (fromJust d) (fromJust s))--main = - do progName <- getProgName- args <- getArgs- if length args /= 1- then putStrLn ("Usage: " ++ progName ++ " <fileName>")- else test (args!!0)