diff --git a/AttributeCertificate.hs b/AttributeCertificate.hs deleted file mode 100644 --- a/AttributeCertificate.hs +++ /dev/null @@ -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 ++ " ") - else test1 (args!!0) diff --git a/BERTest.hs b/BERTest.hs deleted file mode 100644 --- a/BERTest.hs +++ /dev/null @@ -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 --} diff --git a/Codec/ASN1.hs b/Codec/ASN1.hs deleted file mode 100644 --- a/Codec/ASN1.hs +++ /dev/null @@ -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) - ] diff --git a/Codec/ASN1/BER.hs b/Codec/ASN1/BER.hs deleted file mode 100644 --- a/Codec/ASN1/BER.hs +++ /dev/null @@ -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 diff --git a/Codec/ASN1/InformationFramework.hs b/Codec/ASN1/InformationFramework.hs deleted file mode 100644 --- a/Codec/ASN1/InformationFramework.hs +++ /dev/null @@ -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 --- ------------------------------------------------------------------------------ - -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) - diff --git a/Codec/ASN1/PKCS1v15.hs b/Codec/ASN1/PKCS1v15.hs deleted file mode 100644 --- a/Codec/ASN1/PKCS1v15.hs +++ /dev/null @@ -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 --- ( and --- ) 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 diff --git a/Codec/ASN1/PKCS8.hs b/Codec/ASN1/PKCS8.hs deleted file mode 100644 --- a/Codec/ASN1/PKCS8.hs +++ /dev/null @@ -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 . --- ------------------------------------------------------------------------------ - -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. --} - --} diff --git a/Codec/ASN1/TLV.hs b/Codec/ASN1/TLV.hs deleted file mode 100644 --- a/Codec/ASN1/TLV.hs +++ /dev/null @@ -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) diff --git a/Codec/ASN1/X509.hs b/Codec/ASN1/X509.hs deleted file mode 100644 --- a/Codec/ASN1/X509.hs +++ /dev/null @@ -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 - } - diff --git a/Codec/ASN1/X509/AttributeCertificateDefinitions.hs b/Codec/ASN1/X509/AttributeCertificateDefinitions.hs deleted file mode 100644 --- a/Codec/ASN1/X509/AttributeCertificateDefinitions.hs +++ /dev/null @@ -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 --- ------------------------------------------------------------------------------ - -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) - diff --git a/Codec/Binary/Base64.hs b/Codec/Binary/Base64.hs deleted file mode 100644 --- a/Codec/Binary/Base64.hs +++ /dev/null @@ -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 --- and . --- ------------------------------------------------------------------------------ - -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 diff --git a/Codec/Binary/BubbleBabble.hs b/Codec/Binary/BubbleBabble.hs new file mode 100644 --- /dev/null +++ b/Codec/Binary/BubbleBabble.hs @@ -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 + diff --git a/Codec/Encryption/TEA.hs b/Codec/Encryption/TEA.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/TEA.hs @@ -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; +} + +-} diff --git a/Codec/Text/Raw.hs b/Codec/Text/Raw.hs --- a/Codec/Text/Raw.hs +++ b/Codec/Text/Raw.hs @@ -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 diff --git a/Crypto.cabal b/Crypto.cabal --- a/Crypto.cabal +++ b/Crypto.cabal @@ -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 diff --git a/Data/Digest/SHA1.hs b/Data/Digest/SHA1.hs --- a/Data/Digest/SHA1.hs +++ b/Data/Digest/SHA1.hs @@ -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 --- and . +-- Take [Word8] and return Word160. +-- See 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 diff --git a/Data/Digest/SHA1Aux.hs b/Data/Digest/SHA1Aux.hs deleted file mode 100644 --- a/Data/Digest/SHA1Aux.hs +++ /dev/null @@ -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) - diff --git a/Data/Digest/SHA2.hs b/Data/Digest/SHA2.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/SHA2.hs @@ -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 +-- . +-- +----------------------------------------------------------------------------- + +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 diff --git a/Data/Digest/SHA224.hs b/Data/Digest/SHA224.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/SHA224.hs @@ -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 . +-- +----------------------------------------------------------------------------- + +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 diff --git a/Data/Digest/SHA256.hs b/Data/Digest/SHA256.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/SHA256.hs @@ -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 . +-- +----------------------------------------------------------------------------- + +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 diff --git a/Data/Digest/SHA384.hs b/Data/Digest/SHA384.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/SHA384.hs @@ -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 . +-- +----------------------------------------------------------------------------- + +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 diff --git a/Data/Digest/SHA512.hs b/Data/Digest/SHA512.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/SHA512.hs @@ -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 . +-- +----------------------------------------------------------------------------- + +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 diff --git a/Data/HMAC.hs b/Data/HMAC.hs new file mode 100644 --- /dev/null +++ b/Data/HMAC.hs @@ -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 +-- . +-- +----------------------------------------------------------------------------- + +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)) diff --git a/Data/LargeWord.hs b/Data/LargeWord.hs --- a/Data/LargeWord.hs +++ b/Data/LargeWord.hs @@ -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. diff --git a/HMACTest.hs b/HMACTest.hs new file mode 100644 --- /dev/null +++ b/HMACTest.hs @@ -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 +-- + +-- HMAC-MD5 tests from +-- + +-- 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 + diff --git a/PKCS8Example.hs b/PKCS8Example.hs deleted file mode 100644 --- a/PKCS8Example.hs +++ /dev/null @@ -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 ++ " ") - else test (args!!0) diff --git a/QuickTest.hs b/QuickTest.hs --- a/QuickTest.hs +++ b/QuickTest.hs @@ -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 diff --git a/RSAEncryptionExample.hs b/RSAEncryptionExample.hs deleted file mode 100644 --- a/RSAEncryptionExample.hs +++ /dev/null @@ -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..." diff --git a/RSATest.hs b/RSATest.hs --- a/RSATest.hs +++ b/RSATest.hs @@ -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 ( diff --git a/RSAVerifyExample.hs b/RSAVerifyExample.hs deleted file mode 100644 --- a/RSAVerifyExample.hs +++ /dev/null @@ -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..." diff --git a/ReadMe.tex b/ReadMe.tex --- a/ReadMe.tex +++ b/ReadMe.tex @@ -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} diff --git a/SHA1Test.hs b/SHA1Test.hs new file mode 100644 --- /dev/null +++ b/SHA1Test.hs @@ -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' + + diff --git a/X509Example.hs b/X509Example.hs deleted file mode 100644 --- a/X509Example.hs +++ /dev/null @@ -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 ++ " ") - else test (args!!0)