packages feed

Crypto (empty) → 3.0.3

raw patch · 40 files changed

+9087/−0 lines, 40 filesdep +HUnitdep +NewBinarydep +QuickCheckbuild-type:Customsetup-changed

Dependencies added: HUnit, NewBinary, QuickCheck, base, mtl

Files

+ AttributeCertificate.hs view
@@ -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 ++ " <fileName>")+         else test1 (args!!0)
+ BERTest.hs view
@@ -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+-}
+ Codec/ASN1.hs view
@@ -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)+   ]
+ Codec/ASN1/BER.hs view
@@ -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
+ Codec/ASN1/InformationFramework.hs view
@@ -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 <http://www.itu.int/ITU-T/asn1/database/itu-t/x/x501/2005/InformationFramework.html>+--+-----------------------------------------------------------------------------++module Codec.ASN1.InformationFramework (+-- * Type declarations+   GeneralName(..),+   GeneralNames(..),+   Name(..),+   RDNSequence(..),+-- * Function declarations+   generalName,+   generalNames,+   name,+   rdnSequence,+   unRDNSequence+   ) where++import Codec.ASN1+import Codec.ASN1.BER+import Codec.ASN1.X509 (+   relativeDistinguishedName,+   RelativeDistinguishedName+   )++{-+GeneralNames ::= SEQUENCE SIZE (1..MAX) OF GeneralName++GeneralName ::= CHOICE {+   otherName                 [0] INSTANCE OF OTHER-NAME,+   rfc822Name                [1] IA5String,+   dNSName                   [2] IA5String,+   x400Address               [3] ORAddress,+   directoryName             [4] Name,+   ediPartyName              [5] EDIPartyName,+   uniformResourceIdentifier [6] IA5String,+   iPAddress                 [7] OCTET STRING,+   registeredID              [8] OBJECT IDENTIFIER+   }++-- naming data types +Name ::= CHOICE { +   -- only one possibility for now +   rdnSequence RDNSequence+   }++RDNSequence ::= SEQUENCE OF RelativeDistinguishedName+-}++generalName :: TypeDefn+generalName =+   "GeneralName" ::= +      AbsChoice [+--          (Explicit, Just "otherName" :>: [0] INSTANCE OF OTHER-NAME),+         (Explicit, Just "rfc822Name" :>: (Just 1 :@: absIA5String)),+         (Explicit, Just "dNSName" :>: (Just 2 :@: absIA5String)),+--          (Explicit, Just "x400Address" :>: [3] ORAddress),+         (Explicit, Just "directoryName" :>: (Just 4 :@: name)),+--          (Explicit, Just "ediPartyName" :>: [5] :@: EDIPartyName),+         (Explicit, Just "uniformResourceIdentifier" :>: +            (Just 6 :@: absIA5String)),+         (Explicit, Just "iPAddress" :>: (Just 7 :@: absOctetString)),+         (Explicit, Just "registeredID" :>: (Just 8 :@: absOID))+      ]++data GeneralName =+   Rfc822Name                IA5String   |+   DNSName                   IA5String   |+   DirectoryName             Name        |+   UnifromResourceIdentifier IA5String   |+   IPAddress                 OctetString |+   RegisteredID              OID+      deriving (Eq,Show)++instance Encode GeneralName where+   decode a b =+      do x <- b+         let t  = defaultedTagValue x+             bs = encodedDefComps x+             a' = absRefedType a+             b' = (encodedDefComps x)!! 0+         case t of+            1 -> do foo <- decode a' b'+                    return $ Rfc822Name foo+            2 -> do foo <- decode a' b'+                    return $ DNSName foo+            4 -> do foo <- decode a' b'+                    return $ DirectoryName foo+            6 -> do foo <- decode a' b'+                    return $ UnifromResourceIdentifier foo+            7 -> do foo <- decode a' b'+                    return $ IPAddress foo+            8 -> do foo <- decode a' b'+                    return $ RegisteredID foo++generalNames :: TypeDefn+generalNames = +   "GeneralNames" ::= +      AbsSeqOf Universal 16 Implicit generalName++data GeneralNames = GeneralNames [GeneralName]+   deriving (Eq,Show)++instance Encode GeneralNames where+   decode a b =+      do x <- decode a b+         return (GeneralNames x)++name :: TypeDefn+name =+   "Name" ::=+      AbsChoice [(Implicit,Just "rdnSequence" :>: (Nothing :@: rdnSequence))]++data Name= Name RDNSequence+   deriving (Eq,Show)++instance Encode Name where+   decode a b =+      do x <- b+         let t = defaultedTagValue x+         case t of+            16 -> do foo <- decode a b+                     return $ Name foo++rdnSequence :: TypeDefn+rdnSequence =+   "RDNSequence" ::=+      AbsSeqOf Universal 16 Implicit relativeDistinguishedName++data RDNSequence = RDNSequence [RelativeDistinguishedName]+   deriving (Eq,Show)++unRDNSequence :: RDNSequence -> [RelativeDistinguishedName]+unRDNSequence (RDNSequence x) = x++instance Encode RDNSequence where+   decode a b =+      do x <- decode a b+         return (RDNSequence x)+
+ Codec/ASN1/PKCS1v15.hs view
@@ -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 +-- (<ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-1/pkcs-1v2-1.pdf> and+-- <ftp://ftp.rsasecurity.com/pub/pkcs/ascii/pkcs-1.asc>) for +-- further information.+-----------------------------------------------------------------------------++module Codec.ASN1.PKCS1v15(+   -- * Type Declarations+   DigestInfo(..),+   DigestAlgorithm,+   -- * Function Declarations+   encode, +   decode,+   digestInfo,+   digestAlgorithm+   ) where++import Data.Maybe+import Codec.Utils (Octet)+import Codec.ASN1+import qualified Codec.ASN1.BER as BER+import Codec.ASN1.X509 (algorithmIdentifier,AlgorithmIdentifier)++-- | Not yet implemented.++encode :: [Octet] -> [Octet]++encode xs = error "tbd"++-- | Take an encoded message and return the decoded message provided all the+--   conditions in the specification are met.++decode :: [Octet] -> Maybe [Octet]+decode encoded =+   if decodeError +      then Nothing+      else (Just m)+   where  +      (x0,t0) = splitAt 1 encoded+      (x1,t1) = splitAt 1 t0+      (ps,t2) = span (==0xff) t1+      (x3,m) = splitAt 1 t2+      decodeError = +         and [+            x0 /= [0x00], +            x1 /= [0x02], +            x3 /= [0x00],+            length ps < 8+         ]++{-+DigestInfo ::= SEQUENCE {+   digestAlgorithm DigestAlgorithm,+   digest OCTET STRING+}+-}++digestInfo =+   "DigestInfo" ::=+      AbsSeq Universal 16 Implicit [+         Regular (Just "digestAlgorithm" :>: (Nothing :@:+   digestAlgorithm)),+         Regular (Just "digest"          :>: (Nothing :@:+   absOctetString))+      ]++data DigestInfo =+   DigestInfo {+      digestAlgorithm1 :: DigestAlgorithm,+      digest :: OctetString+      }+   deriving (Eq,Show)++instance BER.Encode DigestInfo where+   decode a b =+      do x <- b+         let as = absSeqComponents a+             bs  = BER.encodedDefComps x+         return $+            DigestInfo {+               digestAlgorithm1 = fromJust $ BER.decode (as!!0) (bs!!0),+               digest = fromJust $ BER.decode (as!!1) (bs!!1)+            }++digestAlgorithm =+   modName "DigestAlgorithm" algorithmIdentifier++type DigestAlgorithm = AlgorithmIdentifier
+ Codec/ASN1/PKCS8.hs view
@@ -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 <http://www.rsasecurity.com/rsalabs/pkcs/pkcs-8/>.+--+-----------------------------------------------------------------------------++module Codec.ASN1.PKCS8 (+-- * Type declarations+   RSAPrivateKey(..),+   PrivateKeyInfo(..),+-- * Function declarations+   rsaPrivateKey,+   privateKeyInfo+   ) where++import Data.Maybe+import Codec.ASN1+import Codec.ASN1.BER+import Codec.ASN1.X509 (+   algorithmIdentifier,+   AlgorithmIdentifier,+   attributeTypeAndValue,+   AttributeTypeAndValue+   )++{-+See http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1.2. A.1.2+RSA private key syntax:++RSAPrivateKey ::= SEQUENCE {+   version           Version,+   modulus           INTEGER,  -- n+   publicExponent    INTEGER,  -- e+   privateExponent   INTEGER,  -- d+   prime1            INTEGER,  -- p+   prime2            INTEGER,  -- q+   exponent1         INTEGER,  -- d mod (p-1)+   exponent2         INTEGER,  -- d mod (q-1)+   coefficient       INTEGER,  -- (inverse of q) mod p+   otherPrimeInfos   OtherPrimeInfos OPTIONAL+      }+-}++rsaPrivateKey :: TypeDefn+rsaPrivateKey =+   "RSAPrivateKey" ::=+      AbsSeq Universal 16 Implicit +         [Regular (Just "version"         :>: (Nothing :@: version)),+          Regular (Just "modulus"         :>: (Nothing :@: absInteger)),+          Regular (Just "publicExponent"  :>: (Nothing :@: absInteger)),+          Regular (Just "privateExponent" :>: (Nothing :@: absInteger)),+          Regular (Just "prime1"          :>: (Nothing :@: absInteger)),+          Regular (Just "prime2"          :>: (Nothing :@: absInteger)),+          Regular (Just "exponent1"       :>: (Nothing :@: absInteger)),+          Regular (Just "exponent2"       :>: (Nothing :@: absInteger)),+          Regular (Just "coefficient"     :>: (Nothing :@: absInteger))]++data RSAPrivateKey =+   RSAPrivateKey {+      version1        :: Integer,+      modulus         :: Integer, -- n+      publicExponent  :: Integer, -- e+      privateExponent :: Integer, -- d+      prime1          :: Integer, -- p+      prime2          :: Integer, -- q+      exponent1       :: Integer, -- d mod (p-1)+      exponent2       :: Integer, -- d mod (q-1)+      coefficient     :: Integer  -- (inverse of q) mod p+      }+   deriving Show++instance Encode RSAPrivateKey where+   decode a b = +      do x <- b+         let as = absSeqComponents a+             bs  = encodedDefComps x+             as' = map (\x -> replaceRef x as bs) as+             version         = fromJust $ decode (as'!!0) (bs!!0)+             modulus         = fromJust $ decode (as'!!1) (bs!!1)+             publicExponent  = fromJust $ decode (as'!!2) (bs!!2)+             privateExponent = fromJust $ decode (as'!!3) (bs!!3)+             prime1          = fromJust $ decode (as'!!4) (bs!!4)+             prime2          = fromJust $ decode (as'!!5) (bs!!5)+             exponent1       = fromJust $ decode (as'!!6) (bs!!6)+             exponent2       = fromJust $ decode (as'!!7) (bs!!7)+             coefficient     = fromJust $ decode (as'!!8) (bs!!8)+         return $ +            RSAPrivateKey {+               version1        = version,+               modulus         = modulus,+               publicExponent  = publicExponent,+               privateExponent = privateExponent,+               prime1          = prime1,+               prime2          = prime2,+               exponent1       = exponent1,+               exponent2       = exponent2,+               coefficient     = coefficient}++version = modName "Version" absInteger++type Version = Integer++{-+PrivateKey ::= OCTET STRING+-}++privateKey = modName "PrivateKey" absOctetString++type PrivateKey = OctetString++{-+Attributes ::= SET OF Attribute+-}++attributes = +   "Attributes" ::= AbsSetOf Universal 16 Implicit attributeTypeAndValue++type Attributes = SetOf AttributeTypeAndValue++{-+PrivateKeyInfo ::= SEQUENCE {+   version Version,+   privateKeyAlgorithm AlgorithmIdentifier {{PrivateKeyAlgorithms}},+   privateKey PrivateKey,+   attributes [0] Attributes OPTIONAL +      }+-}++privateKeyInfo :: TypeDefn+privateKeyInfo =+   "privateKeyInfo" ::=+      AbsSeq Universal 16 Implicit [+         Regular  (Just "version"      :>: (Nothing :@: version)),+         Regular  (+            Just "privateKeyAlgorithm" :>: (Nothing :@: algorithmIdentifier)+         ),+         Regular  (Just "privateKey"   :>: (Nothing :@: privateKey)),+         Optional (Just "attributes"   :>: (Nothing :@: attributes))+      ]++data PrivateKeyInfo =+   PrivateKeyInfo {+      version2            :: Version,+      privateKeyAlgorithm :: AlgorithmIdentifier,+      privateKey1         :: PrivateKey,+      attributes1         :: Maybe Attributes+      }+   deriving Show++instance Encode PrivateKeyInfo where+   decode a b = +      do x <- b+         let as = absSeqComponents a+             bs  = encodedDefComps x+             as' = map (\x -> replaceRef x as bs) as+             version             = fromJust $ decode (as'!!0) (bs!!0)+             privateKeyAlgorithm = fromJust $ decode (as'!!1) (bs!!1)+             privateKey          = fromJust $ decode (as'!!2) (bs!!2)+             attributes          = decode (as'!!3) (bs!!3)+         return $ +            PrivateKeyInfo {+               version2            = version,+               privateKeyAlgorithm = privateKeyAlgorithm,+               privateKey1         = privateKey,+               attributes1         = attributes+            }++{-+type Algorithm = OID++-- | This will do for now. DSA has some parameters which are more complicated+-- than this but since we plan to do RSA initially and this has NULL parameters+-- then anything will do to get us going.++type Parameters = Int++-- | The parameters will only ever be Nothing as this implementation+-- only supports RSA and this has no parameters. So even if the parameters+-- are non-NULL, fromASN will not fail but will ignore them.++data AlgorithmIdentifier =+   MkAlgorithmIdentifier {+      algorithm :: Algorithm,+      parameters :: Maybe Parameters } +   deriving Show++data PrivateKeyInfo =+   MkPrivateKeyInfo {+      version1 :: Version,+      privateKeyAlgorithm :: AlgorithmIdentifier,+      privateKey :: RSAPrivateKey }+   deriving Show++{-+We are "overloading" Version. It is defined in ++ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-8/pkcs-8v1_2.asn:++Version ::= INTEGER {v1(0)} (v1,...)++and also in ++http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1.2:++Version ::= INTEGER { two-prime(0), multi(1) } ++although for the latter+definition we represent two-prime in Haskell as V1 and do not support+multi.+-}++{-+We assume:++Algorithm ::= OID ++although the situation is far more complicated.+See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html.+-}++algorithm = modName "Algorithm" absOID++type Algorithm = OID++{-+We assume:++Parameters ::= NULL++although the situation is far more complicated.+See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html.+-}++parameters = modName "Parameters" absNull++type Parameters = NULL++{-+See http://www.itu.int/ITU-T/asn1/database/itu-t/x/x509/1997/AuthenticationFramework.html#AuthenticationFramework.AlgorithmIdentifier.++For now, the parameters will only ever be Nothing as this implementation+only supports RSA and this has no parameters. If the parameters+are non-NULL, we will report an error.++See http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1. A.1 RSA key representation:++"The parameters field associated with this OID in a value of type AlgorithmIdentifier shall have a value of type NULL"+-}++{-+See ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-8/pkcs-8v1_2.asn.+-}++-}
+ Codec/ASN1/TLV.hs view
@@ -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)
+ Codec/ASN1/X509.hs view
@@ -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+            }+
+ Codec/ASN1/X509/AttributeCertificateDefinitions.hs view
@@ -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 <http://www.itu.int/ITU-T/asn1/database/itu-t/x/x509/2005/AttributeCertificateDefinitions.html>+--+-----------------------------------------------------------------------------++module Codec.ASN1.X509.AttributeCertificateDefinitions (+-- * Type declarations+   AttributeCertificate(..),+   AttributeCertificateInfo(..),+   Holder(..),+   HolderGeneralNames(..),+   AttCertIssuer(..),+   IssuerSerial(..),+   Attribute(..),+   AttributeValue(..),+   AttCertValidityPeriod(..),+   GeneralizedTime(..),+-- * Function declarations+   attributeCertificate,+   holder,+   holder',+   holderGeneralNames,+   attCertIssuer,+   issuerSerial,+   attribute+   ) where++import Codec.ASN1+import Codec.ASN1.BER+import Data.Maybe(+   fromJust+   )+import Codec.ASN1.X509 (+   algorithmIdentifier,+   AlgorithmIdentifier+   )+import Codec.ASN1.InformationFramework (+   generalNames,+   GeneralNames+   )++{-+AttributeCertificate ::= SIGNED {AttributeCertificateInfo}++AttributeCertificate ::= SEQUENCE {+   attributeCertificateInfo AttributeCertificateInfo,+   algorithmIdentifier      AlgorithmIdentifier,+   encrypted                BIT STRING+   }   ++AttributeCertificateInfo ::= SEQUENCE {+   version                AttCertVersion, --version is v2+   holder                 Holder,+   issuer                 AttCertIssuer,+   signature              AlgorithmIdentifier,+   serialNumber           CertificateSerialNumber,+   attrCertValidityPeriod AttCertValidityPeriod,+   attributes             SEQUENCE OF Attribute,+   issuerUniqueID         UniqueIdentifier OPTIONAL,+   extensions             Extensions OPTIONAL+   }++AttCertVersion ::= INTEGER { v2(1) }+-}++attributeCertificate :: TypeDefn+attributeCertificate =+   "attributeCertificate" ::=+      AbsSeq Universal 16 Implicit+         [Regular (Nothing :>: (Nothing :@: attributeCertificateInfo)),+          Regular (Nothing :>: (Nothing :@: algorithmIdentifier)),+          Regular (Nothing :>: (Nothing :@: absBitString))]++attributeCertificateInfo :: TypeDefn+attributeCertificateInfo =+   "attributeCertificateInfo" ::=+       AbsSeq Universal 16 Implicit [+          Regular (Just "version" :>: (Nothing :@: version)),+          Regular (Just "holder"  :>: (Nothing :@: holder')),+          Regular (Just "issuer"  :>: (Nothing :@: attCertIssuer)),+          Regular (Just "signature" :>: +             (Nothing :@: algorithmIdentifier)),+          Regular (Just "serialNumber" :>: +             (Nothing :@: certificateSerialNumber)),+          Regular (Just "attrCertValidityPeriod" :>: +             (Nothing :@: attCertValidityPeriod)),+          Regular (Just "attributes" :>:+             (Nothing :@: (+                "SEQUENCE OF Attribute" ::=+                   AbsSeqOf Universal 16 Implicit attribute+                )+             )+          )+       ]++data AttributeCertificate =+   AttributeCertificate {+      attributeCertificateInfo1 :: AttributeCertificateInfo,+      algorithmIdentifier2 :: AlgorithmIdentifier,+      encrypted :: BitString+   } deriving (Eq,Show)      ++instance Encode AttributeCertificate where+   decode a b =+      do x <- b+         let as = absSeqComponents a+             bs  = encodedDefComps x+         return $+            AttributeCertificate {+               attributeCertificateInfo1 = fromJust $ decode (as!!0) (bs!!0),+               algorithmIdentifier2 = fromJust $ decode (as!!1) (bs!!1),+               encrypted = fromJust $ decode (as!!2) (bs!!2)+            }++data AttributeCertificateInfo =+   AttributeCertificateInfo {+      version1      :: Version,+      holder1       :: Holder,+      issuer2       :: AttCertIssuer,+      signature1    :: AlgorithmIdentifier,+      serialNumber1 :: CertificateSerialNumber,+      attrCertValidityPeriod ::  AttCertValidityPeriod,+      attributes    :: [Attribute]+   } deriving (Eq,Show)++instance Encode AttributeCertificateInfo where+   decode a b =+      do x <- b+         let as = absSeqComponents a+             bs  = encodedDefComps x+         return $+            AttributeCertificateInfo {+               version1      = fromJust $ decode (as!!0) (bs!!0),+               holder1       = fromJust $ decode (as!!1) (bs!!1),+               issuer2       = fromJust $ decode (as!!2) (bs!!2),+               signature1    = fromJust $ decode (as!!3) (bs!!3),+               serialNumber1 = fromJust $ decode (as!!4) (bs!!4),+               attrCertValidityPeriod = fromJust $ decode (as!!5) (bs!!5),+               attributes    = fromJust $ decode (as!!6) (bs!!6)+            }++type Version = Integer++version = modName "Version" absInteger++{-+Holder ::= SEQUENCE {+   baseCertificateID [0] IssuerSerial OPTIONAL,+   -- the issuer and serial number of the holder's Public Key Certificate+   entityName [1] GeneralNames OPTIONAL,+   -- the name of the entity or role+   objectDigestInfo [2] ObjectDigestInfo OPTIONAL+   --used to directly authenticate the holder, e.g. an executable+   --at least one of baseCertificateID, entityName or objectDigestInfo+   -- shall be present+   }+-}++holder =+   "Holder" ::= +      AbsSeq Universal 16 Implicit+         [Optional (Just "entityName" :>: (Just 1 :@: generalNames))]++holder' =+   "Holder" ::= +      AbsSeq Universal 16 Implicit+         [Optional (Nothing :>: (Nothing :@: holderGeneralNames))]++{-+We don't handle IMPLICIT / EXPLICIT correctly on ComponentTypes of+SEQUENCE so we have to invent a new intermediate type to get over +the problem here until it is fixed in the main ASN1 module.++HolderGeneralNames ::=+   [1] IMPLICIT GeneralNames+-}++holderGeneralNames = +   "entityName" ::= AbsRef Context 1 Implicit generalNames++data HolderGeneralNames = +   HolderGeneralNames GeneralNames+      deriving (Eq,Show)++instance Encode HolderGeneralNames where+   decode a b =+      do x <- decode a b+         return $ HolderGeneralNames x++data Holder =+   Holder {+      entityName :: Maybe HolderGeneralNames+   }+   deriving (Eq,Show)++instance Encode Holder where+   decode a b =+      do x <- b+         let as = absSeqComponents a+             bs  = encodedDefComps x+         return $+            Holder {+               entityName = decode (as!!0) (bs!!0)+            }++{-+AttCertIssuer ::= [0] SEQUENCE {+   issuerName            GeneralNames     OPTIONAL,+   baseCertificateID [0] IssuerSerial     OPTIONAL,+   objectDigestInfo  [1] ObjectDigestInfo OPTIONAL +   }+-- At least one component shall be present+   ( WITH COMPONENTS { ..., issuerName PRESENT } |+     WITH COMPONENTS { ..., baseCertificateID PRESENT } |+     WITH COMPONENTS { ..., objectDigestInfo PRESENT } )+-}++attCertIssuer :: TypeDefn+attCertIssuer =+   "attCertIssuer" ::=+      AbsSeq Context 0 Implicit+         [Optional (Just "issuerName" :>: +             (Nothing :@: generalNames)),+          Optional (Just "baseCertificateID" :>:+             (Just 0 :@: issuerSerial))+{-+051218140100++For now. Since with the PERMIS attribute certificate, we know+that we will get an issuerName, we don't have to support this yet+and ObjectDigestInfo is a) more work and b) contains ENUMERATED+which we don't support yet even though it's not hard so to do.++          Optional (Just "objectDigestInfo" :>:+             (Just 1 :@: objectDigestInfo))+-}+      ]++data AttCertIssuer =+   AttCertIssuer {+      issuerName :: Maybe GeneralNames,+      baseCertificateID :: Maybe IssuerSerial+   }+   deriving (Eq,Show)++instance Encode AttCertIssuer where+   decode a b =+      do x <- b+         let as = absSeqComponents a+             bs  = encodedDefComps x+         return $+            AttCertIssuer {+               issuerName = decode (as!!0) (bs!!0),+               baseCertificateID = decode (as!!1) (bs!!1)+            }++{-      +IssuerSerial ::= SEQUENCE {+   issuer    GeneralNames,+   serial    CertificateSerialNumber,+   issuerUID UniqueIdentifier OPTIONAL +   }+-}++issuerSerial =+   "IssuerSerial" ::=+      AbsSeq Universal 16 Implicit [+         Regular  (Just "issuer"    :>: (Nothing :@: generalNames)),+         Regular  (Just "serial"    :>: (Nothing :@: certificateSerialNumber)),+         Optional (Just "issuerUID" :>: (Nothing :@: uniqueIdentifier))+      ]++data IssuerSerial =+   IssuerSerial {+      issuer1  :: GeneralNames,+      serial   :: CertificateSerialNumber,+      issuerID :: Maybe UniqueIdentifier+   }+   deriving (Eq,Show)++instance Encode IssuerSerial where+   decode a b =+      do x <- b+         let as = absSeqComponents a+             bs  = encodedDefComps x+         return $+            IssuerSerial {+               issuer1  = fromJust $ decode (as!!0) (bs!!0),+               serial   = fromJust $ decode (as!!1) (bs!!1),+               issuerID = decode (as!!2) (bs!!2)+            }++{-+CertificateSerialNumber ::= INTEGER+-}++certificateSerialNumber =+   modName "CertificateSerialNumber" absInteger++type CertificateSerialNumber = Integer++{-+AttCertValidityPeriod ::= SEQUENCE {+   notBeforeTime GeneralizedTime,+   notAfterTime GeneralizedTime +   }+-}++attCertValidityPeriod :: TypeDefn+attCertValidityPeriod =+   "Validity" ::=+      AbsSeq Universal 16 Implicit+         [Regular (Just "notBeforeTime"  :>: (Nothing :@: generalizedTime)),+          Regular (Just "notAfterTime"   :>: (Nothing :@: generalizedTime))]++data AttCertValidityPeriod =+   AttCertValidityPeriod {+      notBeforeTime :: GeneralizedTime,+      notAfterTime  :: GeneralizedTime+      }+   deriving (Eq,Show)++instance Encode AttCertValidityPeriod where+   decode a b =+      do x <- b+         let as = absSeqComponents a+             bs  = encodedDefComps x+         return $+            AttCertValidityPeriod {+               notBeforeTime = fromJust $ decode (as!!0) (bs!!0),+               notAfterTime  = fromJust $ decode (as!!1) (bs!!1)+            }++{-+This is really from X.680.++GeneralizedTime ::= [UNIVERSAL 24] IMPLICIT VisibleString+-}++generalizedTime :: TypeDefn+generalizedTime =+   "Time" ::= AbsRef Universal 24 Implicit absVisibleString++data GeneralizedTime = GeneralizedTime VisibleString+   deriving (Eq,Show)++instance Encode GeneralizedTime where+   decode a b =+      do x <- decode a b+         return $ GeneralizedTime x++{-+This is really from++SelectedAttributeTypes {+   joint-iso-itu-t ds(5) module(1) selectedAttributeTypes (5) 4+   }++UniqueIdentifier ::= BIT STRING++WARNING: typechecking BIT STRING is a kludge and may not work for this.+-}++uniqueIdentifier =+   modName "UniqueIdentifier" absBitString++type UniqueIdentifier = BitString++{-+This is invalid ASN.1 even though it comes from+RFC 3281.++Attribute ::= SEQUENCE {+   type      AttributeType,+   values    SET OF AttributeValue+   -- at least one value is required+   }++AttributeType ::= OBJECT IDENTIFIER++AttributeValue ::= ANY DEFINED BY AttributeType++This is also invalid but it should be easy to support+typechecking of it.++Attribute ::= SEQUENCE {+   type  AttributeType,+   values SET OF ANY DEFINED BY type,+   -- at least one value is required+   }++The "real" definition is from++InformationFramework +{joint-iso-itu-t(2) ds(5) module(1) informationFramework(1) 3}+has a different definition:++Attribute ::= SEQUENCE {+   type +      ATTRIBUTE.&id({SupportedAttributes}),+   values+      SET SIZE (0..MAX) OF+         ATTRIBUTE.&Type({SupportedAttributes}{@type}),+   valuesWithContext+      SET SIZE (1..MAX) OF+         SEQUENCE {+            value ATTRIBUTE.&Type({SupportedAttributes}{@type}),+            contextList  SET SIZE (1..MAX) OF Context} OPTIONAL+   }++Thus we won't support valuesWithContext. Should they be present,+they will be ignored.+-}++{-+attribute :: TypeDefn+attribute =+   "Attribute" ::=+      AbsSeq Universal 16 Implicit+         [Regular (Just "type"  :>: (Nothing :@: absOID)),+          AnyDefBy 0]+-}++attribute :: TypeDefn+attribute =+   "Attribute" ::=+      AbsSeq Universal 16 Implicit [+         Regular (Just "type"  :>: (Nothing :@: absOID)),+         Regular (+            Just "values" :>: (+               Nothing :@: (+                  "SET OF AttributeValue" ::= +                     AbsSetOf Universal 17 Implicit (+                        "ANY DEFINED BY type" ::= AbsAnyDefBy 0+                     )+               )+            )+         )+      ]++data Attribute =+   Attribute {+      attributeType   :: OID,+      attributeValues :: SetOf AttributeValue+   }+   deriving (Eq,Show)++instance Encode Attribute where+   decode a b =+      do x <- b+         let as = absSeqComponents a+             bs  = encodedDefComps x+         return $+            Attribute {+               attributeType   = fromJust $ decode (as!!0) (bs!!0),+               attributeValues = fromJust $ decode (as!!1) (bs!!1)+            }++data AttributeValue = AVPS PrintableString+   deriving (Eq,Show)++instance Encode AttributeValue where+   decode a@(AbsBasePrim _ _ AbsPrintableString) b =+      do x <- decode a b+         return (AVPS x)+   decode a b =+      error (show a ++ "\n" ++ show b)+
+ Codec/Binary/Base64.hs view
@@ -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 <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> +-- and <http://www.faqs.org/rfcs/rfc2045.html>.+--+-----------------------------------------------------------------------------++module Codec.Binary.Base64 (+    encode,+    decode,+    chop72+) where++++{------------------------------------------------------------------------+This is what RFC2045 had to say:++6.8.  Base64 Content-Transfer-Encoding++   The Base64 Content-Transfer-Encoding is designed to represent+   arbitrary sequences of octets in a form that need not be humanly+   readable.  The encoding and decoding algorithms are simple, but the+   encoded data are consistently only about 33 percent larger than the+   unencoded data.  This encoding is virtually identical to the one used+   in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421.++   A 65-character subset of US-ASCII is used, enabling 6 bits to be+   represented per printable character. (The extra 65th character, "=",+   is used to signify a special processing function.)++   NOTE:  This subset has the important property that it is represented+   identically in all versions of ISO 646, including US-ASCII, and all+   characters in the subset are also represented identically in all+   versions of EBCDIC. Other popular encodings, such as the encoding+   used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and+   the base85 encoding specified as part of Level 2 PostScript, do not+   share these properties, and thus do not fulfill the portability+   requirements a binary transport encoding for mail must meet.++   The encoding process represents 24-bit groups of input bits as output+   strings of 4 encoded characters.  Proceeding from left to right, a+   24-bit input group is formed by concatenating 3 8bit input groups.+   These 24 bits are then treated as 4 concatenated 6-bit groups, each+   of which is translated into a single digit in the base64 alphabet.+   When encoding a bit stream via the base64 encoding, the bit stream+   must be presumed to be ordered with the most-significant-bit first.+   That is, the first bit in the stream will be the high-order bit in+   the first 8bit byte, and the eighth bit will be the low-order bit in+   the first 8bit byte, and so on.++   Each 6-bit group is used as an index into an array of 64 printable+   characters.  The character referenced by the index is placed in the+   output string.  These characters, identified in Table 1, below, are+   selected so as to be universally representable, and the set excludes+   characters with particular significance to SMTP (e.g., ".", CR, LF)+   and to the multipart boundary delimiters defined in RFC 2046 (e.g.,+   "-").++++                    Table 1: The Base64 Alphabet++     Value Encoding  Value Encoding  Value Encoding  Value Encoding+         0 A            17 R            34 i            51 z+         1 B            18 S            35 j            52 0+         2 C            19 T            36 k            53 1+         3 D            20 U            37 l            54 2+         4 E            21 V            38 m            55 3+         5 F            22 W            39 n            56 4+         6 G            23 X            40 o            57 5+         7 H            24 Y            41 p            58 6+         8 I            25 Z            42 q            59 7+         9 J            26 a            43 r            60 8+        10 K            27 b            44 s            61 9+        11 L            28 c            45 t            62 ++        12 M            29 d            46 u            63 /+        13 N            30 e            47 v+        14 O            31 f            48 w         (pad) =+        15 P            32 g            49 x+        16 Q            33 h            50 y++   The encoded output stream must be represented in lines of no more+   than 76 characters each.  All line breaks or other characters not+   found in Table 1 must be ignored by decoding software.  In base64+   data, characters other than those in Table 1, line breaks, and other+   white space probably indicate a transmission error, about which a+   warning message or even a message rejection might be appropriate+   under some circumstances.++   Special processing is performed if fewer than 24 bits are available+   at the end of the data being encoded.  A full encoding quantum is+   always completed at the end of a body.  When fewer than 24 input bits+   are available in an input group, zero bits are added (on the right)+   to form an integral number of 6-bit groups.  Padding at the end of+   the data is performed using the "=" character.  Since all base64+   input is an integral number of octets, only the following cases can+   arise: (1) the final quantum of encoding input is an integral+   multiple of 24 bits; here, the final unit of encoded output will be+   an integral multiple of 4 characters with no "=" padding, (2) the+   final quantum of encoding input is exactly 8 bits; here, the final+   unit of encoded output will be two characters followed by two "="+   padding characters, or (3) the final quantum of encoding input is+   exactly 16 bits; here, the final unit of encoded output will be three+   characters followed by one "=" padding character.++   Because it is used only for padding at the end of the data, the+   occurrence of any "=" characters may be taken as evidence that the+   end of the data has been reached (without truncation in transit).  No+   such assurance is possible, however, when the number of octets+   transmitted was a multiple of three and no "=" characters are+   present.++   Any characters outside of the base64 alphabet are to be ignored in+   base64-encoded data.++   Care must be taken to use the proper octets for line breaks if base64+   encoding is applied directly to text material that has not been+   converted to canonical form.  In particular, text line breaks must be+   converted into CRLF sequences prior to base64 encoding.  The+   important thing to note is that this may be done directly by the+   encoder rather than in a prior canonicalization step in some+   implementations.++   NOTE: There is no need to worry about quoting potential boundary+   delimiters within base64-encoded bodies within multipart entities+   because no hyphen characters are used in the base64 encoding.+++----------------------------------------------------------------------------}+++{-++The following properties should hold:++  decode . encode = id+  decode . chop72 . encode = id++I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input,+the second variation corresponds better with the RFC above, but outside of+MIME applications might be undesireable.++++But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only +     8 significant bits, which is more than enough for US-ASCII.  +-}+++++import Data.Array+import Data.Bits+import Data.Int+import Data.Char (chr,ord)+import Codec.Utils (Octet)++encodeArray :: Array Int Char+encodeArray = array (0,64) +          [ (0,'A'),  (1,'B'),  (2,'C'),  (3,'D'),  (4,'E'),  (5,'F')                    +          , (6,'G'),  (7,'H'),  (8,'I'),  (9,'J'),  (10,'K'), (11,'L')                    +          , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R')+          , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X')+          , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')+          , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j')+          , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p')+          , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v')+          , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1')+          , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7')+          , (60,'8'), (61,'9'), (62,'+'), (63,'/') ]+++-- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits)+-- clearly the upmost/leftmost 8 bits of the answer are 0.+-- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3.+-- 0 represents a 4 :(+int4_char3 :: [Int] -> [Char]+int4_char3 (a:b:c:d:t) = +    let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d)+    in (chr (n `shiftR` 16 .&. 0xff))+     : (chr (n `shiftR` 8 .&. 0xff))+     : (chr (n .&. 0xff)) : int4_char3 t++int4_char3 [a,b,c] =+    let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6)+    in [ (chr (n `shiftR` 16 .&. 0xff))+       , (chr (n `shiftR` 8 .&. 0xff)) ]++int4_char3 [a,b] = +    let n = (a `shiftL` 18 .|. b `shiftL` 12)+    in [ (chr (n `shiftR` 16 .&. 0xff)) ]++int4_char3 [] = []     +++++-- Convert triplets of characters to+-- 4 base64 integers.  The last entries+-- in the list may not produce 4 integers,+-- a trailing 2 character group gives 3 integers,+-- while a trailing single character gives 2 integers.+char3_int4 :: [Char] -> [Int]+char3_int4 (a:b:c:t) +    = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c)+      in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6  .&. 0x3f) : (n .&. 0x3f) : char3_int4 t++char3_int4 [a,b]+    = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8)+      in [ (n `shiftR` 18 .&. 0x3f)+         , (n `shiftR` 12 .&. 0x3f)+         , (n `shiftR` 6  .&. 0x3f) ]+    +char3_int4 [a]+    = let n = (ord a `shiftL` 16)+      in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]++char3_int4 [] = []+++-- Retrieve base64 char, given an array index integer in the range [0..63]+enc1 :: Int -> Char+enc1 ch = encodeArray!ch+++-- | Cut up a string into 72 char lines, each line terminated by CRLF.++chop72 :: String -> String+chop72 str =  let (bgn,end) = splitAt 70 str+              in if null end then bgn else "\r\n" ++ chop72 end+++-- Pads a base64 code to a multiple of 4 characters, using the special+-- '=' character.+quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t+quadruplets [a,b,c]     = [a,b,c,'=']      -- 16bit tail unit+quadruplets [a,b]       = [a,b,'=','=']    -- 8bit tail unit+quadruplets []          = []               -- 24bit tail unit+++enc :: [Int] -> [Char]+enc = quadruplets . map enc1+++dcd [] = []+dcd (h:t)+    | h <= 'Z' && h >= 'A'  =  ord h - ord 'A'      : dcd t+    | h >= '0' && h <= '9'  =  ord h - ord '0' + 52 : dcd t+    | h >= 'a' && h <= 'z'  =  ord h - ord 'a' + 26 : dcd t+    | h == '+'  = 62 : dcd t+    | h == '/'  = 63 : dcd t+    | h == '='  = []  -- terminate data stream+    | otherwise = dcd t+++-- Principal encoding and decoding functions.++encode :: [Octet] -> String+encode = enc . char3_int4 . (map (chr .fromIntegral))++{-+prop_base64 os =+   os == (f . g . h) os+      where types = (os :: [Word8])+            f = map (fromIntegral. ord)+            g = decode . encode+            h = map (chr . fromIntegral)+-}++decode :: String -> [Octet]+decode = (map (fromIntegral . ord)) . int4_char3 . dcd
+ Codec/Encryption/AES.hs view
@@ -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+
+ Codec/Encryption/AESAux.hs view
@@ -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
+	]
+-}
+
+ Codec/Encryption/Blowfish.hs view
@@ -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 +-- <http://www.counterpane.com/vectors.txt>.++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
+ Codec/Encryption/BlowfishAux.hs view
@@ -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])
+ Codec/Encryption/DES.hs view
@@ -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 <http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/>.+--+-----------------------------------------------------------------------------++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
+ Codec/Encryption/DESAux.hs view
@@ -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+
+ Codec/Encryption/Modes.hs view
@@ -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 <http://www.itl.nist.gov/fipspubs/fip81.htm> 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
+ Codec/Encryption/Padding.hs view
@@ -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 <http://www.rsasecurity.com/rsalabs/pkcs/pkcs-5>)+-- 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
+ Codec/Encryption/RSA.hs view
@@ -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+-- (<http://www.electronconsulting.com/rsa-haskell>).+--+-- 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 +-- <http://www.rsasecurity.com/rsalabs/pkcs/pkcs-1/index.html> 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
+ Codec/Encryption/RSA/EMEOAEP.hs view
@@ -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+-- (<http://www.electronconsulting.com/rsa-haskell>).+--+-- 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 +--   <ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-1/pkcs-1v2-1.pdf> 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'
+ Codec/Encryption/RSA/MGF.hs view
@@ -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:+-- <ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-1/pkcs-1v2-1.pdf>+--+-----------------------------------------------------------------------------++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)
+ Codec/Encryption/RSA/NumberTheory.hs view
@@ -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 (<it) primes))+  where it = min 2000 a++--returns greatest z where x^z | y+largestPower :: Integer -> 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 ) ) ]
+ Codec/Text/Raw.hs view
@@ -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
+ Codec/Utils.hs view
@@ -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 <ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-1/pkcs-1v2-1.pdf>+--   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
+ Crypto.cabal view
@@ -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
+ Data/Digest/MD5.hs view
@@ -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 <http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/>+-- and <http://www.ietf.org/rfc/rfc1321.txt>.+--+-----------------------------------------------------------------------------++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:[])
+ Data/Digest/MD5Aux.hs view
@@ -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+
+ Data/Digest/SHA1.hs view
@@ -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 <http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/>+-- and <http://www.itl.nist.gov/fipspubs/fip180-1.htm>.+--+-----------------------------------------------------------------------------++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:[])
+ Data/Digest/SHA1Aux.hs view
@@ -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)+
+ Data/LargeWord.hs view
@@ -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
+ PKCS8Example.hs view
@@ -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 ++ " <fileName>")+         else test (args!!0)
+ QuickTest.hs view
@@ -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
+ RSAEncryptionExample.hs view
@@ -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..."
+ RSATest.hs view
@@ -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
+ RSAVerifyExample.hs view
@@ -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..."
+ ReadMe.tex view
@@ -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}
+ Setup.hs view
@@ -0,0 +1,5 @@+module Main where+import Distribution.Simple++main :: IO ()+main = defaultMain
+ SymmetricTest.hs view
@@ -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
+ X509Example.hs view
@@ -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 ++ " <fileName>")+         else test (args!!0)