diff --git a/AttributeCertificate.hs b/AttributeCertificate.hs new file mode 100644 --- /dev/null +++ b/AttributeCertificate.hs @@ -0,0 +1,174 @@ +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 new file mode 100644 --- /dev/null +++ b/BERTest.hs @@ -0,0 +1,1214 @@ +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 new file mode 100644 --- /dev/null +++ b/Codec/ASN1.hs @@ -0,0 +1,329 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Codec/ASN1/BER.hs @@ -0,0 +1,556 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Codec/ASN1/InformationFramework.hs @@ -0,0 +1,155 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Codec/ASN1/PKCS1v15.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Codec/ASN1/PKCS8.hs @@ -0,0 +1,265 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Codec/ASN1/TLV.hs @@ -0,0 +1,185 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Codec/ASN1/X509.hs @@ -0,0 +1,465 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Codec/ASN1/X509/AttributeCertificateDefinitions.hs @@ -0,0 +1,483 @@ +----------------------------------------------------------------------------- +-- | +-- 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 new file mode 100644 --- /dev/null +++ b/Codec/Binary/Base64.hs @@ -0,0 +1,282 @@ +----------------------------------------------------------------------------- +-- | +-- 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/Encryption/AES.hs b/Codec/Encryption/AES.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/AES.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.AES +-- Copyright : (c) Dominic Steinitz 2004 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Takes the AES module supplied by Lukasz Anforowicz and wraps it so it can +-- used with the standard modes. +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.AES ( + -- * Function Types + encrypt, decrypt) where + +import Codec.Encryption.AESAux +import Data.LargeWord +import Codec.Utils +import Data.Word +import Data.Bits + +class (Bits a, Integral a) => AESKey a + +instance AESKey Word128 +instance AESKey Word192 +instance AESKey Word256 + +-- | Basic AES encryption which takes a key and a block of plaintext +-- and returns the encrypted block of ciphertext according to the standard. + +encrypt :: AESKey a => a -> Word128 -> Word128 +encrypt k p = + case bitSize k of + 128 -> f aes128Encrypt k p + 192 -> f aes192Encrypt k p + 256 -> f aes256Encrypt k p + +f g k p = + fromIntegral $ fromOctets 256 $ + g (i2osp (bitSize k `div` bitSize (0::Octet)) $ fromIntegral k) + (i2osp (bitSize p `div` bitSize (0::Octet)) $ fromIntegral p) + +-- | Basic AES decryption which takes a key and a block of ciphertext and +-- returns the decrypted block of plaintext according to the standard. + +decrypt :: AESKey a => a -> Word128 -> Word128 +decrypt k p = + case bitSize k of + 128 -> f aes128Decrypt k p + 192 -> f aes192Decrypt k p + 256 -> f aes256Decrypt k p + diff --git a/Codec/Encryption/AESAux.hs b/Codec/Encryption/AESAux.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/AESAux.hs @@ -0,0 +1,1008 @@ +-- | Advanced Encryption System (specification can be found in FIPS-197) +module Codec.Encryption.AESAux( + aes128Encrypt, + aes192Encrypt, + aes256Encrypt, + aes128Decrypt, + aes192Decrypt, + aes256Decrypt, +) where + +import Data.Bits +import Data.Int(Int) +import Data.Word(Word32) + +import Codec.Utils(Octet) + +aes128Encrypt :: [Octet] -- ^ key (16 octets) + -> [Octet] -- ^ msg (16 octets) + -> [Octet] -- ^ enciphered msg (16 octets) +aes128Encrypt = aesEncrypt 10 4 + +aes192Encrypt :: [Octet] -- ^ key (24 octets) + -> [Octet] -- ^ msg (16 octets) + -> [Octet] -- ^ enciphered msg (16 octets) +aes192Encrypt = aesEncrypt 12 6 + +aes256Encrypt :: [Octet] -- ^ key (32 octets) + -> [Octet] -- ^ msg (16 octets) + -> [Octet] -- ^ enciphered msg (16 octets) +aes256Encrypt = aesEncrypt 14 8 + +aes128Decrypt :: [Octet] -- ^ key (16 octets) + -> [Octet] -- ^ enciphered msg (16 octets) + -> [Octet] -- ^ deciphered msg (16 octets) +aes128Decrypt = aesDecrypt 10 4 + +aes192Decrypt :: [Octet] -- ^ key (24 octets) + -> [Octet] -- ^ enciphered msg (16 octets) + -> [Octet] -- ^ deciphered msg (16 octets) +aes192Decrypt = aesDecrypt 12 6 + +aes256Decrypt :: [Octet] -- ^ key (32 octets) + -> [Octet] -- ^ enciphered msg (16 octets) + -> [Octet] -- ^ deciphered msg (16 octets) +aes256Decrypt = aesDecrypt 14 8 + +aesEncrypt :: Int -- ^ nr + -> Int -- ^ nk + -> [Octet] -- ^ key + -> [Octet] -- ^ msg + -> [Octet] -- ^ enciphered msg +aesEncrypt nr nk key + [i00, i10, i20, i30, + i01, i11, i21, i31, + i02, i12, i22, i32, + i03, i13, i23, i33] = + [fo o00, fo o10, fo o20, fo o30, + fo o01, fo o11, fo o21, fo o31, + fo o02, fo o12, fo o22, fo o32, + fo o03, fo o13, fo o23, fo o33] + where State (o00, o01, o02, o03) + (o10, o11, o12, o13) + (o20, o21, o22, o23) + (o30, o31, o32, o33) = transform ( + State(fi i00, fi i01, fi i02, fi i03) + (fi i10, fi i11, fi i12, fi i13) + (fi i20, fi i21, fi i22, fi i23) + (fi i30, fi i31, fi i32, fi i33)) + fi = (fromIntegral :: Octet -> Word32) + fo = (fromIntegral :: Word32 -> Octet) + (kt0:kts) = genAddRoundKey (generateKeys nr nk key) + transform = foldr (.) kt0 (reverse rest) + mss = replicate (nr - 1) (mixColumns . shiftRows . subBytes) + rest = zipWith (.) kts (mss ++ [shiftRows . subBytes ]) + + +aesDecrypt :: Int -- ^ nr + -> Int -- ^ nk + -> [Octet] -- ^ key + -> [Octet] -- ^ enciphered msg + -> [Octet] -- ^ deciphered msg +aesDecrypt nr nk key + [i00, i10, i20, i30, + i01, i11, i21, i31, + i02, i12, i22, i32, + i03, i13, i23, i33] = + [fo o00, fo o10, fo o20, fo o30, + fo o01, fo o11, fo o21, fo o31, + fo o02, fo o12, fo o22, fo o32, + fo o03, fo o13, fo o23, fo o33] + where State (o00, o01, o02, o03) + (o10, o11, o12, o13) + (o20, o21, o22, o23) + (o30, o31, o32, o33) = transform ( + State(fi i00, fi i01, fi i02, fi i03) + (fi i10, fi i11, fi i12, fi i13) + (fi i20, fi i21, fi i22, fi i23) + (fi i30, fi i31, fi i32, fi i33)) + fi = (fromIntegral :: Octet -> Word32) + fo = (fromIntegral :: Word32 -> Octet) + (kt0:kts) = reverse (genAddRoundKey (generateKeys nr nk key)) + transform = foldr (.) kt0 (reverse rest) + ssm = replicate (nr - 1) + (subBytesRev . shiftRowsRev . mixColumnsRev) + rest = zipWith (.) kts ([subBytesRev . shiftRowsRev] ++ ssm) + + + +data State = State !(Word32, Word32, Word32, Word32) + !(Word32, Word32, Word32, Word32) + !(Word32, Word32, Word32, Word32) + !(Word32, Word32, Word32, Word32) + +sbox :: Word32 -> Word32 +sboxRev :: Word32 -> Word32 + +sbox 0x00 = 0x63 +sbox 0x01 = 0x7C +sbox 0x02 = 0x77 +sbox 0x03 = 0x7B +sbox 0x04 = 0xF2 +sbox 0x05 = 0x6B +sbox 0x06 = 0x6F +sbox 0x07 = 0xC5 + +sbox 0x08 = 0x30 +sbox 0x09 = 0x01 +sbox 0x0a = 0x67 +sbox 0x0b = 0x2B +sbox 0x0c = 0xFE +sbox 0x0d = 0xD7 +sbox 0x0e = 0xAB +sbox 0x0f = 0x76 + +sbox 0x10 = 0xCA +sbox 0x11 = 0x82 +sbox 0x12 = 0xC9 +sbox 0x13 = 0x7D +sbox 0x14 = 0xFA +sbox 0x15 = 0x59 +sbox 0x16 = 0x47 +sbox 0x17 = 0xF0 + +sbox 0x18 = 0xAD +sbox 0x19 = 0xD4 +sbox 0x1a = 0xA2 +sbox 0x1b = 0xAF +sbox 0x1c = 0x9C +sbox 0x1d = 0xA4 +sbox 0x1e = 0x72 +sbox 0x1f = 0xC0 + +sbox 0x20 = 0xB7 +sbox 0x21 = 0xFD +sbox 0x22 = 0x93 +sbox 0x23 = 0x26 +sbox 0x24 = 0x36 +sbox 0x25 = 0x3F +sbox 0x26 = 0xF7 +sbox 0x27 = 0xCC + +sbox 0x28 = 0x34 +sbox 0x29 = 0xA5 +sbox 0x2a = 0xE5 +sbox 0x2b = 0xF1 +sbox 0x2c = 0x71 +sbox 0x2d = 0xD8 +sbox 0x2e = 0x31 +sbox 0x2f = 0x15 + +sbox 0x30 = 0x04 +sbox 0x31 = 0xC7 +sbox 0x32 = 0x23 +sbox 0x33 = 0xC3 +sbox 0x34 = 0x18 +sbox 0x35 = 0x96 +sbox 0x36 = 0x05 +sbox 0x37 = 0x9A + +sbox 0x38 = 0x07 +sbox 0x39 = 0x12 +sbox 0x3a = 0x80 +sbox 0x3b = 0xE2 +sbox 0x3c = 0xEB +sbox 0x3d = 0x27 +sbox 0x3e = 0xB2 +sbox 0x3f = 0x75 + +sbox 0x40 = 0x09 +sbox 0x41 = 0x83 +sbox 0x42 = 0x2C +sbox 0x43 = 0x1A +sbox 0x44 = 0x1B +sbox 0x45 = 0x6E +sbox 0x46 = 0x5A +sbox 0x47 = 0xA0 + +sbox 0x48 = 0x52 +sbox 0x49 = 0x3B +sbox 0x4a = 0xD6 +sbox 0x4b = 0xB3 +sbox 0x4c = 0x29 +sbox 0x4d = 0xE3 +sbox 0x4e = 0x2F +sbox 0x4f = 0x84 + +sbox 0x50 = 0x53 +sbox 0x51 = 0xD1 +sbox 0x52 = 0x00 +sbox 0x53 = 0xED +sbox 0x54 = 0x20 +sbox 0x55 = 0xFC +sbox 0x56 = 0xB1 +sbox 0x57 = 0x5B + +sbox 0x58 = 0x6A +sbox 0x59 = 0xCB +sbox 0x5a = 0xBE +sbox 0x5b = 0x39 +sbox 0x5c = 0x4A +sbox 0x5d = 0x4C +sbox 0x5e = 0x58 +sbox 0x5f = 0xCF + +sbox 0x60 = 0xD0 +sbox 0x61 = 0xEF +sbox 0x62 = 0xAA +sbox 0x63 = 0xFB +sbox 0x64 = 0x43 +sbox 0x65 = 0x4D +sbox 0x66 = 0x33 +sbox 0x67 = 0x85 + +sbox 0x68 = 0x45 +sbox 0x69 = 0xF9 +sbox 0x6a = 0x02 +sbox 0x6b = 0x7F +sbox 0x6c = 0x50 +sbox 0x6d = 0x3C +sbox 0x6e = 0x9F +sbox 0x6f = 0xA8 + +sbox 0x70 = 0x51 +sbox 0x71 = 0xA3 +sbox 0x72 = 0x40 +sbox 0x73 = 0x8F +sbox 0x74 = 0x92 +sbox 0x75 = 0x9D +sbox 0x76 = 0x38 +sbox 0x77 = 0xF5 + +sbox 0x78 = 0xBC +sbox 0x79 = 0xB6 +sbox 0x7a = 0xDA +sbox 0x7b = 0x21 +sbox 0x7c = 0x10 +sbox 0x7d = 0xFF +sbox 0x7e = 0xF3 +sbox 0x7f = 0xD2 + +sbox 0x80 = 0xCD +sbox 0x81 = 0x0C +sbox 0x82 = 0x13 +sbox 0x83 = 0xEC +sbox 0x84 = 0x5F +sbox 0x85 = 0x97 +sbox 0x86 = 0x44 +sbox 0x87 = 0x17 + +sbox 0x88 = 0xC4 +sbox 0x89 = 0xA7 +sbox 0x8a = 0x7E +sbox 0x8b = 0x3D +sbox 0x8c = 0x64 +sbox 0x8d = 0x5D +sbox 0x8e = 0x19 +sbox 0x8f = 0x73 + +sbox 0x90 = 0x60 +sbox 0x91 = 0x81 +sbox 0x92 = 0x4F +sbox 0x93 = 0xDC +sbox 0x94 = 0x22 +sbox 0x95 = 0x2A +sbox 0x96 = 0x90 +sbox 0x97 = 0x88 + +sbox 0x98 = 0x46 +sbox 0x99 = 0xEE +sbox 0x9a = 0xB8 +sbox 0x9b = 0x14 +sbox 0x9c = 0xDE +sbox 0x9d = 0x5E +sbox 0x9e = 0x0B +sbox 0x9f = 0xDB + +sbox 0xa0 = 0xE0 +sbox 0xa1 = 0x32 +sbox 0xa2 = 0x3A +sbox 0xa3 = 0x0A +sbox 0xa4 = 0x49 +sbox 0xa5 = 0x06 +sbox 0xa6 = 0x24 +sbox 0xa7 = 0x5C + +sbox 0xa8 = 0xC2 +sbox 0xa9 = 0xD3 +sbox 0xaa = 0xAC +sbox 0xab = 0x62 +sbox 0xac = 0x91 +sbox 0xad = 0x95 +sbox 0xae = 0xE4 +sbox 0xaf = 0x79 + +sbox 0xb0 = 0xE7 +sbox 0xb1 = 0xC8 +sbox 0xb2 = 0x37 +sbox 0xb3 = 0x6D +sbox 0xb4 = 0x8D +sbox 0xb5 = 0xD5 +sbox 0xb6 = 0x4E +sbox 0xb7 = 0xA9 + +sbox 0xb8 = 0x6C +sbox 0xb9 = 0x56 +sbox 0xba = 0xF4 +sbox 0xbb = 0xEA +sbox 0xbc = 0x65 +sbox 0xbd = 0x7A +sbox 0xbe = 0xAE +sbox 0xbf = 0x08 + +sbox 0xc0 = 0xBA +sbox 0xc1 = 0x78 +sbox 0xc2 = 0x25 +sbox 0xc3 = 0x2E +sbox 0xc4 = 0x1C +sbox 0xc5 = 0xA6 +sbox 0xc6 = 0xB4 +sbox 0xc7 = 0xC6 + +sbox 0xc8 = 0xE8 +sbox 0xc9 = 0xDD +sbox 0xca = 0x74 +sbox 0xcb = 0x1F +sbox 0xcc = 0x4B +sbox 0xcd = 0xBD +sbox 0xce = 0x8B +sbox 0xcf = 0x8A + +sbox 0xd0 = 0x70 +sbox 0xd1 = 0x3E +sbox 0xd2 = 0xB5 +sbox 0xd3 = 0x66 +sbox 0xd4 = 0x48 +sbox 0xd5 = 0x03 +sbox 0xd6 = 0xF6 +sbox 0xd7 = 0x0E + +sbox 0xd8 = 0x61 +sbox 0xd9 = 0x35 +sbox 0xda = 0x57 +sbox 0xdb = 0xB9 +sbox 0xdc = 0x86 +sbox 0xdd = 0xC1 +sbox 0xde = 0x1D +sbox 0xdf = 0x9E + +sbox 0xe0 = 0xE1 +sbox 0xe1 = 0xF8 +sbox 0xe2 = 0x98 +sbox 0xe3 = 0x11 +sbox 0xe4 = 0x69 +sbox 0xe5 = 0xD9 +sbox 0xe6 = 0x8E +sbox 0xe7 = 0x94 + +sbox 0xe8 = 0x9B +sbox 0xe9 = 0x1E +sbox 0xea = 0x87 +sbox 0xeb = 0xE9 +sbox 0xec = 0xCE +sbox 0xed = 0x55 +sbox 0xee = 0x28 +sbox 0xef = 0xDF + +sbox 0xf0 = 0x8C +sbox 0xf1 = 0xA1 +sbox 0xf2 = 0x89 +sbox 0xf3 = 0x0D +sbox 0xf4 = 0xBF +sbox 0xf5 = 0xE6 +sbox 0xf6 = 0x42 +sbox 0xf7 = 0x68 + +sbox 0xf8 = 0x41 +sbox 0xf9 = 0x99 +sbox 0xfa = 0x2D +sbox 0xfb = 0x0F +sbox 0xfc = 0xB0 +sbox 0xfd = 0x54 +sbox 0xfe = 0xBB +sbox 0xff = 0x16 + +{----} + +sboxRev 0x63 = 0x00 +sboxRev 0x7C = 0x01 +sboxRev 0x77 = 0x02 +sboxRev 0x7B = 0x03 +sboxRev 0xF2 = 0x04 +sboxRev 0x6B = 0x05 +sboxRev 0x6F = 0x06 +sboxRev 0xC5 = 0x07 + +sboxRev 0x30 = 0x08 +sboxRev 0x01 = 0x09 +sboxRev 0x67 = 0x0a +sboxRev 0x2B = 0x0b +sboxRev 0xFE = 0x0c +sboxRev 0xD7 = 0x0d +sboxRev 0xAB = 0x0e +sboxRev 0x76 = 0x0f + +sboxRev 0xCA = 0x10 +sboxRev 0x82 = 0x11 +sboxRev 0xC9 = 0x12 +sboxRev 0x7D = 0x13 +sboxRev 0xFA = 0x14 +sboxRev 0x59 = 0x15 +sboxRev 0x47 = 0x16 +sboxRev 0xF0 = 0x17 + +sboxRev 0xAD = 0x18 +sboxRev 0xD4 = 0x19 +sboxRev 0xA2 = 0x1a +sboxRev 0xAF = 0x1b +sboxRev 0x9C = 0x1c +sboxRev 0xA4 = 0x1d +sboxRev 0x72 = 0x1e +sboxRev 0xC0 = 0x1f + +sboxRev 0xB7 = 0x20 +sboxRev 0xFD = 0x21 +sboxRev 0x93 = 0x22 +sboxRev 0x26 = 0x23 +sboxRev 0x36 = 0x24 +sboxRev 0x3F = 0x25 +sboxRev 0xF7 = 0x26 +sboxRev 0xCC = 0x27 + +sboxRev 0x34 = 0x28 +sboxRev 0xA5 = 0x29 +sboxRev 0xE5 = 0x2a +sboxRev 0xF1 = 0x2b +sboxRev 0x71 = 0x2c +sboxRev 0xD8 = 0x2d +sboxRev 0x31 = 0x2e +sboxRev 0x15 = 0x2f + +sboxRev 0x04 = 0x30 +sboxRev 0xC7 = 0x31 +sboxRev 0x23 = 0x32 +sboxRev 0xC3 = 0x33 +sboxRev 0x18 = 0x34 +sboxRev 0x96 = 0x35 +sboxRev 0x05 = 0x36 +sboxRev 0x9A = 0x37 + +sboxRev 0x07 = 0x38 +sboxRev 0x12 = 0x39 +sboxRev 0x80 = 0x3a +sboxRev 0xE2 = 0x3b +sboxRev 0xEB = 0x3c +sboxRev 0x27 = 0x3d +sboxRev 0xB2 = 0x3e +sboxRev 0x75 = 0x3f + +sboxRev 0x09 = 0x40 +sboxRev 0x83 = 0x41 +sboxRev 0x2C = 0x42 +sboxRev 0x1A = 0x43 +sboxRev 0x1B = 0x44 +sboxRev 0x6E = 0x45 +sboxRev 0x5A = 0x46 +sboxRev 0xA0 = 0x47 + +sboxRev 0x52 = 0x48 +sboxRev 0x3B = 0x49 +sboxRev 0xD6 = 0x4a +sboxRev 0xB3 = 0x4b +sboxRev 0x29 = 0x4c +sboxRev 0xE3 = 0x4d +sboxRev 0x2F = 0x4e +sboxRev 0x84 = 0x4f + +sboxRev 0x53 = 0x50 +sboxRev 0xD1 = 0x51 +sboxRev 0x00 = 0x52 +sboxRev 0xED = 0x53 +sboxRev 0x20 = 0x54 +sboxRev 0xFC = 0x55 +sboxRev 0xB1 = 0x56 +sboxRev 0x5B = 0x57 + +sboxRev 0x6A = 0x58 +sboxRev 0xCB = 0x59 +sboxRev 0xBE = 0x5a +sboxRev 0x39 = 0x5b +sboxRev 0x4A = 0x5c +sboxRev 0x4C = 0x5d +sboxRev 0x58 = 0x5e +sboxRev 0xCF = 0x5f + +sboxRev 0xD0 = 0x60 +sboxRev 0xEF = 0x61 +sboxRev 0xAA = 0x62 +sboxRev 0xFB = 0x63 +sboxRev 0x43 = 0x64 +sboxRev 0x4D = 0x65 +sboxRev 0x33 = 0x66 +sboxRev 0x85 = 0x67 + +sboxRev 0x45 = 0x68 +sboxRev 0xF9 = 0x69 +sboxRev 0x02 = 0x6a +sboxRev 0x7F = 0x6b +sboxRev 0x50 = 0x6c +sboxRev 0x3C = 0x6d +sboxRev 0x9F = 0x6e +sboxRev 0xA8 = 0x6f + +sboxRev 0x51 = 0x70 +sboxRev 0xA3 = 0x71 +sboxRev 0x40 = 0x72 +sboxRev 0x8F = 0x73 +sboxRev 0x92 = 0x74 +sboxRev 0x9D = 0x75 +sboxRev 0x38 = 0x76 +sboxRev 0xF5 = 0x77 + +sboxRev 0xBC = 0x78 +sboxRev 0xB6 = 0x79 +sboxRev 0xDA = 0x7a +sboxRev 0x21 = 0x7b +sboxRev 0x10 = 0x7c +sboxRev 0xFF = 0x7d +sboxRev 0xF3 = 0x7e +sboxRev 0xD2 = 0x7f + +sboxRev 0xCD = 0x80 +sboxRev 0x0C = 0x81 +sboxRev 0x13 = 0x82 +sboxRev 0xEC = 0x83 +sboxRev 0x5F = 0x84 +sboxRev 0x97 = 0x85 +sboxRev 0x44 = 0x86 +sboxRev 0x17 = 0x87 + +sboxRev 0xC4 = 0x88 +sboxRev 0xA7 = 0x89 +sboxRev 0x7E = 0x8a +sboxRev 0x3D = 0x8b +sboxRev 0x64 = 0x8c +sboxRev 0x5D = 0x8d +sboxRev 0x19 = 0x8e +sboxRev 0x73 = 0x8f + +sboxRev 0x60 = 0x90 +sboxRev 0x81 = 0x91 +sboxRev 0x4F = 0x92 +sboxRev 0xDC = 0x93 +sboxRev 0x22 = 0x94 +sboxRev 0x2A = 0x95 +sboxRev 0x90 = 0x96 +sboxRev 0x88 = 0x97 + +sboxRev 0x46 = 0x98 +sboxRev 0xEE = 0x99 +sboxRev 0xB8 = 0x9a +sboxRev 0x14 = 0x9b +sboxRev 0xDE = 0x9c +sboxRev 0x5E = 0x9d +sboxRev 0x0B = 0x9e +sboxRev 0xDB = 0x9f + +sboxRev 0xE0 = 0xa0 +sboxRev 0x32 = 0xa1 +sboxRev 0x3A = 0xa2 +sboxRev 0x0A = 0xa3 +sboxRev 0x49 = 0xa4 +sboxRev 0x06 = 0xa5 +sboxRev 0x24 = 0xa6 +sboxRev 0x5C = 0xa7 + +sboxRev 0xC2 = 0xa8 +sboxRev 0xD3 = 0xa9 +sboxRev 0xAC = 0xaa +sboxRev 0x62 = 0xab +sboxRev 0x91 = 0xac +sboxRev 0x95 = 0xad +sboxRev 0xE4 = 0xae +sboxRev 0x79 = 0xaf + +sboxRev 0xE7 = 0xb0 +sboxRev 0xC8 = 0xb1 +sboxRev 0x37 = 0xb2 +sboxRev 0x6D = 0xb3 +sboxRev 0x8D = 0xb4 +sboxRev 0xD5 = 0xb5 +sboxRev 0x4E = 0xb6 +sboxRev 0xA9 = 0xb7 + +sboxRev 0x6C = 0xb8 +sboxRev 0x56 = 0xb9 +sboxRev 0xF4 = 0xba +sboxRev 0xEA = 0xbb +sboxRev 0x65 = 0xbc +sboxRev 0x7A = 0xbd +sboxRev 0xAE = 0xbe +sboxRev 0x08 = 0xbf + +sboxRev 0xBA = 0xc0 +sboxRev 0x78 = 0xc1 +sboxRev 0x25 = 0xc2 +sboxRev 0x2E = 0xc3 +sboxRev 0x1C = 0xc4 +sboxRev 0xA6 = 0xc5 +sboxRev 0xB4 = 0xc6 +sboxRev 0xC6 = 0xc7 + +sboxRev 0xE8 = 0xc8 +sboxRev 0xDD = 0xc9 +sboxRev 0x74 = 0xca +sboxRev 0x1F = 0xcb +sboxRev 0x4B = 0xcc +sboxRev 0xBD = 0xcd +sboxRev 0x8B = 0xce +sboxRev 0x8A = 0xcf + +sboxRev 0x70 = 0xd0 +sboxRev 0x3E = 0xd1 +sboxRev 0xB5 = 0xd2 +sboxRev 0x66 = 0xd3 +sboxRev 0x48 = 0xd4 +sboxRev 0x03 = 0xd5 +sboxRev 0xF6 = 0xd6 +sboxRev 0x0E = 0xd7 + +sboxRev 0x61 = 0xd8 +sboxRev 0x35 = 0xd9 +sboxRev 0x57 = 0xda +sboxRev 0xB9 = 0xdb +sboxRev 0x86 = 0xdc +sboxRev 0xC1 = 0xdd +sboxRev 0x1D = 0xde +sboxRev 0x9E = 0xdf + +sboxRev 0xE1 = 0xe0 +sboxRev 0xF8 = 0xe1 +sboxRev 0x98 = 0xe2 +sboxRev 0x11 = 0xe3 +sboxRev 0x69 = 0xe4 +sboxRev 0xD9 = 0xe5 +sboxRev 0x8E = 0xe6 +sboxRev 0x94 = 0xe7 + +sboxRev 0x9B = 0xe8 +sboxRev 0x1E = 0xe9 +sboxRev 0x87 = 0xea +sboxRev 0xE9 = 0xeb +sboxRev 0xCE = 0xec +sboxRev 0x55 = 0xed +sboxRev 0x28 = 0xee +sboxRev 0xDF = 0xef + +sboxRev 0x8C = 0xf0 +sboxRev 0xA1 = 0xf1 +sboxRev 0x89 = 0xf2 +sboxRev 0x0D = 0xf3 +sboxRev 0xBF = 0xf4 +sboxRev 0xE6 = 0xf5 +sboxRev 0x42 = 0xf6 +sboxRev 0x68 = 0xf7 + +sboxRev 0x41 = 0xf8 +sboxRev 0x99 = 0xf9 +sboxRev 0x2D = 0xfa +sboxRev 0x0F = 0xfb +sboxRev 0xB0 = 0xfc +sboxRev 0x54 = 0xfd +sboxRev 0xBB = 0xfe +sboxRev 0x16 = 0xff + +xtime :: Word32 -> Word32 +xtime x = b + where a = x `shiftL` 1 + b = if a .&. (0x0100) == 0 then a else a `xor` 0x11b + +xtimeX2 :: Word32 -> Word32 +--xtimeX2 = xtime . xtime +xtimeX2 x = c + where a = x `shiftL` 2 + b = if a .&. (0x0200) == 0 then a else a `xor` 0x236 + c = if b .&. (0x0100) == 0 then b else b `xor` 0x11b + +xtimeX3 :: Word32 -> Word32 +--xtimeX3 = xtime . xtime . xtime +xtimeX3 x = d + where a = x `shiftL` 3 + b = if a .&. (0x0400) == 0 then a else a `xor` 0x46c + c = if b .&. (0x0200) == 0 then b else b `xor` 0x236 + d = if c .&. (0x0100) == 0 then c else c `xor` 0x11b + +xtime03 :: Word32 -> Word32 +xtime03 x = x `xor` (xtime x) + +xtime0e :: Word32 -> Word32 +xtime0e x = xtime (x `xor` (xtime (x `xor` (xtime x)))) + +xtime09 :: Word32 -> Word32 +xtime09 x = x `xor` (xtimeX3 x) + +xtime0d :: Word32 -> Word32 +xtime0d x = x `xor` (xtimeX2 (x `xor` (xtime x))) + +xtime0b :: Word32 -> Word32 +xtime0b x = x `xor` (xtime (x `xor` (xtimeX2 x))) + +generateKey :: Int -> Int -> Word32 -> Word32 -> Word32 +generateKey nk i wIminus1 wIminusNk = + (temp' `xor` wIminusNk) + where temp' = + if (i `mod` nk) == 0 then (subword(rotword temp)) `xor` rcon + else if (nk > 6) && ((i `mod` nk) == 4) then subword temp + else temp + temp = wIminus1 + subword :: Word32 -> Word32 + subword w = (a `shiftL` 24) .|. (b `shiftL` 16) .|. + (c `shiftL` 8) .|. d + where a = sbox ((w `shiftR` 24) .&. 0xff) + b = sbox ((w `shiftR` 16) .&. 0xff) + c = sbox ((w `shiftR` 8) .&. 0xff) + d = sbox ( w .&. 0xff) + rotword :: Word32 -> Word32 + rotword w = w `rotateL` 8 + rcon :: Word32 + rcon = ((fromIntegral rconMSB)::Word32) `shiftL` 24 + rconMSB = (iterate xtime 0x01) !! ((i `div` nk) - 1) + +wordify :: [Octet] -> [Word32] +wordify [] = [] +wordify octets = firstWord:otherWords + where + (firstWord, otherOctets) = getWord32 octets + otherWords = wordify otherOctets + +generateKeys :: Int -> Int -> [Octet] -> [Word32] +generateKeys nr nk mainKey = + -- assert ((nk * 4) == length mainKey) $ + (take (4 * (nr + 1)) xs) + where + xs = (wordify mainKey) ++ (zipWith3 (generateKey nk) + (drop nk [0,1..]) + (drop (nk - 1) xs) + xs + ) + +subBytes :: State -> State +subBytes (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (sbox s00, sbox s01, sbox s02, sbox s03) + (sbox s10, sbox s11, sbox s12, sbox s13) + (sbox s20, sbox s21, sbox s22, sbox s23) + (sbox s30, sbox s31, sbox s32, sbox s33) + +subBytesRev :: State -> State +subBytesRev (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (sboxRev s00, sboxRev s01, sboxRev s02, sboxRev s03) + (sboxRev s10, sboxRev s11, sboxRev s12, sboxRev s13) + (sboxRev s20, sboxRev s21, sboxRev s22, sboxRev s23) + (sboxRev s30, sboxRev s31, sboxRev s32, sboxRev s33) + +shiftRows :: State -> State +shiftRows (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (s00, s01, s02, s03) + (s11, s12, s13, s10) + (s22, s23, s20, s21) + (s33, s30, s31, s32) + +shiftRowsRev :: State -> State +shiftRowsRev (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (s00, s01, s02, s03) + (s13, s10, s11, s12) + (s22, s23, s20, s21) + (s31, s32, s33, s30) + +mixColumn:: (Word32, Word32, Word32, Word32) -> (Word32, Word32, Word32, Word32) +mixColumn (s0,s1,s2,s3) = + ((xtime s0) `xor` (xtime03 s1) `xor` s2 `xor` s3 , + s0 `xor` (xtime s1) `xor` (xtime03 s2) `xor` s3 , + s0 `xor` s1 `xor` (xtime s2) `xor` (xtime03 s3), + (xtime03 s0) `xor` s1 `xor` s2 `xor` (xtime s3)) + +mixColumns :: State -> State +mixColumns (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (r00, r01, r02, r03) + (r10, r11, r12, r13) + (r20, r21, r22, r23) + (r30, r31, r32, r33) + where (r00, r10, r20, r30) = mixColumn (s00, s10, s20, s30) + (r01, r11, r21, r31) = mixColumn (s01, s11, s21, s31) + (r02, r12, r22, r32) = mixColumn (s02, s12, s22, s32) + (r03, r13, r23, r33) = mixColumn (s03, s13, s23, s33) + +mixColumnRev :: (Word32, Word32, Word32, Word32) + -> (Word32, Word32, Word32, Word32) +mixColumnRev (s0,s1,s2,s3) = + ((xtime0e s0) `xor` (xtime0b s1) `xor` (xtime0d s2) `xor` (xtime09 s3), + (xtime09 s0) `xor` (xtime0e s1) `xor` (xtime0b s2) `xor` (xtime0d s3), + (xtime0d s0) `xor` (xtime09 s1) `xor` (xtime0e s2) `xor` (xtime0b s3), + (xtime0b s0) `xor` (xtime0d s1) `xor` (xtime09 s2) `xor` (xtime0e s3)) + +mixColumnsRev :: State -> State +mixColumnsRev (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (r00, r01, r02, r03) + (r10, r11, r12, r13) + (r20, r21, r22, r23) + (r30, r31, r32, r33) + where (r00, r10, r20, r30) = mixColumnRev (s00, s10, s20, s30) + (r01, r11, r21, r31) = mixColumnRev (s01, s11, s21, s31) + (r02, r12, r22, r32) = mixColumnRev (s02, s12, s22, s32) + (r03, r13, r23, r33) = mixColumnRev (s03, s13, s23, s33) + +addRoundKey :: State -> State -> State +addRoundKey (State (k00, k01, k02, k03) + (k10, k11, k12, k13) + (k20, k21, k22, k23) + (k30, k31, k32, k33)) + (State (s00, s01, s02, s03) + (s10, s11, s12, s13) + (s20, s21, s22, s23) + (s30, s31, s32, s33)) = + State (s00 `xor` k00, s01 `xor` k01, s02 `xor` k02, s03 `xor` k03) + (s10 `xor` k10, s11 `xor` k11, s12 `xor` k12, s13 `xor` k13) + (s20 `xor` k20, s21 `xor` k21, s22 `xor` k22, s23 `xor` k23) + (s30 `xor` k30, s31 `xor` k31, s32 `xor` k32, s33 `xor` k33) + +genAddRoundKey :: [Word32] -> [State -> State] +genAddRoundKey [] = [] +genAddRoundKey (a:b:c:d:ks) = (addRoundKey k):(genAddRoundKey ks) + where k = State (fromIntegral s00, fromIntegral s01, + fromIntegral s02, fromIntegral s03) + (fromIntegral s10, fromIntegral s11, + fromIntegral s12, fromIntegral s13) + (fromIntegral s20, fromIntegral s21, + fromIntegral s22, fromIntegral s23) + (fromIntegral s30, fromIntegral s31, + fromIntegral s32, fromIntegral s33) + [s00, s10, s20, s30] = putWord32 a + [s01, s11, s21, s31] = putWord32 b + [s02, s12, s22, s32] = putWord32 c + [s03, s13, s23, s33] = putWord32 d + +getWord32 :: [Octet] -> (Word32, [Octet]) +getWord32 (a:b:c:d:xs) = (x, xs) + where + x = ((fromIntegral a) `shiftL` 24) .|. + ((fromIntegral b) `shiftL` 16) .|. + ((fromIntegral c) `shiftL` 8) .|. + ((fromIntegral d) ) + +putWord32 :: Word32 -> [Octet] +--a bit slower putWord32 x = map fromIntegral [a,b,c,d] +putWord32 x = [fromIntegral a, fromIntegral b, fromIntegral c, fromIntegral d] + where + a = (x `shiftR` 24) + b = (x `shiftR` 16) .&. 255 + c = (x `shiftR` 8) .&. 255 + d = (x ) .&. 255 + +{- +testGenerateKeys128 :: Test +testGenerateKeys128 = + let key = [0x2b, 0x7e, 0x15, 0x16, + 0x28, 0xae, 0xd2, 0xa6, + 0xab, 0xf7, 0x15, 0x88, + 0x09, 0xcf, 0x4f, 0x3c] + expected = [0x2b7e1516, 0x28aed2a6, 0xabf71588, 0x09cf4f3c, + 0xa0fafe17, 0x88542cb1, 0x23a33939, 0x2a6c7605, + 0xf2c295f2, 0x7a96b943, 0x5935807a, 0x7359f67f, + 0x3d80477d, 0x4716fe3e, 0x1e237e44, 0x6d7a883b, + 0xef44a541, 0xa8525b7f, 0xb671253b, 0xdb0bad00, + 0xd4d1c6f8, 0x7c839d87, 0xcaf2b8bc, 0x11f915bc, + 0x6d88a37a, 0x110b3efd, 0xdbf98641, 0xca0093fd, + 0x4e54f70e, 0x5f5fc9f3, 0x84a64fb2, 0x4ea6dc4f, + 0xead27321, 0xb58dbad2, 0x312bf560, 0x7f8d292f, + 0xac7766f3, 0x19fadc21, 0x28d12941, 0x575c006e, + 0xd014f9a8, 0xc9ee2589, 0xe13f0cc8, 0xb6630ca6 + ] + in TestCase (do + assertEqual "" expected (generateKeys 10 4 key) + ) + + +testGenerateKeys192 :: Test +testGenerateKeys192 = + let key = [0x8e, 0x73, 0xb0, 0xf7, + 0xda, 0x0e, 0x64, 0x52, + 0xc8, 0x10, 0xf3, 0x2b, + 0x80, 0x90, 0x79, 0xe5, + 0x62, 0xf8, 0xea, 0xd2, + 0x52, 0x2c, 0x6b, 0x7b] + expected = [0x8e73b0f7, 0xda0e6452, 0xc810f32b, 0x809079e5, + 0x62f8ead2, 0x522c6b7b, 0xfe0c91f7, 0x2402f5a5, + 0xec12068e, 0x6c827f6b, 0x0e7a95b9, 0x5c56fec2, + 0x4db7b4bd, 0x69b54118, 0x85a74796, 0xe92538fd, + 0xe75fad44, 0xbb095386, 0x485af057, 0x21efb14f + ] + in TestCase (do + assertEqual "" expected + (take (length expected) (generateKeys 12 6 key)) + ) + +testGenerateKeys256 :: Test +testGenerateKeys256 = + let key = [0x60, 0x3d, 0xeb, 0x10, + 0x15, 0xca, 0x71, 0xbe, + 0x2b, 0x73, 0xae, 0xf0, + 0x85, 0x7d, 0x77, 0x81, + 0x1f, 0x35, 0x2c, 0x07, + 0x3b, 0x61, 0x08, 0xd7, + 0x2d, 0x98, 0x10, 0xa3, + 0x09, 0x14, 0xdf, 0xf4] + expected = [0x603deb10, 0x15ca71be, 0x2b73aef0, 0x857d7781, + 0x1f352c07, 0x3b6108d7, 0x2d9810a3, 0x0914dff4, + 0x9ba35411, 0x8e6925af, 0xa51a8b5f, 0x2067fcde, + 0xa8b09c1a, 0x93d194cd, 0xbe49846e, 0xb75d5b9a, + 0xd59aecb8, 0x5bf3c917, 0xfee94248, 0xde8ebe96 + ] + in TestCase (do + assertEqual "" expected + (take (length expected) (generateKeys 14 8 key)) + ) + +testAes128 :: Test +testAes128 = + let key = [0x2b, 0x7e, 0x15, 0x16, + 0x28, 0xae, 0xd2, 0xa6, + 0xab, 0xf7, 0x15, 0x88, + 0x09, 0xcf, 0x4f, 0x3c] + input = [0x32, 0x43, 0xf6, 0xa8, + 0x88, 0x5a, 0x30, 0x8d, + 0x31, 0x31, 0x98, 0xa2, + 0xe0, 0x37, 0x07, 0x34] + output = [0x39, 0x25, 0x84, 0x1d, + 0x02, 0xdc, 0x09, 0xfb, + 0xdc, 0x11, 0x85, 0x97, + 0x19, 0x6a, 0x0b, 0x32] + in TestCase (do + assertEqual "encrypt test" output (aes128Encrypt key input) + assertEqual "encrypt/decrypt test" input + (aes128Decrypt key (aes128Encrypt key input)) + ) + +testAesRandom :: Test +testAesRandom = + TestCase (do + key128 <- getRandomOctets 16 + key192 <- getRandomOctets 24 + key256 <- getRandomOctets 32 + msg <- getRandomOctets 16 + assertEqual "aes128" msg + (aes128Decrypt key128 (aes128Encrypt key128 msg)) + assertEqual "aes192" msg + (aes192Decrypt key192 (aes192Encrypt key192 msg)) + assertEqual "aes256" msg + (aes256Decrypt key256 (aes256Encrypt key256 msg)) + ) + +-- | HUnit tests +tests :: Test +tests = TestList [ + TestLabel "testGenerateKeys128" testGenerateKeys128, + TestLabel "testGenerateKeys192" testGenerateKeys192, + TestLabel "testGenerateKeys256" testGenerateKeys256, + TestLabel "testAes128" testAes128, + TestLabel "testAesRandom" testAesRandom + ] +-} + diff --git a/Codec/Encryption/Blowfish.hs b/Codec/Encryption/Blowfish.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/Blowfish.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Coded.Encryption.Blowfish +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Takes the Blowfish module supplied by Doug Hoyte and wraps it so it can +-- used with the standard modes. +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.Blowfish + ( + -- * Function Types + encrypt, + decrypt + ) where + +import Data.Bits +import Data.Word +import Data.Char +import Codec.Utils +import Codec.Encryption.BlowfishAux + +-- * Basic Blowfish Encryption + +-- | Basic Blowfish encryption which takes a key and a block of plaintext +-- and returns the encrypted block of ciphertext according to the standard. +-- Typical keys are Word8, Word16, Word32, Word64, Word128. See +-- . + +encrypt :: (Integral a) => a -> Word64 -> Word64 +encrypt k p = mergeWord32 (lo,hi) where + lo = head e + hi = head $ tail e + e = bfEnc (bfMakeKey (map (chr . fromIntegral) (toOctets 256 k))) [lo',hi'] + (lo',hi') = (splitZord64 p) + +-- | Basic Blowfish decryption which takes a key and a block of ciphertext +-- and returns the decrypted block of plaintext. + +decrypt :: (Integral a) => a -> Word64 -> Word64 +decrypt k p = mergeWord32 (lo,hi) where + lo = head d + hi = head $ tail d + d = bfDec (bfMakeKey (map (chr . fromIntegral) (toOctets 256 k))) [lo',hi'] + (lo',hi') = splitZord64 p + +splitZord64 :: Word64 -> (Word32,Word32) +splitZord64 x = (fromIntegral (shiftR (x .&. 0xffffffff00000000) 32), + fromIntegral (x .&. 0x00000000ffffffff)) + +mergeWord32 :: (Word32,Word32) -> Word64 +mergeWord32 (lo,hi) = shift (fromIntegral lo) 32 + fromIntegral hi diff --git a/Codec/Encryption/BlowfishAux.hs b/Codec/Encryption/BlowfishAux.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/BlowfishAux.hs @@ -0,0 +1,282 @@ +-- BlowfishAux.hs (C) 2002 HardCore SoftWare, Doug Hoyte +-- +-- Doug has kindly agreed to release this under BSD. +-- +-- Haskell implementation of Bruce Schneier's blowfish encryption algorithm. +-- This implementation uses 16 rounds and produces the same ciphertext as +-- the OpenBSD and Paul Kocher 16-round implementations. +-- +-- The function bfMakeKey should be passed a list of Chars. These represent +-- the key. It will return a datatype called "BF", which contains the +-- initialized key information. +-- +-- The function bfEnc is passed a BF datatype representing the key and a +-- list of 2 Word32s (the plaintext). It returns a list of 2 Word32s +-- (the ciphertext). +-- +-- The function bfDec is passed a BF datatype representing the key and a list +-- of 2 Word32s (the ciphertext) and a BF datatype representing the key. It +-- returns a list of 2 Word32s (the plaintext). + +module Codec.Encryption.BlowfishAux + (bfMakeKey, + bfEnc, + bfDec) where + +import Data.Array +import Data.Bits +import Data.Word +import Data.Char + +type Pbox = Array Word32 Word32 +type Sbox = Array Word32 Word32 + +data BF = BF Pbox Sbox Sbox Sbox Sbox + + + +bfEnc :: BF -> [Word32] -> [Word32] +bfEnc a b = aux a b 0 + where + aux :: BF -> [Word32] -> Word32 -> [Word32] + aux bs@(BF p s0 s1 s2 s3) (l:r:[]) 16 = (r `xor` p!17):(l `xor` p!16):[] + aux bs@(BF p s0 s1 s2 s3) (l:r:[]) i = aux bs (newr:newl:[]) (i+1) + where newl = l `xor` (p ! i) + newr = r `xor` (f newl) + f :: Word32 -> Word32 + f t = ((s0!a + s1!b) `xor` (s2 ! c)) + (s3 ! d) + where a = (t `shiftR` 24) + b = ((t `shiftL` 8) `shiftR` 24) + c = ((t `shiftL` 16) `shiftR` 24) + d = ((t `shiftL` 24) `shiftR` 24) + + +bfDec :: BF -> [Word32] -> [Word32] +bfDec (BF p s0 s1 s2 s3) a = bfEnc (BF (revP p) s0 s1 s2 s3) a + where revP :: Pbox -> Pbox + revP x = x//[(i, x ! (17-i)) | i <- [0..17]] + + +bfMakeKey :: [Char] -> BF +bfMakeKey [] = procKey [0,0] (BF iPbox iSbox0 iSbox1 iSbox2 iSbox3) 0 +bfMakeKey k = procKey [0,0] (BF (string2Pbox k) iSbox0 iSbox1 iSbox2 iSbox3) 0 + + +string2Pbox :: [Char] -> Pbox +string2Pbox k = array (0,17) [(fromIntegral i,xtext!!i) | i <- [0..17]] + where xtext = zipWith (xor) + (compress4 (doShift (makeTo72 (charsToWord32s k) 0) 0)) + [iPbox ! (fromIntegral i) | i <- [0..17]] + charsToWord32s [] = [] + charsToWord32s (k:ks) = (fromIntegral $ fromEnum k) : charsToWord32s ks + makeTo72 k 72 = [] + makeTo72 k i = k!!(i `mod` (length k)) : makeTo72 k (i+1) + doShift [] i = [] + doShift (w:ws) i = w `shiftL` (8*(3 - (i `mod` 4))) : doShift ws (i+1) + compress4 [] = [] + compress4 (a:b:c:d:etc) = (a .|. b .|. c .|. d) : compress4 etc + + +procKey :: [Word32] -> BF -> Word32 -> BF +procKey (l:r:[]) tpbf@(BF p s0 s1 s2 s3) 1042 = tpbf +procKey (l:r:[]) tpbf@(BF p s0 s1 s2 s3) i = procKey [nl,nr] (newbf i) (i+2) + where [nl,nr] = bfEnc tpbf [l,r] + newbf x | x < 18 = (BF (p//[(x,nl),(x+1,nr)]) s0 s1 s2 s3) + | x < 274 = (BF p (s0//[(x-18,nl),(x-17,nr)]) s1 s2 s3) + | x < 530 = (BF p s0 (s1//[(x-274,nl),(x-273,nr)]) s2 s3) + | x < 786 = (BF p s0 s1 (s2//[(x-530,nl),(x-529,nr)]) s3) + | x < 1042 = (BF p s0 s1 s2 (s3//[(x-786,nl),(x-785,nr)])) + + + +---------- INITIAL S AND P BOXES ARE THE HEXADECIMAL DIGITS OF PI ------------ + +iPbox :: Pbox +iPbox = array (0,17) (zip [0..17] + [0x243f6a88, 0x85a308d3, 0x13198a2e, 0x03707344, 0xa4093822, 0x299f31d0, + 0x082efa98, 0xec4e6c89, 0x452821e6, 0x38d01377, 0xbe5466cf, 0x34e90c6c, + 0xc0ac29b7, 0xc97c50dd, 0x3f84d5b5, 0xb5470917, 0x9216d5d9, 0x8979fb1b]) + +iSbox0 :: Sbox +iSbox0 = array (0,255) (zip [0..255] + [0xd1310ba6, 0x98dfb5ac, 0x2ffd72db, 0xd01adfb7, 0xb8e1afed, 0x6a267e96, + 0xba7c9045, 0xf12c7f99, 0x24a19947, 0xb3916cf7, 0x0801f2e2, 0x858efc16, + 0x636920d8, 0x71574e69, 0xa458fea3, 0xf4933d7e, 0x0d95748f, 0x728eb658, + 0x718bcd58, 0x82154aee, 0x7b54a41d, 0xc25a59b5, 0x9c30d539, 0x2af26013, + 0xc5d1b023, 0x286085f0, 0xca417918, 0xb8db38ef, 0x8e79dcb0, 0x603a180e, + 0x6c9e0e8b, 0xb01e8a3e, 0xd71577c1, 0xbd314b27, 0x78af2fda, 0x55605c60, + 0xe65525f3, 0xaa55ab94, 0x57489862, 0x63e81440, 0x55ca396a, 0x2aab10b6, + 0xb4cc5c34, 0x1141e8ce, 0xa15486af, 0x7c72e993, 0xb3ee1411, 0x636fbc2a, + 0x2ba9c55d, 0x741831f6, 0xce5c3e16, 0x9b87931e, 0xafd6ba33, 0x6c24cf5c, + 0x7a325381, 0x28958677, 0x3b8f4898, 0x6b4bb9af, 0xc4bfe81b, 0x66282193, + 0x61d809cc, 0xfb21a991, 0x487cac60, 0x5dec8032, 0xef845d5d, 0xe98575b1, + 0xdc262302, 0xeb651b88, 0x23893e81, 0xd396acc5, 0x0f6d6ff3, 0x83f44239, + 0x2e0b4482, 0xa4842004, 0x69c8f04a, 0x9e1f9b5e, 0x21c66842, 0xf6e96c9a, + 0x670c9c61, 0xabd388f0, 0x6a51a0d2, 0xd8542f68, 0x960fa728, 0xab5133a3, + 0x6eef0b6c, 0x137a3be4, 0xba3bf050, 0x7efb2a98, 0xa1f1651d, 0x39af0176, + 0x66ca593e, 0x82430e88, 0x8cee8619, 0x456f9fb4, 0x7d84a5c3, 0x3b8b5ebe, + 0xe06f75d8, 0x85c12073, 0x401a449f, 0x56c16aa6, 0x4ed3aa62, 0x363f7706, + 0x1bfedf72, 0x429b023d, 0x37d0d724, 0xd00a1248, 0xdb0fead3, 0x49f1c09b, + 0x075372c9, 0x80991b7b, 0x25d479d8, 0xf6e8def7, 0xe3fe501a, 0xb6794c3b, + 0x976ce0bd, 0x04c006ba, 0xc1a94fb6, 0x409f60c4, 0x5e5c9ec2, 0x196a2463, + 0x68fb6faf, 0x3e6c53b5, 0x1339b2eb, 0x3b52ec6f, 0x6dfc511f, 0x9b30952c, + 0xcc814544, 0xaf5ebd09, 0xbee3d004, 0xde334afd, 0x660f2807, 0x192e4bb3, + 0xc0cba857, 0x45c8740f, 0xd20b5f39, 0xb9d3fbdb, 0x5579c0bd, 0x1a60320a, + 0xd6a100c6, 0x402c7279, 0x679f25fe, 0xfb1fa3cc, 0x8ea5e9f8, 0xdb3222f8, + 0x3c7516df, 0xfd616b15, 0x2f501ec8, 0xad0552ab, 0x323db5fa, 0xfd238760, + 0x53317b48, 0x3e00df82, 0x9e5c57bb, 0xca6f8ca0, 0x1a87562e, 0xdf1769db, + 0xd542a8f6, 0x287effc3, 0xac6732c6, 0x8c4f5573, 0x695b27b0, 0xbbca58c8, + 0xe1ffa35d, 0xb8f011a0, 0x10fa3d98, 0xfd2183b8, 0x4afcb56c, 0x2dd1d35b, + 0x9a53e479, 0xb6f84565, 0xd28e49bc, 0x4bfb9790, 0xe1ddf2da, 0xa4cb7e33, + 0x62fb1341, 0xcee4c6e8, 0xef20cada, 0x36774c01, 0xd07e9efe, 0x2bf11fb4, + 0x95dbda4d, 0xae909198, 0xeaad8e71, 0x6b93d5a0, 0xd08ed1d0, 0xafc725e0, + 0x8e3c5b2f, 0x8e7594b7, 0x8ff6e2fb, 0xf2122b64, 0x8888b812, 0x900df01c, + 0x4fad5ea0, 0x688fc31c, 0xd1cff191, 0xb3a8c1ad, 0x2f2f2218, 0xbe0e1777, + 0xea752dfe, 0x8b021fa1, 0xe5a0cc0f, 0xb56f74e8, 0x18acf3d6, 0xce89e299, + 0xb4a84fe0, 0xfd13e0b7, 0x7cc43b81, 0xd2ada8d9, 0x165fa266, 0x80957705, + 0x93cc7314, 0x211a1477, 0xe6ad2065, 0x77b5fa86, 0xc75442f5, 0xfb9d35cf, + 0xebcdaf0c, 0x7b3e89a0, 0xd6411bd3, 0xae1e7e49, 0x00250e2d, 0x2071b35e, + 0x226800bb, 0x57b8e0af, 0x2464369b, 0xf009b91e, 0x5563911d, 0x59dfa6aa, + 0x78c14389, 0xd95a537f, 0x207d5ba2, 0x02e5b9c5, 0x83260376, 0x6295cfa9, + 0x11c81968, 0x4e734a41, 0xb3472dca, 0x7b14a94a, 0x1b510052, 0x9a532915, + 0xd60f573f, 0xbc9bc6e4, 0x2b60a476, 0x81e67400, 0x08ba6fb5, 0x571be91f, + 0xf296ec6b, 0x2a0dd915, 0xb6636521, 0xe7b9f9b6, 0xff34052e, 0xc5855664, + 0x53b02d5d, 0xa99f8fa1, 0x08ba4799, 0x6e85076a]) + +iSbox1 :: Sbox +iSbox1 = array (0,255) (zip [0..255] + [0x4b7a70e9, 0xb5b32944, 0xdb75092e, 0xc4192623, 0xad6ea6b0, 0x49a7df7d, + 0x9cee60b8, 0x8fedb266, 0xecaa8c71, 0x699a17ff, 0x5664526c, 0xc2b19ee1, + 0x193602a5, 0x75094c29, 0xa0591340, 0xe4183a3e, 0x3f54989a, 0x5b429d65, + 0x6b8fe4d6, 0x99f73fd6, 0xa1d29c07, 0xefe830f5, 0x4d2d38e6, 0xf0255dc1, + 0x4cdd2086, 0x8470eb26, 0x6382e9c6, 0x021ecc5e, 0x09686b3f, 0x3ebaefc9, + 0x3c971814, 0x6b6a70a1, 0x687f3584, 0x52a0e286, 0xb79c5305, 0xaa500737, + 0x3e07841c, 0x7fdeae5c, 0x8e7d44ec, 0x5716f2b8, 0xb03ada37, 0xf0500c0d, + 0xf01c1f04, 0x0200b3ff, 0xae0cf51a, 0x3cb574b2, 0x25837a58, 0xdc0921bd, + 0xd19113f9, 0x7ca92ff6, 0x94324773, 0x22f54701, 0x3ae5e581, 0x37c2dadc, + 0xc8b57634, 0x9af3dda7, 0xa9446146, 0x0fd0030e, 0xecc8c73e, 0xa4751e41, + 0xe238cd99, 0x3bea0e2f, 0x3280bba1, 0x183eb331, 0x4e548b38, 0x4f6db908, + 0x6f420d03, 0xf60a04bf, 0x2cb81290, 0x24977c79, 0x5679b072, 0xbcaf89af, + 0xde9a771f, 0xd9930810, 0xb38bae12, 0xdccf3f2e, 0x5512721f, 0x2e6b7124, + 0x501adde6, 0x9f84cd87, 0x7a584718, 0x7408da17, 0xbc9f9abc, 0xe94b7d8c, + 0xec7aec3a, 0xdb851dfa, 0x63094366, 0xc464c3d2, 0xef1c1847, 0x3215d908, + 0xdd433b37, 0x24c2ba16, 0x12a14d43, 0x2a65c451, 0x50940002, 0x133ae4dd, + 0x71dff89e, 0x10314e55, 0x81ac77d6, 0x5f11199b, 0x043556f1, 0xd7a3c76b, + 0x3c11183b, 0x5924a509, 0xf28fe6ed, 0x97f1fbfa, 0x9ebabf2c, 0x1e153c6e, + 0x86e34570, 0xeae96fb1, 0x860e5e0a, 0x5a3e2ab3, 0x771fe71c, 0x4e3d06fa, + 0x2965dcb9, 0x99e71d0f, 0x803e89d6, 0x5266c825, 0x2e4cc978, 0x9c10b36a, + 0xc6150eba, 0x94e2ea78, 0xa5fc3c53, 0x1e0a2df4, 0xf2f74ea7, 0x361d2b3d, + 0x1939260f, 0x19c27960, 0x5223a708, 0xf71312b6, 0xebadfe6e, 0xeac31f66, + 0xe3bc4595, 0xa67bc883, 0xb17f37d1, 0x018cff28, 0xc332ddef, 0xbe6c5aa5, + 0x65582185, 0x68ab9802, 0xeecea50f, 0xdb2f953b, 0x2aef7dad, 0x5b6e2f84, + 0x1521b628, 0x29076170, 0xecdd4775, 0x619f1510, 0x13cca830, 0xeb61bd96, + 0x0334fe1e, 0xaa0363cf, 0xb5735c90, 0x4c70a239, 0xd59e9e0b, 0xcbaade14, + 0xeecc86bc, 0x60622ca7, 0x9cab5cab, 0xb2f3846e, 0x648b1eaf, 0x19bdf0ca, + 0xa02369b9, 0x655abb50, 0x40685a32, 0x3c2ab4b3, 0x319ee9d5, 0xc021b8f7, + 0x9b540b19, 0x875fa099, 0x95f7997e, 0x623d7da8, 0xf837889a, 0x97e32d77, + 0x11ed935f, 0x16681281, 0x0e358829, 0xc7e61fd6, 0x96dedfa1, 0x7858ba99, + 0x57f584a5, 0x1b227263, 0x9b83c3ff, 0x1ac24696, 0xcdb30aeb, 0x532e3054, + 0x8fd948e4, 0x6dbc3128, 0x58ebf2ef, 0x34c6ffea, 0xfe28ed61, 0xee7c3c73, + 0x5d4a14d9, 0xe864b7e3, 0x42105d14, 0x203e13e0, 0x45eee2b6, 0xa3aaabea, + 0xdb6c4f15, 0xfacb4fd0, 0xc742f442, 0xef6abbb5, 0x654f3b1d, 0x41cd2105, + 0xd81e799e, 0x86854dc7, 0xe44b476a, 0x3d816250, 0xcf62a1f2, 0x5b8d2646, + 0xfc8883a0, 0xc1c7b6a3, 0x7f1524c3, 0x69cb7492, 0x47848a0b, 0x5692b285, + 0x095bbf00, 0xad19489d, 0x1462b174, 0x23820e00, 0x58428d2a, 0x0c55f5ea, + 0x1dadf43e, 0x233f7061, 0x3372f092, 0x8d937e41, 0xd65fecf1, 0x6c223bdb, + 0x7cde3759, 0xcbee7460, 0x4085f2a7, 0xce77326e, 0xa6078084, 0x19f8509e, + 0xe8efd855, 0x61d99735, 0xa969a7aa, 0xc50c06c2, 0x5a04abfc, 0x800bcadc, + 0x9e447a2e, 0xc3453484, 0xfdd56705, 0x0e1e9ec9, 0xdb73dbd3, 0x105588cd, + 0x675fda79, 0xe3674340, 0xc5c43465, 0x713e38d8, 0x3d28f89e, 0xf16dff20, + 0x153e21e7, 0x8fb03d4a, 0xe6e39f2b, 0xdb83adf7]) + +iSbox2 :: Sbox +iSbox2 = array (0,255) (zip [0..255] + [0xe93d5a68, 0x948140f7, 0xf64c261c, 0x94692934, 0x411520f7, 0x7602d4f7, + 0xbcf46b2e, 0xd4a20068, 0xd4082471, 0x3320f46a, 0x43b7d4b7, 0x500061af, + 0x1e39f62e, 0x97244546, 0x14214f74, 0xbf8b8840, 0x4d95fc1d, 0x96b591af, + 0x70f4ddd3, 0x66a02f45, 0xbfbc09ec, 0x03bd9785, 0x7fac6dd0, 0x31cb8504, + 0x96eb27b3, 0x55fd3941, 0xda2547e6, 0xabca0a9a, 0x28507825, 0x530429f4, + 0x0a2c86da, 0xe9b66dfb, 0x68dc1462, 0xd7486900, 0x680ec0a4, 0x27a18dee, + 0x4f3ffea2, 0xe887ad8c, 0xb58ce006, 0x7af4d6b6, 0xaace1e7c, 0xd3375fec, + 0xce78a399, 0x406b2a42, 0x20fe9e35, 0xd9f385b9, 0xee39d7ab, 0x3b124e8b, + 0x1dc9faf7, 0x4b6d1856, 0x26a36631, 0xeae397b2, 0x3a6efa74, 0xdd5b4332, + 0x6841e7f7, 0xca7820fb, 0xfb0af54e, 0xd8feb397, 0x454056ac, 0xba489527, + 0x55533a3a, 0x20838d87, 0xfe6ba9b7, 0xd096954b, 0x55a867bc, 0xa1159a58, + 0xcca92963, 0x99e1db33, 0xa62a4a56, 0x3f3125f9, 0x5ef47e1c, 0x9029317c, + 0xfdf8e802, 0x04272f70, 0x80bb155c, 0x05282ce3, 0x95c11548, 0xe4c66d22, + 0x48c1133f, 0xc70f86dc, 0x07f9c9ee, 0x41041f0f, 0x404779a4, 0x5d886e17, + 0x325f51eb, 0xd59bc0d1, 0xf2bcc18f, 0x41113564, 0x257b7834, 0x602a9c60, + 0xdff8e8a3, 0x1f636c1b, 0x0e12b4c2, 0x02e1329e, 0xaf664fd1, 0xcad18115, + 0x6b2395e0, 0x333e92e1, 0x3b240b62, 0xeebeb922, 0x85b2a20e, 0xe6ba0d99, + 0xde720c8c, 0x2da2f728, 0xd0127845, 0x95b794fd, 0x647d0862, 0xe7ccf5f0, + 0x5449a36f, 0x877d48fa, 0xc39dfd27, 0xf33e8d1e, 0x0a476341, 0x992eff74, + 0x3a6f6eab, 0xf4f8fd37, 0xa812dc60, 0xa1ebddf8, 0x991be14c, 0xdb6e6b0d, + 0xc67b5510, 0x6d672c37, 0x2765d43b, 0xdcd0e804, 0xf1290dc7, 0xcc00ffa3, + 0xb5390f92, 0x690fed0b, 0x667b9ffb, 0xcedb7d9c, 0xa091cf0b, 0xd9155ea3, + 0xbb132f88, 0x515bad24, 0x7b9479bf, 0x763bd6eb, 0x37392eb3, 0xcc115979, + 0x8026e297, 0xf42e312d, 0x6842ada7, 0xc66a2b3b, 0x12754ccc, 0x782ef11c, + 0x6a124237, 0xb79251e7, 0x06a1bbe6, 0x4bfb6350, 0x1a6b1018, 0x11caedfa, + 0x3d25bdd8, 0xe2e1c3c9, 0x44421659, 0x0a121386, 0xd90cec6e, 0xd5abea2a, + 0x64af674e, 0xda86a85f, 0xbebfe988, 0x64e4c3fe, 0x9dbc8057, 0xf0f7c086, + 0x60787bf8, 0x6003604d, 0xd1fd8346, 0xf6381fb0, 0x7745ae04, 0xd736fccc, + 0x83426b33, 0xf01eab71, 0xb0804187, 0x3c005e5f, 0x77a057be, 0xbde8ae24, + 0x55464299, 0xbf582e61, 0x4e58f48f, 0xf2ddfda2, 0xf474ef38, 0x8789bdc2, + 0x5366f9c3, 0xc8b38e74, 0xb475f255, 0x46fcd9b9, 0x7aeb2661, 0x8b1ddf84, + 0x846a0e79, 0x915f95e2, 0x466e598e, 0x20b45770, 0x8cd55591, 0xc902de4c, + 0xb90bace1, 0xbb8205d0, 0x11a86248, 0x7574a99e, 0xb77f19b6, 0xe0a9dc09, + 0x662d09a1, 0xc4324633, 0xe85a1f02, 0x09f0be8c, 0x4a99a025, 0x1d6efe10, + 0x1ab93d1d, 0x0ba5a4df, 0xa186f20f, 0x2868f169, 0xdcb7da83, 0x573906fe, + 0xa1e2ce9b, 0x4fcd7f52, 0x50115e01, 0xa70683fa, 0xa002b5c4, 0x0de6d027, + 0x9af88c27, 0x773f8641, 0xc3604c06, 0x61a806b5, 0xf0177a28, 0xc0f586e0, + 0x006058aa, 0x30dc7d62, 0x11e69ed7, 0x2338ea63, 0x53c2dd94, 0xc2c21634, + 0xbbcbee56, 0x90bcb6de, 0xebfc7da1, 0xce591d76, 0x6f05e409, 0x4b7c0188, + 0x39720a3d, 0x7c927c24, 0x86e3725f, 0x724d9db9, 0x1ac15bb4, 0xd39eb8fc, + 0xed545578, 0x08fca5b5, 0xd83d7cd3, 0x4dad0fc4, 0x1e50ef5e, 0xb161e6f8, + 0xa28514d9, 0x6c51133c, 0x6fd5c7e7, 0x56e14ec4, 0x362abfce, 0xddc6c837, + 0xd79a3234, 0x92638212, 0x670efa8e, 0x406000e0]) + +iSbox3 :: Sbox +iSbox3 = array (0,255) (zip [0..255] + [0x3a39ce37, 0xd3faf5cf, 0xabc27737, 0x5ac52d1b, 0x5cb0679e, 0x4fa33742, + 0xd3822740, 0x99bc9bbe, 0xd5118e9d, 0xbf0f7315, 0xd62d1c7e, 0xc700c47b, + 0xb78c1b6b, 0x21a19045, 0xb26eb1be, 0x6a366eb4, 0x5748ab2f, 0xbc946e79, + 0xc6a376d2, 0x6549c2c8, 0x530ff8ee, 0x468dde7d, 0xd5730a1d, 0x4cd04dc6, + 0x2939bbdb, 0xa9ba4650, 0xac9526e8, 0xbe5ee304, 0xa1fad5f0, 0x6a2d519a, + 0x63ef8ce2, 0x9a86ee22, 0xc089c2b8, 0x43242ef6, 0xa51e03aa, 0x9cf2d0a4, + 0x83c061ba, 0x9be96a4d, 0x8fe51550, 0xba645bd6, 0x2826a2f9, 0xa73a3ae1, + 0x4ba99586, 0xef5562e9, 0xc72fefd3, 0xf752f7da, 0x3f046f69, 0x77fa0a59, + 0x80e4a915, 0x87b08601, 0x9b09e6ad, 0x3b3ee593, 0xe990fd5a, 0x9e34d797, + 0x2cf0b7d9, 0x022b8b51, 0x96d5ac3a, 0x017da67d, 0xd1cf3ed6, 0x7c7d2d28, + 0x1f9f25cf, 0xadf2b89b, 0x5ad6b472, 0x5a88f54c, 0xe029ac71, 0xe019a5e6, + 0x47b0acfd, 0xed93fa9b, 0xe8d3c48d, 0x283b57cc, 0xf8d56629, 0x79132e28, + 0x785f0191, 0xed756055, 0xf7960e44, 0xe3d35e8c, 0x15056dd4, 0x88f46dba, + 0x03a16125, 0x0564f0bd, 0xc3eb9e15, 0x3c9057a2, 0x97271aec, 0xa93a072a, + 0x1b3f6d9b, 0x1e6321f5, 0xf59c66fb, 0x26dcf319, 0x7533d928, 0xb155fdf5, + 0x03563482, 0x8aba3cbb, 0x28517711, 0xc20ad9f8, 0xabcc5167, 0xccad925f, + 0x4de81751, 0x3830dc8e, 0x379d5862, 0x9320f991, 0xea7a90c2, 0xfb3e7bce, + 0x5121ce64, 0x774fbe32, 0xa8b6e37e, 0xc3293d46, 0x48de5369, 0x6413e680, + 0xa2ae0810, 0xdd6db224, 0x69852dfd, 0x09072166, 0xb39a460a, 0x6445c0dd, + 0x586cdecf, 0x1c20c8ae, 0x5bbef7dd, 0x1b588d40, 0xccd2017f, 0x6bb4e3bb, + 0xdda26a7e, 0x3a59ff45, 0x3e350a44, 0xbcb4cdd5, 0x72eacea8, 0xfa6484bb, + 0x8d6612ae, 0xbf3c6f47, 0xd29be463, 0x542f5d9e, 0xaec2771b, 0xf64e6370, + 0x740e0d8d, 0xe75b1357, 0xf8721671, 0xaf537d5d, 0x4040cb08, 0x4eb4e2cc, + 0x34d2466a, 0x0115af84, 0xe1b00428, 0x95983a1d, 0x06b89fb4, 0xce6ea048, + 0x6f3f3b82, 0x3520ab82, 0x011a1d4b, 0x277227f8, 0x611560b1, 0xe7933fdc, + 0xbb3a792b, 0x344525bd, 0xa08839e1, 0x51ce794b, 0x2f32c9b7, 0xa01fbac9, + 0xe01cc87e, 0xbcc7d1f6, 0xcf0111c3, 0xa1e8aac7, 0x1a908749, 0xd44fbd9a, + 0xd0dadecb, 0xd50ada38, 0x0339c32a, 0xc6913667, 0x8df9317c, 0xe0b12b4f, + 0xf79e59b7, 0x43f5bb3a, 0xf2d519ff, 0x27d9459c, 0xbf97222c, 0x15e6fc2a, + 0x0f91fc71, 0x9b941525, 0xfae59361, 0xceb69ceb, 0xc2a86459, 0x12baa8d1, + 0xb6c1075e, 0xe3056a0c, 0x10d25065, 0xcb03a442, 0xe0ec6e0e, 0x1698db3b, + 0x4c98a0be, 0x3278e964, 0x9f1f9532, 0xe0d392df, 0xd3a0342b, 0x8971f21e, + 0x1b0a7441, 0x4ba3348c, 0xc5be7120, 0xc37632d8, 0xdf359f8d, 0x9b992f2e, + 0xe60b6f47, 0x0fe3f11d, 0xe54cda54, 0x1edad891, 0xce6279cf, 0xcd3e7e6f, + 0x1618b166, 0xfd2c1d05, 0x848fd2c5, 0xf6fb2299, 0xf523f357, 0xa6327623, + 0x93a83531, 0x56cccd02, 0xacf08162, 0x5a75ebb5, 0x6e163697, 0x88d273cc, + 0xde966292, 0x81b949d0, 0x4c50901b, 0x71c65614, 0xe6c6c7bd, 0x327a140a, + 0x45e1d006, 0xc3f27b9a, 0xc9aa53fd, 0x62a80f00, 0xbb25bfe2, 0x35bdd2f6, + 0x71126905, 0xb2040222, 0xb6cbcf7c, 0xcd769c2b, 0x53113ec0, 0x1640e3d3, + 0x38abbd60, 0x2547adf0, 0xba38209c, 0xf746ce76, 0x77afa1c5, 0x20756060, + 0x85cbfe4e, 0x8ae88dd8, 0x7aaaf9b0, 0x4cf9aa7e, 0x1948c25c, 0x02fb8a8c, + 0x01c36ae4, 0xd6ebe1f9, 0x90d4f869, 0xa65cdea0, 0x3f09252d, 0xc208e69f, + 0xb74e6132, 0xce77e25b, 0x578fdfe3, 0x3ac372e6]) diff --git a/Codec/Encryption/DES.hs b/Codec/Encryption/DES.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/DES.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.DES +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Takes the DES module supplied by Ian Lynagh and wraps it so it can +-- used with the standard modes. +-- +-- See . +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.DES ( + -- * Function Types + encrypt, decrypt) where + +import Codec.Encryption.DESAux +import Data.Word + +-- | Basic DES encryption which takes a key and a block of plaintext +-- and returns the encrypted block of ciphertext according to the standard. + +encrypt :: Word64 -> Word64 -> Word64 +encrypt = flip des_enc + +-- | Basic DES decryption which takes a key and a block of ciphertext and +-- returns the decrypted block of plaintext according to the standard. + +decrypt :: Word64 -> Word64 -> Word64 +decrypt = flip des_dec diff --git a/Codec/Encryption/DESAux.hs b/Codec/Encryption/DESAux.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/DESAux.hs @@ -0,0 +1,177 @@ +module Codec.Encryption.DESAux (des_enc, des_dec) where + +import Data.Word +import Data.Bits + +type Rotation = Int +type Key = Word64 +type Message = Word64 +type Enc = Word64 + +type BitsX = [Bool] +type Bits4 = [Bool] +type Bits6 = [Bool] +type Bits32 = [Bool] +type Bits48 = [Bool] +type Bits56 = [Bool] +type Bits64 = [Bool] + +instance Num [Bool] + +instance Bits [Bool] where + a `xor` b = (zipWith (\x y -> (not x && y) || (x && not y)) a b) + rotate bits rot = drop rot' bits ++ take rot' bits + where rot' = rot `mod` (length bits) + +bitify :: Word64 -> Bits64 +bitify w = map (\b -> w .&. (shiftL 1 b) /= 0) [63,62..0] + +unbitify :: Bits64 -> Word64 +unbitify bs = foldl (\i b -> if b then 1 + shiftL i 1 else shiftL i 1) 0 bs + +initial_permutation :: Bits64 -> Bits64 +initial_permutation mb = map ((!!) mb) i + where i = [57, 49, 41, 33, 25, 17, 9, 1, 59, 51, 43, 35, 27, 19, 11, 3, + 61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7, + 56, 48, 40, 32, 24, 16, 8, 0, 58, 50, 42, 34, 26, 18, 10, 2, + 60, 52, 44, 36, 28, 20, 12, 4, 62, 54, 46, 38, 30, 22, 14, 6] + +key_transformation :: Bits64 -> Bits56 +key_transformation kb = map ((!!) kb) i + where i = [56, 48, 40, 32, 24, 16, 8, 0, 57, 49, 41, 33, 25, 17, + 9, 1, 58, 50, 42, 34, 26, 18, 10, 2, 59, 51, 43, 35, + 62, 54, 46, 38, 30, 22, 14, 6, 61, 53, 45, 37, 29, 21, + 13, 5, 60, 52, 44, 36, 28, 20, 12, 4, 27, 19, 11, 3] + +des_enc :: Message -> Key -> Enc +des_enc = do_des [1,2,4,6,8,10,12,14,15,17,19,21,23,25,27,28] + +des_dec :: Message -> Key -> Enc +des_dec = do_des [28,27,25,23,21,19,17,15,14,12,10,8,6,4,2,1] + +do_des :: [Rotation] -> Message -> Key -> Enc +do_des rots m k = des_work rots (takeDrop 32 mb) kb + where kb = key_transformation $ bitify k + mb = initial_permutation $ bitify m + +des_work :: [Rotation] -> (Bits32, Bits32) -> Bits56 -> Enc +des_work [] (ml, mr) _ = unbitify $ final_perm $ (mr ++ ml) +des_work (r:rs) mb kb = des_work rs mb' kb + where mb' = do_round r mb kb + +do_round :: Rotation -> (Bits32, Bits32) -> Bits56 -> (Bits32, Bits32) +do_round r (ml, mr) kb = (mr, m') + where kb' = get_key kb r + comp_kb = compression_permutation kb' + expa_mr = expansion_permutation mr + res = comp_kb `xor` expa_mr + res' = tail $ iterate (trans 6) ([], res) + trans n (_, b) = (take n b, drop n b) + res_s = concat $ zipWith (\f (x,_) -> f x) [s_box_1, s_box_2, + s_box_3, s_box_4, + s_box_5, s_box_6, + s_box_7, s_box_8] res' + res_p = p_box res_s + m' = res_p `xor` ml + +get_key :: Bits56 -> Rotation -> Bits56 +get_key kb r = kb' + where (kl, kr) = takeDrop 28 kb + kb' = rotateL kl r ++ rotateL kr r + +compression_permutation :: Bits56 -> Bits48 +compression_permutation kb = map ((!!) kb) i + where i = [13, 16, 10, 23, 0, 4, 2, 27, 14, 5, 20, 9, + 22, 18, 11, 3, 25, 7, 15, 6, 26, 19, 12, 1, + 40, 51, 30, 36, 46, 54, 29, 39, 50, 44, 32, 47, + 43, 48, 38, 55, 33, 52, 45, 41, 49, 35, 28, 31] + +expansion_permutation :: Bits32 -> Bits48 +expansion_permutation mb = map ((!!) mb) i + where i = [31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, + 7, 8, 9, 10, 11, 12, 11, 12, 13, 14, 15, 16, + 15, 16, 17, 18, 19, 20, 19, 20, 21, 22, 23, 24, + 23, 24, 25, 26, 27, 28, 27, 28, 29, 30, 31, 0] + +s_box :: [[Word8]] -> Bits6 -> Bits4 +s_box s [a,b,c,d,e,f] = to_bool 4 $ (s !! row) !! col + where row = sum $ zipWith numericise [a,f] [1, 0] + col = sum $ zipWith numericise [b,c,d,e] [3, 2, 1, 0] + numericise = (\x y -> if x then 2^y else 0) + to_bool 0 _ = [] + to_bool n i = ((i .&. 8) == 8):to_bool (n-1) (shiftL i 1) + +s_box_1 :: Bits6 -> Bits4 +s_box_1 = s_box i + where i = [[14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7], + [ 0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8], + [ 4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0], + [15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13]] + +s_box_2 :: Bits6 -> Bits4 +s_box_2 = s_box i + where i = [[15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10], + [3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5], + [0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15], + [13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9]] + +s_box_3 :: Bits6 -> Bits4 +s_box_3 = s_box i + where i = [[10, 0, 9, 14 , 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8], + [13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1], + [13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7], + [1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12]] + +s_box_4 :: Bits6 -> Bits4 +s_box_4 = s_box i + where i = [[7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15], + [13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9], + [10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4], + [3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14]] + +s_box_5 :: Bits6 -> Bits4 +s_box_5 = s_box i + where i = [[2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9], + [14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6], + [4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14], + [11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3]] + +s_box_6 :: Bits6 -> Bits4 +s_box_6 = s_box i + where i = [[12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11], + [10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8], + [9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6], + [4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13]] + +s_box_7 :: Bits6 -> Bits4 +s_box_7 = s_box i + where i = [[4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1], + [13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6], + [1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2], + [6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12]] + +s_box_8 :: Bits6 -> Bits4 +s_box_8 = s_box i + where i = [[13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7], + [1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2], + [7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8], + [2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11]] + +p_box :: Bits32 -> Bits32 +p_box kb = map ((!!) kb) i + where i = [15, 6, 19, 20, 28, 11, 27, 16, 0, 14, 22, 25, 4, 17, 30, 9, + 1, 7, 23, 13, 31, 26, 2, 8, 18, 12, 29, 5, 21, 10, 3, 24] + +final_perm :: Bits64 -> Bits64 +final_perm kb = map ((!!) kb) i + where i = [39, 7, 47, 15, 55, 23, 63, 31, 38, 6, 46, 14, 54, 22, 62, 30, + 37, 5, 45, 13, 53, 21, 61, 29, 36, 4, 44, 12, 52, 20, 60, 28, + 35, 3, 43, 11, 51, 19, 59, 27, 34, 2, 42, 10, 50, 18, 58, 26, + 33, 1, 41, 9, 49, 17, 57, 25, 32, 0, 40 , 8, 48, 16, 56, 24] + +takeDrop :: Int -> [a] -> ([a], [a]) +takeDrop _ [] = ([], []) +takeDrop 0 xs = ([], xs) +takeDrop n (x:xs) = (x:ys, zs) + where (ys, zs) = takeDrop (n-1) xs + diff --git a/Codec/Encryption/Modes.hs b/Codec/Encryption/Modes.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/Modes.hs @@ -0,0 +1,61 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.Modes +-- Copyright : (c) Dominic Steinitz 2001-2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- This module currently supports Cipher Block Chaining (CBC) mode. +-- See for further details. +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.Modes ( + -- * Function types + cbc, unCbc + ) where + +import Data.Word +import Data.Bits + +-- * CBC or Cipher Block Chaining Mode + +-- | In CBC or Cipher Block Chaining mode each block is XORed with +-- the previous enciphered block before encryption. For the first +-- block, start with an initialization vector. +-- Take an encryption function, an initialisation vector, a key and +-- a list of blocks and return the encrypted blocks using CBC. + +cbc :: Bits block => + (key -> block -> block) -> + block -> + key -> + [block] -> + [block] + +cbc e iv k ps = + ciphers where + ciphers = map (e k) feedIns + feedIns = zipWith xor (iv : ciphers) ps + +-- | To decipher in CBC or Cipher Block Chaining mode, decipher +-- each block, then XOR the result with the previous block of +-- plaintext result. Note that the initialization vector is treated as the +-- zeroth block of plaintext. +-- Take a decryption function, an initialisation vector, a key and a list +-- of encrypted blocks using CBC and return plaintext blocks. + +unCbc :: Bits block => + (key -> block -> block) -> + block -> + key -> + [block] -> + [block] + +unCbc d iv k ms = + outOfCbcs where + beforeXOrs = map (d k) ms + outOfCbcs = zipWith xor (iv : ms) beforeXOrs diff --git a/Codec/Encryption/Padding.hs b/Codec/Encryption/Padding.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/Padding.hs @@ -0,0 +1,108 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.Padding +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Padding algorithms for use with block ciphers. +-- +-- This module currently supports: +-- +-- * PKCS5 padding and unpadding. +-- +-- * Null padding and unpadding. +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.Padding ( + -- * Function types + pkcs5, unPkcs5, + padNulls, unPadNulls + ) where + +import Data.Word +import Data.Bits +import Data.List +import Codec.Utils + +-- | When the last block of plaintext is shorter than the block size then it +-- must be padded. PKCS5 specifies that the padding octets should each +-- contain the number of octets which must be stripped off. So, for example, +-- with a block size of 8, \"0a0b0c\" will be padded with \"05\" resulting in +-- \"0a0b0c0505050505\". If the final block is a full block of 8 octets +-- then a whole block of \"0808080808080808\" is appended. + +pkcs5 :: (Integral a, Bits a) => [Octet] -> [a] +pkcs5 s = pad p s where p n = replicate n (fromIntegral n) + +-- | When the last block of plaintext is shorter than the block size then it +-- must be padded. Nulls padding specifies that the padding octets should each +-- contain a null. So, for example, +-- with a block size of 8, \"0a0b0c\" will be padded to +-- \"0a0b0c0000000000\". If the final block is a full block of 8 octets +-- then a whole block of \"0000000000000000\" is appended. +-- NB this is only suitable for data which does not contain nulls, +-- for example, ASCII. + +padNulls :: (Integral a, Bits a) => [Octet] -> [a] +padNulls s = pad p s where p n = replicate n 0 + +testPad s = pad p s where p n = replicate (n-1) 0xff ++ [fromIntegral n] + +pad p s = + blocks where + octetSize = (bitSize $ head blocks) `div` 8 + blocks = map (fromOctets 256) (unfoldr h $ concat $ unfoldr g s) + g :: [Octet] -> Maybe ([Octet],[Octet]) + g x + | l == 0 = Nothing + | l < octetSize = Just (t ++ (p (octetSize-l)), []) + | d == [] = Just (t ++ (p octetSize), []) + | otherwise = Just (t, d) + where l = length t + t = take octetSize x + d = drop octetSize x + h :: [Octet] -> Maybe ([Octet],[Octet]) + h x + | x == [] = Nothing + | otherwise = Just (take octetSize x, drop octetSize x) + +-- | Take a list of blocks padded using the method described in PKCS5 +-- (see ) +-- and return the list of unpadded octets. NB this function does not +-- currently check that the padded block is correctly formed and should +-- only be used for blocks that have been padded correctly. + +unPkcs5 :: (Bits a, Integral a) => [a] -> [Octet] +unPkcs5 s = + unPad h s + where + h octetSize x = take (octetSize - (fromIntegral (last x))) x + +-- | Take a list of blocks padded with nulls +-- and return the list of unpadded octets. NB if the blocks contain +-- a null then the result is unpredictable. + +unPadNulls :: (Bits a, Integral a) => [a] -> [Octet] +unPadNulls s = + unPad h s + where + h _ x = takeWhile (/=0) x + +unPad p s = + concat $ unfoldr g s where + g :: (Integral a, Bits a) => [a] -> Maybe ([Octet],[a]) + g x + | t == [] = Nothing + | d == [] = Just (s, []) + | otherwise = Just (v, d) + where t = take 1 x + d = drop 1 x + u = head t + octetSize = (bitSize u) `div` 8 + v = i2osp octetSize u + s = p octetSize v diff --git a/Codec/Encryption/RSA.hs b/Codec/Encryption/RSA.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/RSA.hs @@ -0,0 +1,79 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Coded.Encryption.RSA +-- Copyright : (c) David J. Sankel 2003, Dominic Steinitz 2003 +-- License : GPL (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- A modified version of the RSA module supplied by David J. Sankel +-- (). +-- +-- As the original code is GPL, this has to be. +-- This code is free software; you can redistribute it and\/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This code is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this code; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111\-1307 USA +----------------------------------------------------------------------------- + +module Codec.Encryption.RSA( + -- * Function Types + encrypt, + decrypt + )where + +import Codec.Utils +import Codec.Encryption.RSA.NumberTheory + +rsaep :: (Integer , Integer) -> Integer -> Integer +rsaep (n,e) m + | m < 0 || m > n-1 = + error "Codec.Encryption.RSA.rsaep: message too long" + | otherwise = + expmod m e n + +-- | Take the modulus of the RSA key and the public exponent expressed +-- as lists of octets and the plaintext also expressed as a list of +-- octets and return the ciphertext as a list of octets. Of course, +-- these are all large integers but using lists of octets makes +-- everything easier. See +-- for more +-- details. + +encrypt :: ([Octet],[Octet]) -> [Octet] -> [Octet] +encrypt (n,e) m = + i2osp (length n) $ + rsaep (fromOctets 256 n, fromOctets 256 e) (fromOctets 256 m) + +rsadp :: (Integer , Integer) -> Integer -> Integer +rsadp (n,d) c + | c < 0 || c > n-1 = + error "Codec.Encryption.RSA.rsadp: decryption error" + | otherwise = + expmod c d n + +-- | Take the modulus of the RSA key and the private exponent expressed +-- as lists of octets and the ciphertext also expressed as a list of +-- octets and return the plaintext as a list of octets. + +decrypt :: ([Octet],[Octet]) -> [Octet] -> [Octet] +decrypt (n,e) m + | lc > lm = + error "Codec.Encryption.RSA.rsadp: decryption error" + | otherwise = + i2osp (length n) $ + rsadp (fromOctets 256 n, fromOctets 256 e) (fromOctets 256 m) + where + lc = length $ dropWhile (==0x00) m + lm = length $ dropWhile (==0x00) n diff --git a/Codec/Encryption/RSA/EMEOAEP.hs b/Codec/Encryption/RSA/EMEOAEP.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/RSA/EMEOAEP.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Coded.Encryption.RSA.EMEOAEP +-- Copyright : (c) David J. Sankel 2003, Dominic Steinitz 2003 +-- License : GPL (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- A modified version of the EMEOAEP module supplied by David J. Sankel +-- (). +-- +-- As the original code is GPL, this has to be. +-- This code is free software; you can redistribute it and\/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- This code is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this code; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111\-1307 USA +----------------------------------------------------------------------------- + +module Codec.Encryption.RSA.EMEOAEP( + -- * Function Types + encode, + decode + )where + +import Codec.Utils (Octet) +import Data.Bits + +xorOctets :: Bits a => [a] -> [a] -> [a] +xorOctets = zipWith xor + +-- | Take a mask generating function, a hash function, a label (which may be +-- null), a random seed, the modulus of the key and the message and returns +-- an encoded message. NB you could pass in the length of the modulus +-- but it seems safer to pass in the modulus itself and calculate the +-- length when required. See +-- for more +-- details. + +encode :: (([Octet] -> [Octet]) -> [Octet] -> Int -> [Octet]) -> + ([Octet] -> [Octet]) -> [Octet] -> [Octet] -> [Octet] -> [Octet] -> + [Octet] + +encode mgf hash p seed n m = + if length m > emLen - 2*hLen - 2 + then error "Codec.Encryption.EMEOAEP.encode: message too long" + else em + where + emLen = length n + mLen = length m + ps = take (emLen-mLen-2*hLen-2) $ repeat $ 0x00 + pHash = hash p + hLen = length pHash + db = pHash ++ ps ++ [0x01] ++ m + dbMask = mgf hash seed (length db) + maskedDB = db `xorOctets` dbMask + seedMask = mgf hash maskedDB hLen + maskedSeed = seed `xorOctets` seedMask + em = [0x00] ++ maskedSeed ++ maskedDB + +-- | Take a mask generating function, a hash function, a label (which may be +-- null) and the message and returns the decoded. + +decode :: (([Octet] -> [Octet]) -> [Octet] -> Int -> [Octet]) -> + ([Octet] -> [Octet]) -> [Octet] -> [Octet] -> [Octet] + +decode mgf hash p em = + if length em < 2*hLen + 1 || + one /= 0x01 || + pHash' /= pHash || + y /= [0x00] + then error "Codec.Encryption.EMEOAEP.decode: decryption error" + else m + where + (y,rest) = splitAt 1 em + pHash = hash p + hLen = length pHash + (maskedSeed,maskedDB) = splitAt hLen rest + seedMask = mgf hash maskedDB hLen + seed = maskedSeed `xorOctets` seedMask + emLen = length em + dbMask = mgf hash seed (emLen - hLen - 1) + db = maskedDB `xorOctets` dbMask + (pHash',rest') = splitAt hLen db + (one:m) = dropWhile (== 0x00) rest' diff --git a/Codec/Encryption/RSA/MGF.hs b/Codec/Encryption/RSA/MGF.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/RSA/MGF.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Encryption.RSA.MGF +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Implements the mask generation function as specified in: +-- +-- +----------------------------------------------------------------------------- + +module Codec.Encryption.RSA.MGF ( + -- * Function Types + mgf) where + +import Codec.Utils (Octet, i2osp) + +-- | Take a hash function, a seed and the intended length of the +-- the mask and deliver a mask of the requested length. + +mgf :: ([Octet] -> [Octet]) -> [Octet] -> Int -> [Octet] + +mgf hash z l = + take l $ concat $ hashes + where + hashes = map f [0..(l `div` hLen)] + hLen = length $ f 0 + f = hash . (z++) . (i2osp 4) diff --git a/Codec/Encryption/RSA/NumberTheory.hs b/Codec/Encryption/RSA/NumberTheory.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/RSA/NumberTheory.hs @@ -0,0 +1,203 @@ +--Copyright 2001, 2002, 2003 David J. Sankel +-- +--This file is part of rsa-haskell. +--rsa-haskell is free software; you can redistribute it and/or modify +--it under the terms of the GNU General Public License as published by +--the Free Software Foundation; either version 2 of the License, or +--(at your option) any later version. +-- +--rsa-haskell is distributed in the hope that it will be useful, +--but WITHOUT ANY WARRANTY; without even the implied warranty of +--MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +--GNU General Public License for more details. +-- +--You should have received a copy of the GNU General Public License +--along with rsa-haskell; if not, write to the Free Software +--Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +module Codec.Encryption.RSA.NumberTheory( +inverse, extEuclGcd, simplePrimalityTest, getPrime, pg, isPrime, +rabinMillerPrimalityTest, expmod, factor, testInverse, primes, (/|), +randomOctet +) where + + +import System.Random(getStdRandom,randomR) +--The following line is required for ghc optomized implementation +-- (see comments beginning with GHC): +-- import Bits(setBit) +import Data.List(elemIndex) +import Data.Maybe(fromJust) +import Data.Char(chr,ord) +import Data.Bits(xor) + +--Precondition: the integer is >= 0 +randomOctet :: Int -> IO( String ) +randomOctet n + | n < 0 = error "randomOctet argument doesn't meet preconditions" + | otherwise = (sequence $ take n $ repeat $ getStdRandom (randomR( 0,255) )) + >>= (return . (map chr) ) + +--Returns a list [r_1,r_2,r_3,r_4, . . ., r_n ] where +-- a = p_1^r_1 * p_2^r_2 * p_3^r_3 * . . . * p_n^r_n +factor :: Integer -> [Int] +factor = factor_1 + +--An implimentation of factor +factor_1 :: Integer -> [Int] +factor_1 a = reverse . dropWhile (== 0) . reverse + . map (\x -> largestPower x a) . takeWhile (<= a ) $ primes + +--Another implimentation of factor +factor_2 :: Integer -> [Integer] +factor_2 a = + let + p = map (fromIntegral) . reverse . dropWhile (== 0) + . reverse . map (\x -> largestPower x a) + . takeWhile (<= a `div` 2) $ primes + in + if (length p == 0) + then (take ((fromIntegral . fromJust $ elemIndex a primes)-1) (repeat 0)) + ++ [1] + else p + +--Find the inverse of x (mod n) +inverse :: Integer -> Integer -> Integer +inverse x n = (fst (extEuclGcd x n)) `mod` n + +testInverse :: Integer ->Integer -> Bool +testInverse a b = ((inverse a b)*a) `mod` b == 1 + +--Extended Eucildean algorithm +--Returns (x,y) where gcd(a,b) = xa + yb +extEuclGcd :: Integer -> Integer -> (Integer,Integer) +extEuclGcd a b = extEuclGcd_iter a b (1,0) (0,1) + +extEuclGcd_iter :: Integer -> Integer + -> (Integer,Integer) -> (Integer,Integer) -> (Integer,Integer) +extEuclGcd_iter a b (c1,c2) (d1,d2) + | (a > b) && (r1 == 0) = (d1,d2) + | (a > b) && (r1 /= 0) = extEuclGcd_iter + (a - (q1*b)) b (c1 - (q1*d1), c2 - (q1*d2)) (d1,d2) + | (a <= b) && (r2 == 0) = (c1,c2) + | (a <= b) && (r2 /= 0) = extEuclGcd_iter + a (b - (q2*a)) (c1,c2) ( d1 - (q2*c1), d2- (q2*c2)) + where + q1 = a `div` b + q2 = b `div` a + r1 = a `mod` b + r2 = b `mod` a + +-- This will return a random Integer of n bits. The highest order bit +-- will always be 1. + +-- GHC optomized implementation +-- getNumber :: Int -> IO Integer +-- getNumber n = do +-- i <- getStdRandom ( randomR (0, a-1 ) ) +-- return (setBit i (n-1)) +-- where +-- a = (2^n) ::Integer + +--This is the portable version +getNumber :: Int -> IO Integer +getNumber n = do + i <- getStdRandom ( randomR (0, a-1 ) ) + return (i+(2^(n-1))) + where + a = (2^(n-1)) ::Integer + +--Returns a probable prime number of nBits bits + +-- GHC optomized implementation +-- getPrime :: Int -> IO Integer +-- getPrime nBits = do +-- r <- getNumber nBits +-- let p = (setBit r 0) --Make it odd for speed +-- pIsPrime <- isPrime p +-- if( pIsPrime ) +-- then return p +-- else getPrime nBits + +--This is the portable version +getPrime :: Int -> IO Integer +getPrime nBits = do + r <- getNumber nBits + let p = if( 2 /| r ) then r else r+1 + pIsPrime <- isPrime p + if( pIsPrime ) + then return p + else getPrime nBits + +--Prime Generate: +--Generates a prime p | minimum <= p <= maximum and gcd p e == 1 +pg :: Integer -> Integer -> Integer -> IO(Integer) +pg minimum maximum e = do + p <- getStdRandom( randomR( minimum, maximum ) ) + pIsPrime <- isPrime p + if( pIsPrime && (gcd p e) == 1 ) + then return p + else pg minimum maximum e + +isPrime :: Integer -> IO Bool +isPrime a + | (a <= 1) = return False + | (a <= 2000) = return (simplePrimalityTest a) + | otherwise = if (simplePrimalityTest a) + then do --Do this 5 times for saftey + test <- mapM rabinMillerPrimalityTest $ take 5 $ repeat a + return (and test) + else return False + +simplePrimalityTest :: Integer -> Bool +simplePrimalityTest a = foldr (&&) True (map (/| a)(takeWhile ( Integer -> Int +largestPower x y = fromJust . elemIndex False + . map (\b -> (y `mod` x^b) == 0) $ [1..] + +rabinMillerPrimalityTest :: Integer -> IO Bool +rabinMillerPrimalityTest p = rabinMillerPrimalityTest_iter_1 p b m + where + b = fromIntegral $ largestPower 2 (p-1) + m = (p-1) `div` (2^b) + +--The ?prime? Number -> The amount of iterations -> b -> m +rabinMillerPrimalityTest_iter_1 :: Integer -> Integer -> Integer -> IO Bool +rabinMillerPrimalityTest_iter_1 p b m = + do + a <- getStdRandom ( randomR (0, 2000 ) ) + return (rabinMillerPrimalityTest_iter_2 p b 0 (expmod a m p)) + +rabinMillerPrimalityTest_iter_2 :: Integer -> Integer -> Integer -> Integer + -> Bool +rabinMillerPrimalityTest_iter_2 p b j z + | (z == 1) || (z == p-1) = True + | (j > 0) && (z == 1) = False + | (j+1 < b) && (z /= p-1) = + (rabinMillerPrimalityTest_iter_2 p b (j+1) ((z^2) `mod` p )) + | z == p - 1 = True + | (j+1 == b) && (z /= p-1) = False + +--a^x (mod m) +expmod :: Integer -> Integer -> Integer -> Integer +expmod a x m | x == 0 = 1 + | x == 1 = a `mod` m + | even x = let p = (expmod a (x `div` 2) m) `mod` m + in (p^2) `mod` m + | otherwise = (a * expmod a (x-1) m) `mod` m + +--Largest x where x^2 < i +intSqrt :: Integer -> Integer +intSqrt i = floor (sqrt (fromIntegral i ) ) + +--The doesn't divide function +(/|) :: Integer -> Integer -> Bool +a /| b = b `mod` a /= 0 + +--List of primes +primes :: [Integer] +primes = 2:[x | x <- [3,5..], foldr (&&) True + ( map ( /| x ) (takeWhile (<=(intSqrt x)) primes ) ) ] diff --git a/Codec/Text/Raw.hs b/Codec/Text/Raw.hs new file mode 100644 --- /dev/null +++ b/Codec/Text/Raw.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Coded.Text.Raw +-- Copyright : (c) Dominic Steinitz 2006 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +----------------------------------------------------------------------------- + +module Codec.Text.Raw( + hexdump + ) where + +import Data.List +import Codec.Utils +import Numeric +import Text.PrettyPrint + +split :: Int -> [a] -> [[a]] +split n xs = unfoldr (g n) xs + +g :: Int -> [a] -> Maybe ([a],[a]) +g n [] = Nothing +g n y = Just (splitAt n y) + +sh x | x < 16 = '0':(showHex x "") + | otherwise = showHex x "" + +type OctetsPerLine = Int + +hexdump :: OctetsPerLine -> [Octet] -> Doc +hexdump n = + vcat . + map hcat . + map (intersperse colon) . + map (map (text . sh)) . + split n diff --git a/Codec/Utils.hs b/Codec/Utils.hs new file mode 100644 --- /dev/null +++ b/Codec/Utils.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Utils +-- Copyright : (c) Dominic Steinitz 2003 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Utilities for coding and decoding. +-- +----------------------------------------------------------------------------- + +module Codec.Utils ( + -- * Types and Constants + Octet, + msb, + -- * Octet Conversion Functions + fromTwosComp, toTwosComp, + toOctets, fromOctets, + i2osp + ) where + +import Data.Word +import Data.Bits + +powersOf n = 1 : (map (*n) (powersOf n)) + +toBase x = + map fromIntegral . + reverse . + map (flip mod x) . + takeWhile (/=0) . + iterate (flip div x) + +-- | Take a number a convert it to base n as a list of octets. + +toOctets :: (Integral a, Integral b) => a -> b -> [Octet] +toOctets n x = (toBase n . fromIntegral) x + +-- | The basic type for encoding and decoding. + +type Octet = Word8 + +-- | The most significant bit of an 'Octet'. + +msb :: Int +msb = bitSize (undefined::Octet) - 1 + +-- | Take a list of octets (a number expressed in base n) and convert it +-- to a number. + +fromOctets :: (Integral a, Integral b) => a -> [Octet] -> b +fromOctets n x = + fromIntegral $ + sum $ + zipWith (*) (powersOf n) (reverse (map fromIntegral x)) + +-- | Take the length of the required number of octets and convert the +-- number to base 256 padding it out to the required length. If the +-- required length is less than the number of octets of the converted +-- number then return the converted number. NB this is different from +-- the standard +-- but mimics how replicate behaves. + +i2osp :: Integral a => Int -> a -> [Octet] +i2osp l y = + pad ++ z + where + pad = replicate (l - unPaddedLen) (0x00::Octet) + z = toOctets 256 y + unPaddedLen = length z + +-- | Convert from twos complement. + +fromTwosComp :: Integral a => [Octet] -> a +fromTwosComp x = conv x + where conv [] = 0 + conv w@(x:xs) = if (testBit x msb) + then neg w + else pos w + neg w@(x:xs) = let z=(clearBit x msb):xs in + fromIntegral((fromOctets 256 z)- + (128*(256^((length w)-1)))) + pos w = fromIntegral(fromOctets 256 w) + +toTwosComp :: Integral a => a -> [Octet] +toTwosComp x + | x < 0 = reverse . plusOne . reverse . (map complement) $ u + | x == 0 = [0x00] + | otherwise = u + where z@(y:ys) = toBase 256 (abs x) + u = if testBit y msb + then 0x00:z + else z + +plusOne :: [Octet] -> [Octet] +plusOne [] = [1] +plusOne (x:xs) = + if x == 0xff + then 0x00:(plusOne xs) + else (x+1):xs diff --git a/Crypto.cabal b/Crypto.cabal new file mode 100644 --- /dev/null +++ b/Crypto.cabal @@ -0,0 +1,131 @@ +Name: Crypto +Version: 3.0.3 +License: OtherLicense +License-File: ReadMe.tex +Author: Dominic Steinitz +Maintainer: dominic.steinitz@blueyonder.co.uk +Copyright: Dominic Steinitz 2003 - 2006 +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 + 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, + Codec.Encryption.RSA, + Codec.Encryption.RSA.EMEOAEP, + Codec.Encryption.RSA.MGF, + Codec.Encryption.RSA.NumberTheory, + Codec.Encryption.DES, + Codec.Encryption.AES, + Codec.Encryption.Blowfish, + Codec.Encryption.Modes, + Codec.Encryption.Padding, + Codec.Text.Raw, + Codec.Utils, + Data.Digest.MD5, + Data.Digest.SHA1, + Data.LargeWord +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: 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: 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: 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 diff --git a/Data/Digest/MD5.hs b/Data/Digest/MD5.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/MD5.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.MD5 +-- Copyright : (c) Dominic Steinitz 2004 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Takes the MD5 module supplied by Ian Lynagh and wraps it so it +-- takes [Octet] and returns [Octet] where the length of the result +-- is always 16. +-- See +-- and . +-- +----------------------------------------------------------------------------- + +module Data.Digest.MD5 ( + -- * Function Types + hash) where + +import Data.Digest.MD5Aux +import Codec.Utils +import Data.Char(chr) +import Data.List(unfoldr) +import Numeric(readHex) + +-- | Take [Octet] and return [Octet] according to the standard. +-- The length of the result is always 16 octets or 128 bits as required +-- by the standard. + +hash :: [Octet] -> [Octet] +hash xs = + unfoldr f $ md5s $ Str $ 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:[]) diff --git a/Data/Digest/MD5Aux.hs b/Data/Digest/MD5Aux.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/MD5Aux.hs @@ -0,0 +1,355 @@ +module Data.Digest.MD5Aux + (md5, md5s, md5i, + MD5(..), ABCD(..), + Zord64, Str(..), BoolList(..), WordList(..)) where + +import Data.Char +import Data.Bits +import Data.Word + +{- +Nasty kludge to create a type Zord64 which is really a Word64 but works +how we want in hugs ands nhc98 too... +Also need a rotate left function that actually works. + +#ifdef __GLASGOW_HASKELL__ +#define rotL rotateL +#include "Zord64_EASY.hs" +#else + +> import Zord64_HARD + +> rotL :: Word32 -> Rotation -> Word32 +> rotL a s = shiftL a s .|. shiftL a (s-32) + +#endif +-} + +rotL x = rotateL x +type Zord64 = Word64 + +-- ===================== TYPES AND CLASS DEFINTIONS ======================== + + +type XYZ = (Word32, Word32, Word32) +type Rotation = Int +newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) +newtype Str = Str String +newtype BoolList = BoolList [Bool] +newtype WordList = WordList ([Word32], Zord64) + +-- Anything we want to work out the MD5 of must be an instance of class MD5 + +class MD5 a where + get_next :: a -> ([Word32], Int, a) -- get the next blocks worth + -- \ \ \------ the rest of the input + -- \ \--------- the number of bits returned + -- \--------------- the bits returned in 32bit words + len_pad :: Zord64 -> a -> a -- append the padding and length + finished :: a -> Bool -- Have we run out of input yet? + + +-- Mainly exists because it's fairly easy to do MD5s on input where the +-- length is not a multiple of 8 + +instance MD5 BoolList where + get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) + where (ys, zs) = splitAt 512 s + len_pad l (BoolList bs) + = BoolList (bs ++ [True] + ++ replicate (fromIntegral $ (447 - l) .&. 511) False + ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] + ) + where mangle [] = [] + mangle xs = reverse ys ++ mangle zs + where (ys, zs) = splitAt 8 xs + finished (BoolList s) = s == [] + + +-- The string instance is fairly straightforward + +instance MD5 Str where + get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) + where (ys, zs) = splitAt 64 s + len_pad c64 (Str s) = Str (s ++ padding ++ l) + where padding = '\128':replicate (fromIntegral zeros) '\000' + zeros = shiftR ((440 - c64) .&. 511) 3 + l = length_to_chars 8 c64 + finished (Str s) = s == "" + + +-- YA instance that is believed will be useful + +instance MD5 WordList where + get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) + where (xs, ys) = splitAt 16 ws + taken = if l > 511 then 512 else l .&. 511 + len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) + where beginning = if length ws > 0 then start ++ lastone' else [] + start = init ws + lastone = last ws + offset = c64 .&. 31 + lastone' = [if offset > 0 then lastone + theone else lastone] + theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) + (fromIntegral $ offset .&. (31 - 7)) + nextish = if offset == 0 then [128] else [] + c64' = c64 + (32 - offset) + num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) + blanks = replicate num_blanks 0 + lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) + topsize = fromIntegral $ shiftR c64 32 + size = [lowsize, topsize] + newlen = l .&. (complement 511) + + if c64 .&. 511 >= 448 then 1024 else 512 + finished (WordList (_, z)) = z == 0 + + +instance Num ABCD where + ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + + +-- ===================== EXPORTED FUNCTIONS ======================== + + +-- The simplest function, gives you the MD5 of a string as 4-tuple of +-- 32bit words. + +md5 :: (MD5 a) => a -> ABCD +md5 m = md5_main False 0 magic_numbers m + + +-- Returns a hex number ala the md5sum program + +md5s :: (MD5 a) => a -> String +md5s = abcd_to_string . md5 + + +-- Returns an integer equivalent to the above hex number + +md5i :: (MD5 a) => a -> Integer +md5i = abcd_to_integer . md5 + + +-- ===================== THE CORE ALGORITHM ======================== + + +-- Decides what to do. The first argument indicates if padding has been +-- added. The second is the length mod 2^64 so far. Then we have the +-- starting state, the rest of the string and the final state. + +md5_main :: (MD5 a) => + Bool -- Have we added padding yet? + -> Zord64 -- The length so far mod 2^64 + -> ABCD -- The initial state + -> a -- The non-processed portion of the message + -> ABCD -- The resulting state +md5_main padded ilen abcd m + = if finished m && padded + then abcd + else md5_main padded' (ilen + 512) (abcd + abcd') m'' + where (m16, l, m') = get_next m + len' = ilen + fromIntegral l + ((m16', _, m''), padded') = if not padded && l < 512 + then (get_next $ len_pad len' m, True) + else ((m16, l, m'), padded) + abcd' = md5_do_block abcd m16' + + +-- md5_do_block processes a 512 bit block by calling md5_round 4 times to +-- apply each round with the correct constants and permutations of the +-- block + +md5_do_block :: ABCD -- Initial state + -> [Word32] -- The block to be processed - 16 32bit words + -> ABCD -- Resulting state +md5_do_block abcd0 w = abcd4 + where (r1, r2, r3, r4) = rounds + {- + map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] + -- [(5 * x + 1) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] + -- [(3 * x + 5) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] + -- [(7 * x) `mod` 16 | x <- [0..15]] + -} + perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] + perm5 _ = error "broke at perm5" + perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] + perm3 _ = error "broke at perm3" + perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] + perm7 _ = error "broke at perm7" + abcd1 = md5_round md5_f abcd0 w r1 + abcd2 = md5_round md5_g abcd1 (perm5 w) r2 + abcd3 = md5_round md5_h abcd2 (perm3 w) r3 + abcd4 = md5_round md5_i abcd3 (perm7 w) r4 + + +-- md5_round does one of the rounds. It takes an auxiliary function and foldls +-- (md5_inner_function f) to repeatedly apply it to the initial state with the +-- correct constants + +md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I + -- for those of you with a copy of + -- the prayer book^W^WRFC) + -> ABCD -- Initial state + -> [Word32] -- The 16 32bit words of input + -> [(Rotation, Word32)] -- The list of 16 rotations and + -- additive constants + -> ABCD -- Resulting state +md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' + where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns + + +-- Apply one of the functions md5_[fghi] and put the new ABCD together + +md5_inner_function :: (XYZ -> Word32) -- Auxiliary function + -> ABCD -- Initial state + -> (Rotation, Word32) -- The rotation and additive + -- constant (X[i] + T[j]) + -> ABCD -- Resulting state +md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) + where mid_a = a + f(b,c,d) + ki + rot_a = rotL mid_a s + a' = b + rot_a + + +-- The 4 auxiliary functions + +md5_f :: XYZ -> Word32 +md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) +{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} + +md5_g :: XYZ -> Word32 +md5_g (x, y, z) = md5_f (z, x, y) +{- was: (x .&. z) .|. (y .&. (complement z)) -} + +md5_h :: XYZ -> Word32 +md5_h (x, y, z) = x `xor` y `xor` z + +md5_i :: XYZ -> Word32 +md5_i (x, y, z) = y `xor` (x .|. (complement z)) + + +-- The magic numbers from the RFC. + +magic_numbers :: ABCD +magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) + + +-- The 4 lists of (rotation, additive constant) tuples, one for each round + +rounds :: ([(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)]) +rounds = (r1, r2, r3, r4) + where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), + (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), + (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), + (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), + (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), + (s14, 0x49b40821)] + r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), + (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), + (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), + (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), + (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), + (s24, 0x8d2a4c8a)] + r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), + (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), + (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), + (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), + (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), + (s34, 0xc4ac5665)] + r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), + (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), + (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), + (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), + (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), + (s44, 0xeb86d391)] + s11 = 7 + s12 = 12 + s13 = 17 + s14 = 22 + s21 = 5 + s22 = 9 + s23 = 14 + s24 = 20 + s31 = 4 + s32 = 11 + s33 = 16 + s34 = 23 + s41 = 6 + s42 = 10 + s43 = 15 + s44 = 21 + + +-- ===================== CONVERSION FUNCTIONS ======================== + + +-- Turn the 4 32 bit words into a string representing the hex number they +-- represent. + +abcd_to_string :: ABCD -> String +abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] + + +-- Split the 32 bit word up, swap the chunks over and convert the numbers +-- to their hex equivalents. + +display_32bits_as_hex :: Word32 -> String +display_32bits_as_hex w = swap_pairs cs + where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] + getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) + swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs + swap_pairs _ = [] + +-- Convert to an integer, performing endianness magic as we go + +abcd_to_integer :: ABCD -> Integer +abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) + + rev_num b * 2^(64 :: Int) + + rev_num c * 2^(32 :: Int) + + rev_num d + +rev_num :: Word32 -> Integer +rev_num i = toInteger j `mod` (2^(32 :: Int)) + -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ + where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) + 0 [0,8,16,24] + +-- Used to convert a 64 byte string to 16 32bit words + +string_to_word32s :: String -> [Word32] +string_to_word32s "" = [] +string_to_word32s ss = this:string_to_word32s ss' + where (s, ss') = splitAt 4 ss + this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s + + +-- Used to convert a list of 512 bools to 16 32bit words + +bools_to_word32s :: [Bool] -> [Word32] +bools_to_word32s [] = [] +bools_to_word32s bs = this:bools_to_word32s rest + where (bs1, bs1') = splitAt 8 bs + (bs2, bs2') = splitAt 8 bs1' + (bs3, bs3') = splitAt 8 bs2' + (bs4, rest) = splitAt 8 bs3' + this = boolss_to_word32 [bs1, bs2, bs3, bs4] + bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 + boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 + + +-- Convert the size into a list of characters used by the len_pad function +-- for strings + +length_to_chars :: Int -> Zord64 -> String +length_to_chars 0 _ = [] +length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) + where this = chr $ fromIntegral $ n .&. 255 + diff --git a/Data/Digest/SHA1.hs b/Data/Digest/SHA1.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/SHA1.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.SHA1 +-- Copyright : (c) Dominic Steinitz 2003 +-- 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 . +-- +----------------------------------------------------------------------------- + +module Data.Digest.SHA1 ( + -- * Function Types + hash) where + +import Data.Digest.SHA1Aux +import Codec.Utils +import Data.Char(chr) +import Data.List(unfoldr) +import Numeric(readHex) + +-- | 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. + +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:[]) diff --git a/Data/Digest/SHA1Aux.hs b/Data/Digest/SHA1Aux.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/SHA1Aux.hs @@ -0,0 +1,106 @@ +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/LargeWord.hs b/Data/LargeWord.hs new file mode 100644 --- /dev/null +++ b/Data/LargeWord.hs @@ -0,0 +1,135 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.LargeWord +-- Copyright : (c) Dominic Steinitz 2004 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Provides Word128, Word192 and Word256 and a way of producing other +-- large words if required. +-- +----------------------------------------------------------------------------- + +module Data.LargeWord + (Word128,Word192,Word256) where + +import Data.Word +import Data.Bits +import Numeric +import Data.Char + +-- Keys have certain capabilities. + +class LargeWord a where + largeWordToInteger :: a -> Integer + integerToLargeWord :: Integer -> a + largeWordPlus :: a -> a -> a + largeWordAnd :: a -> a -> a + largeWordOr :: a -> a -> a + largeWordShift :: a -> Int -> a + largeWordXor :: a -> a -> a + largeBitSize :: a -> Int + +-- Word64 is a key in the obvious way. + +instance LargeWord Word64 where + largeWordToInteger = toInteger + integerToLargeWord = fromInteger + largeWordPlus = (+) + largeWordAnd = (.&.) + largeWordOr = (.|.) + largeWordShift = shift + largeWordXor = xor + largeBitSize = bitSize + +-- Define larger keys from smaller ones. + +data LargeKey a b = LargeKey a b + deriving (Eq, Ord) + +instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => + LargeWord (LargeKey a b) where + largeWordToInteger (LargeKey lo hi) = + largeWordToInteger lo + (2^(bitSize lo)) * largeWordToInteger hi + integerToLargeWord x = + let (h,l) = x `quotRem` (2^(bitSize lo)) + (lo,hi) = (integerToLargeWord l, integerToLargeWord h) in + LargeKey lo hi + largeWordPlus (LargeKey alo ahi) (LargeKey blo bhi) = + LargeKey lo' hi' where + lo' = alo + blo + hi' = ahi + bhi + if lo' < alo then 1 else 0 + largeWordAnd (LargeKey alo ahi) (LargeKey blo bhi) = + LargeKey lo' hi' where + lo' = alo .&. blo + hi' = ahi .&. bhi + largeWordOr (LargeKey alo ahi) (LargeKey blo bhi) = + LargeKey lo' hi' where + lo' = alo .|. blo + hi' = ahi .|. bhi + largeWordXor (LargeKey alo ahi) (LargeKey blo bhi) = + LargeKey lo' hi' where + lo' = alo `xor` blo + hi' = ahi `xor` bhi + largeWordShift w 0 = w + largeWordShift (LargeKey lo hi) x = + if bitSize lo < bitSize hi + then LargeKey (shift lo x) + (shift hi x .|. (shift (conv lo) (x - (bitSize lo)))) + else LargeKey (shift lo x) + (shift hi x .|. (conv $ shift lo (x - (bitSize lo)))) + where conv = integerToLargeWord . largeWordToInteger + largeBitSize ~(LargeKey lo hi) = largeBitSize lo + largeBitSize hi + +instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => Show (LargeKey a b) where + showsPrec p = showInt . largeWordToInteger + +instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => + Num (LargeKey a b) where + (+) = largeWordPlus + fromInteger = integerToLargeWord + +-- Larger keys are instances of Bits provided their constituents are keys. + +instance (Ord a, Bits a, LargeWord a, Bits b, LargeWord b) => + Bits (LargeKey a b) where + (.&.) = largeWordAnd + (.|.) = largeWordOr + xor = largeWordXor + shift = largeWordShift + bitSize = largeBitSize + +instance (Ord a, Bits a, Bounded a, Integral a, LargeWord a, + Bits b, Bounded b, Integral b, LargeWord b) => + Bounded (LargeKey a b) where + minBound = 0 + maxBound = + result where + result = + fromIntegral $ + (1 + fromIntegral (maxBound `asTypeOf` (boflk result)))* + (1 + fromIntegral (maxBound `asTypeOf` (aoflk result))) - 1 + +aoflk :: (LargeKey a b) -> a +aoflk = undefined +boflk :: (LargeKey a b) -> b +boflk = undefined + +instance (Ord a, Bits a, LargeWord a, Ord b, Bits b, LargeWord b) => + Integral (LargeKey a b) where + toInteger = largeWordToInteger + +instance (Ord a, Bits a, LargeWord a, Ord b, Bits b, LargeWord b) => + Real (LargeKey a b) + +instance Enum (LargeKey a b) + +type Word96 = LargeKey Word32 Word64 +type Word128 = LargeKey Word64 Word64 +type Word160 = LargeKey Word32 Word128 +type Word192 = LargeKey Word64 Word128 +type Word224 = LargeKey Word32 Word192 +type Word256 = LargeKey Word64 Word192 diff --git a/PKCS8Example.hs b/PKCS8Example.hs new file mode 100644 --- /dev/null +++ b/PKCS8Example.hs @@ -0,0 +1,117 @@ +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 new file mode 100644 --- /dev/null +++ b/QuickTest.hs @@ -0,0 +1,85 @@ +module Main where + +import Codec.Utils +import Codec.Encryption.Blowfish as Blowfish +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 +import Numeric +import Data.Char +import Test.QuickCheck + +instance Arbitrary Word8 where + arbitrary = + do n <- choose ((fromIntegral (minBound::Word8))::Int, + (fromIntegral (maxBound::Word8))::Int) + return (fromIntegral n) + +instance Arbitrary Word64 where + arbitrary = + do n <- choose ((fromIntegral (minBound::Word64))::Integer, + (fromIntegral (maxBound::Word64))::Integer) + return (fromIntegral n) + +instance Arbitrary Word128 where + arbitrary = + do n <- choose ((fromIntegral (minBound::Word128))::Integer, + (fromIntegral (maxBound::Word128))::Integer) + return (fromIntegral n) + +prop_decryptEncrypt k b = b == Blowfish.decrypt k (Blowfish.encrypt k b) + where types = (k :: Word8, b :: Word64) + +prop_AESIdempotent k b = b == AES.decrypt k (AES.encrypt k b) + where types = (k :: Word128, b :: Word128) + +prop_unCbcCbc iv k bs = + bs == (unPkcs5 $ unCbc Blowfish.decrypt iv k $ cbc Blowfish.encrypt iv k $ pkcs5 bs) + where types =(k :: Word8, iv :: Word64, bs :: [Octet]) + +prop_unPkcs5Pkcs5 os = + os == (unPkcs5 $ ((pkcs5 os)::[Word64])) + where types = (os :: [Octet]) + +prop_unNullsNulls os = + all (/=0) os ==> + os == (unPadNulls $ ((padNulls os)::[Word64])) + where types = (os :: [Octet]) + +prop_fromOctetsToOctets k n = + k >= 0 && n > 1 ==> + k == (fromOctets n $ toOctets n k) + where types = (k :: Int, n :: Word8) + +prop_unTwosCompTwosComp n = + n < (0) ==> + collect n $ + forAll g $ + \n -> n == (fromTwosComp $ toTwosComp n) + where types = (n::Int) + 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 + quickCheck prop_AESIdempotent + quickCheck prop_unCbcCbc + quickCheck prop_unPkcs5Pkcs5 + quickCheck prop_unNullsNulls + quickCheck prop_fromOctetsToOctets + quickCheck prop_unTwosCompTwosComp diff --git a/RSAEncryptionExample.hs b/RSAEncryptionExample.hs new file mode 100644 --- /dev/null +++ b/RSAEncryptionExample.hs @@ -0,0 +1,104 @@ +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 new file mode 100644 --- /dev/null +++ b/RSATest.hs @@ -0,0 +1,137 @@ +module Main(main) where + +import Codec.Utils +import Data.Digest.SHA1 +import Codec.Encryption.RSA.MGF +import Codec.Encryption.RSA.EMEOAEP +import Codec.Encryption.RSA +import Test.HUnit + +n :: [Octet] +n = + [0xbb, 0xf8, 0x2f, 0x09, 0x06, 0x82, 0xce, 0x9c, + 0x23, 0x38, 0xac, 0x2b, 0x9d, 0xa8, 0x71, 0xf7, + 0x36, 0x8d, 0x07, 0xee, 0xd4, 0x10, 0x43, 0xa4, + 0x40, 0xd6, 0xb6, 0xf0, 0x74, 0x54, 0xf5, 0x1f, + 0xb8, 0xdf, 0xba, 0xaf, 0x03, 0x5c, 0x02, 0xab, + 0x61, 0xea, 0x48, 0xce, 0xeb, 0x6f, 0xcd, 0x48, + 0x76, 0xed, 0x52, 0x0d, 0x60, 0xe1, 0xec, 0x46, + 0x19, 0x71, 0x9d, 0x8a, 0x5b, 0x8b, 0x80, 0x7f, + 0xaf, 0xb8, 0xe0, 0xa3, 0xdf, 0xc7, 0x37, 0x72, + 0x3e, 0xe6, 0xb4, 0xb7, 0xd9, 0x3a, 0x25, 0x84, + 0xee, 0x6a, 0x64, 0x9d, 0x06, 0x09, 0x53, 0x74, + 0x88, 0x34, 0xb2, 0x45, 0x45, 0x98, 0x39, 0x4e, + 0xe0, 0xaa, 0xb1, 0x2d, 0x7b, 0x61, 0xa5, 0x1f, + 0x52, 0x7a, 0x9a, 0x41, 0xf6, 0xc1, 0x68, 0x7f, + 0xe2, 0x53, 0x72, 0x98, 0xca, 0x2a, 0x8f, 0x59, + 0x46, 0xf8, 0xe5, 0xfd, 0x09, 0x1d, 0xbd, 0xcb] + +p :: [Octet] +p = [0xee, 0xcf, 0xae, 0x81, 0xb1, 0xb9, 0xb3, 0xc9, + 0x08, 0x81, 0x0b, 0x10, 0xa1, 0xb5, 0x60, 0x01, + 0x99, 0xeb, 0x9f, 0x44, 0xae, 0xf4, 0xfd, 0xa4, + 0x93, 0xb8, 0x1a, 0x9e, 0x3d, 0x84, 0xf6, 0x32, + 0x12, 0x4e, 0xf0, 0x23, 0x6e, 0x5d, 0x1e, 0x3b, + 0x7e, 0x28, 0xfa, 0xe7, 0xaa, 0x04, 0x0a, 0x2d, + 0x5b, 0x25, 0x21, 0x76, 0x45, 0x9d, 0x1f, 0x39, + 0x75, 0x41, 0xba, 0x2a, 0x58, 0xfb, 0x65, 0x99] + +q :: [Octet] +q = [0xc9, 0x7f, 0xb1, 0xf0, 0x27, 0xf4, 0x53, 0xf6, + 0x34, 0x12, 0x33, 0xea, 0xaa, 0xd1, 0xd9, 0x35, + 0x3f, 0x6c, 0x42, 0xd0, 0x88, 0x66, 0xb1, 0xd0, + 0x5a, 0x0f, 0x20, 0x35, 0x02, 0x8b, 0x9d, 0x86, + 0x98, 0x40, 0xb4, 0x16, 0x66, 0xb4, 0x2e, 0x92, + 0xea, 0x0d, 0xa3, 0xb4, 0x32, 0x04, 0xb5, 0xcf, + 0xce, 0x33, 0x52, 0x52, 0x4d, 0x04, 0x16, 0xa5, + 0xa4, 0x41, 0xe7, 0x00, 0xaf, 0x46, 0x15, 0x03] + +popTest = + TestCase ( + assertEqual "Product of Primes" + (fromOctets 256 n) + ((fromOctets 256 p)*(fromOctets 256 q)) + ) + +d :: [Octet] +d = [0xa5, 0xda, 0xfc, 0x53, 0x41, 0xfa, 0xf2, + 0x89, 0xc4, 0xb9, 0x88, 0xdb, 0x30, 0xc1, 0xcd, + 0xf8, 0x3f, 0x31, 0x25, 0x1e, 0x06, 0x68, 0xb4, + 0x27, 0x84, 0x81, 0x38, 0x01, 0x57, 0x96, 0x41, + 0xb2, 0x94, 0x10, 0xb3, 0xc7, 0x99, 0x8d, 0x6b, + 0xc4, 0x65, 0x74, 0x5e, 0x5c, 0x39, 0x26, 0x69, + 0xd6, 0x87, 0x0d, 0xa2, 0xc0, 0x82, 0xa9, 0x39, + 0xe3, 0x7f, 0xdc, 0xb8, 0x2e, 0xc9, 0x3e, 0xda, + 0xc9, 0x7f, 0xf3, 0xad, 0x59, 0x50, 0xac, 0xcf, + 0xbc, 0x11, 0x1c, 0x76, 0xf1, 0xa9, 0x52, 0x94, + 0x44, 0xe5, 0x6a, 0xaf, 0x68, 0xc5, 0x6c, 0x09, + 0x2c, 0xd3, 0x8d, 0xc3, 0xbe, 0xf5, 0xd2, 0x0a, + 0x93, 0x99, 0x26, 0xed, 0x4f, 0x74, 0xa1, 0x3e, + 0xdd, 0xfb, 0xe1, 0xa1, 0xce, 0xcc, 0x48, 0x94, + 0xaf, 0x94, 0x28, 0xc2, 0xb7, 0xb8, 0x88, 0x3f, + 0xe4, 0x46, 0x3a, 0x4b, 0xc8, 0x5b, 0x1c, 0xb3, + 0xc1] + +dP :: [Octet] +dP = [0x54, 0x49, 0x4c, 0xa6, 0x3e, 0xba, 0x03, 0x37, + 0xe4, 0xe2, 0x40, 0x23, 0xfc, 0xd6, 0x9a, 0x5a, + 0xeb, 0x07, 0xdd, 0xdc, 0x01, 0x83, 0xa4, 0xd0, + 0xac, 0x9b, 0x54, 0xb0, 0x51, 0xf2, 0xb1, 0x3e, + 0xd9, 0x49, 0x09, 0x75, 0xea, 0xb7, 0x74, 0x14, + 0xff, 0x59, 0xc1, 0xf7, 0x69, 0x2e, 0x9a, 0x2e, + 0x20, 0x2b, 0x38, 0xfc, 0x91, 0x0a, 0x47, 0x41, + 0x74, 0xad, 0xc9, 0x3c, 0x1f, 0x67, 0xc9, 0x81] + +exponent1 = + toOctets 256 $ (fromOctets 256 d) `mod` ((fromOctets 256 p) - 1) + +e1Test = + TestCase ( + assertEqual "Exponent" dP exponent1 + ) + +dQ :: [Octet] +dQ = [0x47, 0x1e, 0x02, 0x90, 0xff, 0x0a, 0xf0, 0x75, + 0x03, 0x51, 0xb7, 0xf8, 0x78, 0x86, 0x4c, 0xa9, + 0x61, 0xad, 0xbd, 0x3a, 0x8a, 0x7e, 0x99, 0x1c, + 0x5c, 0x05, 0x56, 0xa9, 0x4c, 0x31, 0x46, 0xa7, + 0xf9, 0x80, 0x3f, 0x8f, 0x6f, 0x8a, 0xe3, 0x42, + 0xe9, 0x31, 0xfd, 0x8a, 0xe4, 0x7a, 0x22, 0x0d, + 0x1b, 0x99, 0xa4, 0x95, 0x84, 0x98, 0x07, 0xfe, + 0x39, 0xf9, 0x24, 0x5a, 0x98, 0x36, 0xda, 0x3d] + +m :: [Octet] +m = [0xd4, 0x36, 0xe9, 0x95, 0x69, 0xfd, 0x32, 0xa7, + 0xc8, 0xa0, 0x5b, 0xbc, 0x90, 0xd3, 0x2c, 0x49] + +seed :: [Octet] +seed = [0xaa, 0xfd, 0x12, 0xf6, 0x59, 0xca, 0xe6, 0x34, + 0x89, 0xb4, 0x79, 0xe5, 0x07, 0x6d, 0xde, 0xc2, + 0xf0, 0x6c, 0xb5, 0x8f] + +e :: [Octet] +e = [0x11] + +encodedText = encode mgf hash [] seed n m + +decodedText = decode mgf hash [] encodedText + +encodingTest = + TestCase ( + assertEqual "Encoding / Decoding" m decodedText + ) + +cipherText = encrypt (n,e) encodedText + +plainText = decrypt (n,d) cipherText + +decodedText' = decode mgf hash [] plainText + +encryptionTest = + TestCase ( + assertEqual "Encrypting / Decrypting" m decodedText + ) + +tests = TestList [popTest, e1Test, encodingTest, encryptionTest] + +main = runTestTT tests diff --git a/RSAVerifyExample.hs b/RSAVerifyExample.hs new file mode 100644 --- /dev/null +++ b/RSAVerifyExample.hs @@ -0,0 +1,112 @@ +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 new file mode 100644 --- /dev/null +++ b/ReadMe.tex @@ -0,0 +1,821 @@ +\documentclass{article} + +\usepackage{listings} +\usepackage{a4} +\usepackage{courier} +\usepackage{hyperref} +\usepackage{html} + + +\lstdefinelanguage{ASN1} { + morekeywords={}, + sensitive=false, + morecomment=[s]{(--}{--)} + } + +\lstdefinelanguage{shell} { + sensitive=true + } + +\setlength{\parskip}{\medskipamount} +\setlength{\parindent}{0pt} + +\title{Haskell Cryptographic Library 3.0.3} +\author{Dominic Steinitz} + +\begin{document} + +\maketitle + +The +\htmladdnormallinkfoot +{Haskell Cryptographic Library 3.0.3} +{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. + +This release contains: +\begin{itemize} +\item DES +\item Blowfish +\item AES +\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 +\htmladdnormallinkfoot +{here} +{http://www.haskell.org/crypto/doc/html} +. + +\section{System Requirements} + +\begin{itemize} +\item +The code has been tested on GHC 6.4. +It does not currently work with Hugs or NHC. +\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. +\end{itemize} + +\section{Installation Instructions} + +Get the sources: + +\lstset{language=shell,basicstyle=\ttfamily\small} +\begin{lstlisting}[frame=single] +darcs get --tag "3.0.3" http://www.haskell.org/crypto/src +\end{lstlisting} + +Build and install ready for testing: + +\begin{lstlisting}[frame=single] +ghc -o Setup Setup.hs -package Cabal +./Setup configure --prefix=/my/chosen/dir +./Setup build +./Setup install --user +\end{lstlisting} + +Run the tests. + +\begin{lstlisting}[frame=single] +cd /my/chosen/dir/bin +./BERTest +./RSATest +./SymmetricTest +./QuickTest +\end{lstlisting} + +You can now run the examples to confirm further that everything +is working satisfactorily. +When you are happy, build and install them in +their final destination: + +\begin{lstlisting}[frame=single] +./Setup unregister --user +./Setup clean +./Setup configure +./Setup build +./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. +\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. +\end{itemize} + +\section{Contact} + +All questions, comments, bug reports, flames, requests for +updates / changes and suggestions should be directed to Dominic Steinitz. + +\section{Licensing} + +The modules in the library come from different authors and have been +released under different licences. + +\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 \\ +\hline\hline +\end{tabular} + +\subsubsection{Codec.Text} +\begin{tabular}{|p{6cm}|p{3cm}|p{3cm}|p{1cm}|} +\hline\hline +Codec.Text.Raw & Dominic Steinitz & +Copyright \copyright\ 2006, All rights reserved & BSD \\ +\hline\hline +\end{tabular} + +\subsubsection{Codec.Encryption} +\begin{tabular}{|p{6cm}|p{3cm}|p{3cm}|p{1cm}|} +\hline\hline +Codec.Encryption.AES & Lukasz Anforowicz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Codec.Encryption.AESAux & Dominic Steinitz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Codec.Encryption.Blowfish & Doug Hoyte & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Codec.Encryption.BlowfishAux & Dominic Steinitz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Codec.Encryption.DES & Ian Lynagh & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Codec.Encryption.DESAux & Dominic Steinitz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Codec.Encryption.Modes & Dominic Steinitz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Codec.Encryption.Padding & Dominic Steinitz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Codec.Encryption.RSA & David Sankel & +Copyright \copyright\ 2005, All rights reserved & GPL \\ +\hline +Codec.Encryption.RSA.EMEOAEP & David Sankel & +Copyright \copyright\ 2005, All rights reserved & GPL \\ +\hline +Codec.Encryption.RSA.MGF & Dominic Steinitz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Codec.Encryption.RSA.NumberTheory & David Sankel & +Copyright \copyright\ 2005, All rights reserved & GPL \\ +\hline\hline +\end{tabular} + +\subsubsection{Codec} +\begin{tabular}{|p{6cm}|p{3cm}|p{3cm}|p{1cm}|} +\hline\hline +Codec.Utils & Dominic Steinitz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline\hline +\end{tabular} + +\subsubsection{Data.Digest} +\begin{tabular}{|p{6cm}|p{3cm}|p{3cm}|p{1cm}|} +\hline\hline +Data.Digest.MD5 & Dominic Steinitz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline +Data.Digest.MD5Aux & Ian Lynagh & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\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} + +\subsubsection{Data} +\begin{tabular}{|p{6cm}|p{3cm}|p{3cm}|p{1cm}|} +\hline\hline +Data.LargeWord +& Dominic Steinitz & +Copyright \copyright\ 2005, All rights reserved & BSD \\ +\hline\hline +\end{tabular} + +\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 \\ +\hline +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} + +\subsection{The BSD License} + +This license is based on +\htmladdnormallinkfoot +{The BSD License} +{http://www.opensource.org/licenses/bsd-license.php}. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +\begin{itemize} +\item +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. +\item +Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. +\item +The names of its contributors may not be used to endorse or promote +products derived from this software without specific prior written permission. +\end{itemize} + +\begin{sc} +This software is provided by the copyright holders and contributors ``AS IS'' +and any express or implied warranties, including, but not limited to, +the implied warranties of merchantability and fitness for a particular +purpose are disclaimed. In no event shall the copyright onwers or +contributors be liable for any direct, indirect, incidental, special, +exemplary, or consequential damages (including, but not limited to, +procurement of substitute goods or services; loss of use, data, or profits; +or business interruption) however caused and on any theory of liability, +whether in contract, strict liability, or tort (including negligence or +otherwise) arising in any way out of the use of this software, +even if advised of the possibility of such damage. +\end{sc} + +\subsection{The GNU General Public License (GPL)} + +This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. + +You can find a copy of +the GNU General Public License +\htmladdnormallinkfoot +{here} +{http://www.opensource.org/licenses/gpl-license.php} +; +if not, write to the Free Software Foundation, Inc., 59 Temple Place, +Suite 330, Boston, MA 02111-1307 USA + +\section{Disclaimer} +Cryptography is a notoriously easy area in which to make mistakes, +not necessarily with the algorithms but with how they are implemented +(for example not protecting keys, using weak keys and so on). +For a readable account of some of the pitfalls, see +\htmladdnormallinkfoot +{Ross Anderson} +{http://www.cl.cam.ac.uk/users/rja14/} +'s book. + +\begin{sc} +This software is provided by the copyright holders and contributors ``AS IS'' +and any express or implied warranties, including, but not limited to, +the implied warranties of merchantability and fitness for a particular +purpose are disclaimed. In no event shall the copyright onwers or +contributors be liable for any direct, indirect, incidental, special, +exemplary, or consequential damages (including, but not limited to, +procurement of substitute goods or services; loss of use, data, or profits; +or business interruption) however caused and on any theory of liability, +whether in contract, strict liability, or tort (including negligence or +otherwise) arising in any way out of the use of this software, +even if advised of the possibility of such damage. +\end{sc} + +\section{Acknowledgements} + +\begin{itemize} +\item +Doug Hoyte (HardCore SoftWare) +\item +\htmladdnormallinkfoot + {Ian Lynagh} + {http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh} +\item +\htmladdnormallinkfoot + {David Sankel} + {http://www.electronconsulting.com/whois.html} +\item +\htmladdnormallinkfoot +{Ross Paterson} +{http://www.soi.city.ac.uk/~ross} +\item +Lukasz Anforowicz +\item +\htmladdnormallinkfoot +{Warrick Gray} +{http://homepages.paradise.net.nz/warrickg/haskell/http/} +\end{itemize} + +This document was last updated on 1st April 2006. +\copyright\ 2006 Dominic Steinitz. + +\end{document} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +module Main where +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/SymmetricTest.hs b/SymmetricTest.hs new file mode 100644 --- /dev/null +++ b/SymmetricTest.hs @@ -0,0 +1,232 @@ +module Main(main) where + +import Codec.Utils +import Codec.Encryption.Blowfish as Blowfish +import Codec.Encryption.Modes +import Codec.Encryption.Padding +import Codec.Encryption.DES as DES +import Codec.Encryption.AES as AES +import Data.Word +import Data.Bits +import Data.Char +import Data.LargeWord +import Test.HUnit +import Numeric + +-- AES Tests. + +-- Comparision with resuts from +-- http://www.cs.ucsd.edu/~fritz/rijndael_test.html + +ad = 0xF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word128 +ak16 = 0xF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word128 +ae16 = 0x6e94fffbb861b2c1769cd4629f3d724b :: Word128 +ae16' = AES.encrypt ak16 ad +aesTest1 = + TestCase ( + assertEqual "AES Key Length 128" ae16 ae16' + ) + +ak24 = 0xF0E1D2C3B4A5968778695A4B3C2D1E0FF0E1D2C3B4A59687 :: Word192 +ae24' = AES.encrypt ak24 ad +ae24 = 0x07d806bb62ebb4399354594ea6586ec6 :: Word128 +aesTest2 = + TestCase ( + assertEqual "AES Key Length 192" ae24 ae24' + ) + +ak32 = 0xF0E1D2C3B4A5968778695A4B3C2D1E0FF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word256 +ae32' = AES.encrypt ak32 ad +ae32 = 0x28e88482d9b146fdde7e080fcbae1b98 :: Word128 +aes3 = ae32 == ae32' +aesTest3 = + TestCase ( + assertEqual "AES Key Length 256" ae32 ae32' + ) + +-- Comparision with resuts from +-- http://www.zvon.org/tmRFC/RFC3602/Output/chapter4.html + +aeskey16 = 0x06a9214036b8a15b512e03d534120006 :: Word128 +aesiv16 = 0x3dafba429d9eb430b422da802c9fac41 :: Word128 +aesplaintext = "Single block msg" +aesciphertext = [0xe353779c1079aeb82708942dbe77181a] :: [Word128] +aesciphertext' = + cbc AES.encrypt aesiv16 aeskey16 $ + pkcs5 $ + map (fromIntegral . ord) aesplaintext +-- aescbc1 = aesciphertext == take 1 aesciphertext' +aescbcTest1 = + TestCase ( + assertEqual "AES CBC PKCS5 Key Length 128" + aesciphertext (take 1 aesciphertext') + ) + +aesplaintext' = + map (chr . fromIntegral) $ + unPkcs5 $ + unCbc AES.decrypt aesiv16 aeskey16 aesciphertext' +aescbcTest2 = + TestCase ( + assertEqual "AES CBC PKCS5 Decryption Key Length 128" + aesplaintext aesplaintext' + ) + +aes2key16 = 0x6c3ea0477630ce21a2ce334aa746c2cd :: Word128 +aes2iv16 = 0xc782dc4c098c66cbd9cd27d825682c81 :: Word128 +aes2plaintext = "This is a 48-byte message (exactly 3 AES blocks)" +aes2ciphertext = [0xd0a02b3836451753d493665d33f0e886, + 0x2dea54cdb293abc7506939276772f8d5, + 0x021c19216bad525c8579695d83ba2684] :: [Word128] +aes2ciphertext' = + cbc AES.encrypt aes2iv16 aes2key16 $ + pkcs5 $ + map (fromIntegral . ord) aes2plaintext +aescbcTest3 = + TestCase ( + assertEqual "AES CBC PKCS5 3 Blocks Key Length 128" + aes2ciphertext (take 3 aes2ciphertext') + ) + +-- Comparision with resuts from +-- http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf + +aes3key24 = + 0x8e73b0f7da0e6452c810f32b809079e562f8ead2522c6b7b :: Word192 +aes3iv16 = 0x000102030405060708090a0b0c0d0e0f :: Word128 +aes3plaintext = + [0x6bc1bee22e409f96e93d7e117393172a, + 0xae2d8a571e03ac9c9eb76fac45af8e51, + 0x30c81c46a35ce411e5fbc1191a0a52ef, + 0xf69f2445df4f9b17ad2b417be66c3710] :: [Word128] +aes3ciphertext' = + cbc AES.encrypt aes3iv16 aes3key24 $ + pkcs5 $ + concat $ + map (toOctets 256) aes3plaintext +aes3ciphertext = + [0x4f021db243bc633d7178183a9fa071e8, + 0xb4d9ada9ad7dedf4e5e738763f69145a, + 0x571b242012fb7ae07fa9baac3df102e0, + 0x08b0e27988598881d920a9e64f5615cd] :: [Word128] +aescbcTest4 = + TestCase ( + assertEqual "AES CBC PKCS5 4 Blocks Key Length 192" + aes3ciphertext (take 4 aes3ciphertext') + ) + +aes4key32 = + 0x603deb1015ca71be2b73aef0857d77811f352c073b6108d72d9810a30914dff4 + :: Word256 +aes4iv16 = 0x000102030405060708090a0b0c0d0e0f :: Word128 +aes4plaintext = + [0x6bc1bee22e409f96e93d7e117393172a, + 0xae2d8a571e03ac9c9eb76fac45af8e51, + 0x30c81c46a35ce411e5fbc1191a0a52ef, + 0xf69f2445df4f9b17ad2b417be66c3710] :: [Word128] +aes4ciphertext' = + cbc AES.encrypt aes4iv16 aes4key32 $ + pkcs5 $ + concat $ + map (toOctets 256) aes3plaintext +aes4ciphertext = + [0xf58c4c04d6e5f1ba779eabfb5f7bfbd6, + 0x9cfc4e967edb808d679f777bc6702c7d, + 0x39f23369a9d9bacfa530e26304231461, + 0xb2eb05e2c39be9fcda6c19078c6a9d1b] :: [Word128] +aescbcTest5 = + TestCase ( + assertEqual "AES CBC PKCS5 4 Blocks Key Length 256" + aes4ciphertext (take 4 aes4ciphertext') + ) + +-- Blowfish Tests. + +-- Tests from http://www.counterpane.com/vectors.txt. + +d = 0xFEDCBA9876543210 :: Word64 +k = 0xF0 :: Word8 +e = 0xF9AD597C49DB005E :: Word64 +e' = Blowfish.encrypt k d +bfTest1 = + TestCase ( + assertEqual "Blowfish Key Length 8" e e' + ) + +k2 = 0xF0E1 :: Word16 +e2 = 0xE91D21C1D961A6D6 :: Word64 +e2' = Blowfish.encrypt k2 d +bfTest2 = + TestCase ( + assertEqual "Blowfish Key Length 16" e2 e2' + ) + +e8 = 0xE87A244E2CC85E82 :: Word64 +k8 = 0xF0E1D2C3B4A59687 :: Word64 +e8' = Blowfish.encrypt k8 d +bfTest3 = + TestCase ( + assertEqual "Blowfish Key Length 64" e8 e8' + ) + +e16 = 0x93142887EE3BE15C :: Word64 +k16= 0xF0E1D2C3B4A5968778695A4B3C2D1E0F :: Word128 +e16' = Blowfish.encrypt k16 d +bfTest4 = + TestCase ( + assertEqual "Blowfish Key Length 128" e16 e16' + ) + +-- Blowfish test with Cipher Block Chaining. +-- Set up the published key, initialization vector and data. + +key16 = 0x0123456789ABCDEFF0E1D2C3B4A59687 :: Word128 +iv8 = 0xFEDCBA9876543210 :: Word64 +data29 = "7654321 Now is the time for \NUL" + +-- Pad with nulls as in the example. + +e29' = + cbc Blowfish.encrypt iv8 key16 $ padNulls $ map (fromIntegral . ord) data29 + +e29 = [0x6B,0x77,0xB4,0xD6,0x30,0x06,0xDE,0xE6, + 0x05,0xB1,0x56,0xE2,0x74,0x03,0x97,0x93, + 0x58,0xDE,0xB9,0xE7,0x15,0x46,0x16,0xD9, + 0x59,0xF1,0x65,0x2B,0xD5,0xFF,0x92,0xCC] :: [Octet] + +bfTest5 = + TestCase ( + assertEqual "AES CBC Nulls Key Length 128" + e29 (concat $ map (toOctets 256) e29') + ) + +-- DES Tests + +-- Test from http://www.itl.nist.gov/fipspubs/fip81.htm + +key = 0x0123456789abcdef :: Word64 +iv = 0x1234567890abcdef :: Word64 +expectedDES = [0xe5c7cdde872bf27c, + 0x43e934008c389c0f, + 0x683788499a7c05f6] :: [Word64] +plainText = "Now is the time for all " + +-- Pad using PKCS#5 so only take the first 3 blocks of the ciphertext. + +cipherText = + cbc DES.encrypt iv key $ pkcs5 $ map (fromIntegral . ord) plainText +descbcTest1 = + TestCase ( + assertEqual "DES CBC PKCS5 3 Blocks" + expectedDES (take 3 cipherText) + ) + +tests = + TestList [ + aesTest1, aesTest2, aesTest3, aescbcTest1, + aescbcTest2, aescbcTest3, aescbcTest4, aescbcTest5, + bfTest1, bfTest2, bfTest3, bfTest4, bfTest5, + descbcTest1 + ] + +main = runTestTT tests diff --git a/X509Example.hs b/X509Example.hs new file mode 100644 --- /dev/null +++ b/X509Example.hs @@ -0,0 +1,120 @@ +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)