domain-auth 0.2.1 → 0.2.2
raw patch · 31 files changed
+658/−492 lines, 31 filesdep +asn1-encodingdep +asn1-typesdep +attoparsecdep −RSAdep −SHAdep −appar
Dependencies added: asn1-encoding, asn1-types, attoparsec, cryptonite, doctest, memory, pretty-simple, word8, x509
Dependencies removed: RSA, SHA, appar, binary, blaze-builder, crypto-pubkey-types
Files
- Network/DomainAuth.hs +1/−3
- Network/DomainAuth/DK.hs +5/−12
- Network/DomainAuth/DK/Parser.hs +29/−4
- Network/DomainAuth/DK/Types.hs +4/−13
- Network/DomainAuth/DK/Verify.hs +8/−4
- Network/DomainAuth/DKIM.hs +38/−12
- Network/DomainAuth/DKIM/Btag.hs +39/−16
- Network/DomainAuth/DKIM/Parser.hs +78/−5
- Network/DomainAuth/DKIM/Types.hs +3/−9
- Network/DomainAuth/DKIM/Verify.hs +17/−15
- Network/DomainAuth/Mail.hs +1/−3
- Network/DomainAuth/Mail/Mail.hs +20/−9
- Network/DomainAuth/Mail/Parser.hs +25/−6
- Network/DomainAuth/Mail/Types.hs +3/−9
- Network/DomainAuth/Mail/XMail.hs +7/−1
- Network/DomainAuth/PRD.hs +1/−3
- Network/DomainAuth/PRD/Domain.hs +20/−7
- Network/DomainAuth/PRD/Lexer.hs +70/−54
- Network/DomainAuth/PRD/PRD.hs +85/−19
- Network/DomainAuth/Pubkey/Base64.hs +17/−7
- Network/DomainAuth/Pubkey/Der.hs +0/−179
- Network/DomainAuth/Pubkey/RSAPub.hs +28/−24
- Network/DomainAuth/SPF.hs +42/−11
- Network/DomainAuth/SPF/Eval.hs +15/−14
- Network/DomainAuth/SPF/Parser.hs +47/−24
- Network/DomainAuth/SPF/Resolver.hs +3/−2
- Network/DomainAuth/SPF/Types.hs +4/−1
- Network/DomainAuth/Types.hs +5/−8
- Network/DomainAuth/Utils.hs +11/−8
- domain-auth.cabal +22/−10
- test/doctests.hs +10/−0
Network/DomainAuth.hs view
@@ -1,6 +1,4 @@-{-|- Library for Sender Policy Framework, SenderID, DomainKeys and DKIM.--}+-- | Library for Sender Policy Framework, SenderID, DomainKeys and DKIM. module Network.DomainAuth ( module Network.DomainAuth.Mail
Network/DomainAuth/DK.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -{-|- A library for DomainKeys (<http://www.ietf.org/rfc/rfc4070>).- Currently, only receiver side is implemented.--}+-- | A library for DomainKeys (<http://www.ietf.org/rfc/rfc4870.txt>).+-- Currently, only receiver side is implemented. module Network.DomainAuth.DK ( -- * Documentation@@ -16,7 +14,6 @@ , dkFieldKey ) where -import Control.Applicative import Network.DNS as DNS (Resolver) import Network.DomainAuth.DK.Parser import Network.DomainAuth.DK.Types@@ -26,9 +23,7 @@ import Network.DomainAuth.Types import qualified Data.ByteString as BS (append) -{-|- Verifying 'Mail' with DomainKeys.--}+-- | Verifying 'Mail' with DomainKeys. runDK :: Resolver -> Mail -> IO DAResult runDK resolver mail = dk1 where@@ -36,10 +31,8 @@ dk2 dkv = maybe (return DAPermError) dk3 $ parseDK (fieldValueUnfolded dkv) dk3 = runDK' resolver mail -{-|- Verifying 'Mail' with DomainKeys. The value of DomainKey-Signature:- should be parsed beforehand.--}+-- | Verifying 'Mail' with DomainKeys. The value of DomainKey-Signature:+-- should be parsed beforehand. runDK' :: Resolver -> Mail -> DK -> IO DAResult runDK' resolver mail dk = maybe DATempError (verify mail dk) <$> pub where
Network/DomainAuth/DK/Parser.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.DomainAuth.DK.Parser where+module Network.DomainAuth.DK.Parser (+ parseDK+ ) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS@@ -10,9 +12,32 @@ import Network.DomainAuth.DK.Types import Network.DomainAuth.Mail -{-|- Parsing DomainKey-Signature:.--}+-- $setup+-- >>> import Text.Pretty.Simple+-- >>> import Data.ByteString.Char8 as BS8+++-- | Parsing DomainKey-Signature:.+--+-- >>> :{+-- let dk = BS8.concat [+-- "a=rsa-sha1; s=brisbane; d=football.example.com;\n"+-- , " c=simple; q=dns;\n"+-- , " b=dzdVyOfAKCdLXdJOc9G2q8LoXSlEniSbav+yuU4zGeeruD00lszZ\n"+-- , " VoG4ZHRNiYzR;"+-- ]+-- in pPrintNoColor $ parseDK dk+-- :}+-- Just +-- ( DK +-- { dkAlgorithm = DK_RSA_SHA1+-- , dkSignature = "dzdVyOfAKCdLXdJOc9G2q8LoXSlEniSbav+yuU4zGeeruD00lszZVoG4ZHRNiYzR"+-- , dkCanonAlgo = DK_SIMPLE+-- , dkDomain0 = "football.example.com"+-- , dkFields = Nothing+-- , dkSelector0 = "brisbane"+-- } +-- ) parseDK :: RawFieldValue -> Maybe DK parseDK val = toDK domkey where
Network/DomainAuth/DK/Types.hs view
@@ -9,9 +9,7 @@ ---------------------------------------------------------------- -{-|- Canonicalized key for DomainKey-Signature:.--}+-- | Canonicalized key for DomainKey-Signature:. dkFieldKey :: CanonFieldKey dkFieldKey = "domainkey-signature" @@ -22,10 +20,7 @@ --data DkQuery = DK_DNS deriving (Eq,Show) type DkFields = M.Map ByteString Bool -- Key Bool -{-|- Abstract type for DomainKey-Signature:--}-+-- | Abstract type for DomainKey-Signature: data DK = DK { dkAlgorithm :: DkAlgorithm , dkSignature :: ByteString@@ -36,14 +31,10 @@ , dkSelector0 :: ByteString } deriving (Eq,Show) -{-|- Getting of the value of the \"d\" tag in DomainKey-Signature:.--}+-- | Getting of the value of the \"d\" tag in DomainKey-Signature:. dkDomain :: DK -> Domain dkDomain = dkDomain0 -{-|- Getting of the value of the \"s\" tag in DomainKey-Signature:.--}+-- | Getting of the value of the \"s\" tag in DomainKey-Signature:. dkSelector :: DK -> ByteString dkSelector = dkSelector0
Network/DomainAuth/DK/Verify.hs view
@@ -4,9 +4,13 @@ verifyDK, prepareDK ) where -import Blaze.ByteString.Builder-import Codec.Crypto.RSA+import Crypto.Hash+import Crypto.PubKey.RSA+import Crypto.PubKey.RSA.PKCS15 import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL import qualified Data.Map as M import Network.DomainAuth.DK.Types import Network.DomainAuth.Mail@@ -53,7 +57,7 @@ ---------------------------------------------------------------- verifyDK :: Mail -> DK -> PublicKey -> Bool-verifyDK mail dk pub = rsassa_pkcs1_v1_5_verify hashSHA1 pub cmail sig+verifyDK mail dk pub = verify (Just SHA1) pub cmail sig where sig = B.decode . dkSignature $ dk- cmail = toLazyByteString (prepareDK dk mail)+ cmail = BL.toStrict $ BB.toLazyByteString $ prepareDK dk mail
Network/DomainAuth/DKIM.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -{-|- A library for DKIM (<http://www.ietf.org/rfc/rfc4071>).- Currently, only receiver side is implemented.--}+-- | A library for DKIM (<http://www.ietf.org/rfc/rfc6376.txt>).+-- Currently, only receiver side is implemented. module Network.DomainAuth.DKIM ( -- * Documentation@@ -17,7 +15,6 @@ ) where import qualified Data.ByteString as BS-import Control.Applicative import Network.DNS as DNS (Resolver) import Network.DomainAuth.DKIM.Parser import Network.DomainAuth.DKIM.Types@@ -26,9 +23,40 @@ import Network.DomainAuth.Pubkey.RSAPub import Network.DomainAuth.Types -{-|- Verifying 'Mail' with DKIM.--}+-- $setup+-- >>> import Network.DNS+-- >>> import Data.ByteString.Char8 as BS8++-- | Verifying 'Mail' with DKIM.+--+-- >>> rs <- makeResolvSeed defaultResolvConf+-- >>> :{+-- let lst = ["DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;"+-- ," d=gmail.com; s=20161025;"+-- ," h=mime-version:from:date:message-id:subject:to;"+-- ," bh=IQB23UrpTWE7dPV0Ebeqy3ZJyCILT/tw2Ixhmh83FJ0=;"+-- ," b=BCZrZwEnJfrdbbNqM+bWHeDrdHKvc6DvjafGCDndUUkHPbfVvvx2RTYfkC3LT1uCZC"+-- ," 7vzKmucESLK5PVh4mAGNQjHDmdvhq7GIubOVK8Uoq+MpjZ321SwNI7rck/uLq512bfvO"+-- ," NU9nYcUGNIKh+rho6V8XHX/REsfE+a8jGUvywZgV5IoORfTvejEluuy360PN0rAjSmi3"+-- ," j5WRFV7XR5pCzAN78hmsUaTzf8zdwQwIlSsnUylnlRmc97xU5Ou3VBzxBV+ScXZsX5jI"+-- ," TNv+ujuZcoO0fS0zm7UwmcOzXb01cQpBDqHK8cBvEdQ4+8LSx/Nf1UaOBrecw6GiwN23"+-- ," BFBg=="+-- ,"MIME-Version: 1.0"+-- ,"Received: by 10.37.15.133 with HTTP; Wed, 20 Sep 2017 01:19:02 -0700 (PDT)"+-- ,"From: Kazu Yamamoto <kazu.yamamoto@gmail.com>"+-- ,"Date: Wed, 20 Sep 2017 17:19:02 +0900"+-- ,"Message-ID: <CAKipW39GqeTzzQzB6WhM86_P==xTHwioa5gE=wZZ96fzf1j3Vw@mail.gmail.com>"+-- ,"Subject: test for DKIM"+-- ,"To: Kazu Yamamoto <kazu@iij.ad.jp>"+-- ,"Content-Type: text/plain; charset=\"UTF-8\""+-- ,""+-- ,"this is test."+-- ,""+-- ]+-- mail = getMail $ BS8.intercalate "\r\n" lst+-- in withResolver rs $ \rslv -> runDKIM rslv mail+-- :}+-- pass runDKIM :: Resolver -> Mail -> IO DAResult runDKIM resolver mail = dkim1 where@@ -36,10 +64,8 @@ dkim2 dkimv = maybe (return DAPermError) dkim3 $ parseDKIM (fieldValueUnfolded dkimv) dkim3 = runDKIM' resolver mail -{-|- Verifying 'Mail' with DKIM. The value of DKIM-Signature:- should be parsed beforehand.--}+-- | Verifying 'Mail' with DKIM. The value of DKIM-Signature:+-- should be parsed beforehand. runDKIM' :: Resolver -> Mail -> DKIM -> IO DAResult runDKIM' resolver mail dkim = maybe DATempError (verify mail dkim) <$> pub where
Network/DomainAuth/DKIM/Btag.hs view
@@ -1,24 +1,47 @@-module Network.DomainAuth.DKIM.Btag where+{-# LANGUAGE OverloadedStrings #-} +module Network.DomainAuth.DKIM.Btag (+ removeBtagValue+ ) where++import Control.Applicative import Control.Monad-import Data.ByteString.Char8-import Data.Maybe-import Text.Appar.ByteString+import Data.Attoparsec.ByteString (Parser)+import qualified Data.Attoparsec.ByteString as P+import qualified Data.Attoparsec.Combinator as P (option)+import Data.ByteString as BS+import Data.ByteString.Builder (Builder)+import Data.ByteString.Lazy (toStrict)+import qualified Data.ByteString.Builder as B+import Data.ByteString.Char8 ()+import Data.Monoid+import Data.Word8 +-- |+--+-- >>> removeBtagValue "DKIM-Signature: a=rsa-sha256; d=example.net; s=brisbane;\n c=simple; q=dns/txt; i=@eng.example.net;\n t=1117574938; x=1118006938;\n h=from:to:subject:date;\n z=From:foo@eng.example.net|To:joe@example.com|\n Subject:demo=20run|Date:July=205,=202005=203:44:08=20PM=20-0700;\n bh=MTIzNDU2Nzg5MDEyMzQ1Njc4OTAxMjM0NTY3ODkwMTI=;\n b=dzdVyOfAKCdLXdJOc9G2q8LoXSlEniSbav+yuU4zGeeruD00lszZ\n VoG4ZHRNiYzR;\n"+-- "DKIM-Signature: a=rsa-sha256; d=example.net; s=brisbane;\n c=simple; q=dns/txt; i=@eng.example.net;\n t=1117574938; x=1118006938;\n h=from:to:subject:date;\n z=From:foo@eng.example.net|To:joe@example.com|\n Subject:demo=20run|Date:July=205,=202005=203:44:08=20PM=20-0700;\n bh=MTIzNDU2Nzg5MDEyMzQ1Njc4OTAxMjM0NTY3ODkwMTI=;\n b=;\n" removeBtagValue :: ByteString -> ByteString-removeBtagValue = pack . fromMaybe "" . parse remBtagValue+removeBtagValue inp = case P.parseOnly remBtagValue inp of+ Left _ -> ""+ Right bs -> toStrict $ B.toLazyByteString bs -remBtagValue :: Parser String-remBtagValue = (++) <$> inFix btag <*> many anyChar+remBtagValue :: Parser Builder+remBtagValue = (<>) <$> inFix btag <*> anyString+ where+ anyString = B.byteString <$> P.takeWhile (const True) -inFix :: Parser String -> Parser String-inFix p = try p <|> (:) <$> anyChar <*> inFix p+inFix :: Parser Builder -> Parser Builder+inFix p = P.try p <|> (<>) <$> anyWord8 <*> inFix p+ where+ anyWord8 = B.word8 <$> P.anyWord8 -btag :: Parser String+btag :: Parser Builder btag = do- b <- string "b"- w <- many $ oneOf " \t\r\n"- e <- string "="- void . some $ noneOf ";"- s <- option "" (string ";")- return $ b ++ w ++ e ++ s+ b <- B.word8 <$> P.word8 _b+ w <- B.byteString <$> P.takeWhile (P.inClass " \t\r\n")+ e <- B.word8 <$> P.word8 _equal+ void $ P.takeWhile1 (P.notInClass ";")+ s <- P.option mempty (B.word8 <$> P.word8 _semicolon)+ return (b <> w <> e <> s)+
Network/DomainAuth/DKIM/Parser.hs view
@@ -1,17 +1,90 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.DomainAuth.DKIM.Parser where+module Network.DomainAuth.DKIM.Parser (+ parseDKIM+ ) where -import Control.Applicative import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Maybe import Network.DomainAuth.DKIM.Types import Network.DomainAuth.Mail -{-|- Parsing DKIM-Signature:.--}+-- $setup+-- >>> import Text.Pretty.Simple+-- >>> import Data.ByteString.Char8 as BS8++-- | Parsing DKIM-Signature:.+--+-- >>> :{+-- let dkim = BS8.concat [+-- "v=1; a=rsa-sha256; s=brisbane; d=example.com;\n"+-- , " c=relaxed/simple; q=dns/txt; i=joe@football.example.com;\n"+-- , " h=Received : From : To : Subject : Date : Message-ID;\n"+-- , " bh=2jUSOH9NhtVGCQWNr9BrIAPreKQjO6Sn7XIkfJVOzv8=;\n"+-- , " b=AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB\n"+-- , " 4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHut\n"+-- , " KVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV\n"+-- , " 4bmp/YzhwvcubU4=;"+-- ]+-- in pPrintNoColor $ parseDKIM dkim+-- :}+-- Just +-- ( DKIM +-- { dkimVersion = "1"+-- , dkimSigAlgo = RSA_SHA256+-- , dkimSignature = "AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHutKVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV4bmp/YzhwvcubU4="+-- , dkimBodyHash = "2jUSOH9NhtVGCQWNr9BrIAPreKQjO6Sn7XIkfJVOzv8="+-- , dkimHeaderCanon = DKIM_RELAXED+-- , dkimBodyCanon = DKIM_SIMPLE+-- , dkimDomain0 = "example.com"+-- , dkimFields = +-- [ "received"+-- , "from"+-- , "to"+-- , "subject"+-- , "date"+-- , "message-id"+-- ] +-- , dkimLength = Nothing+-- , dkimSelector0 = "brisbane"+-- } +-- )+--+-- >>> :{+-- let dkim = BS8.concat [+-- "v=1; a=rsa-sha256; s=brisbane; d=example.com;\n"+-- , " q=dns/txt; i=joe@football.example.com;\n"+-- , " h=Received : From : To : Subject : Date : Message-ID;\n"+-- , " bh=2jUSOH9NhtVGCQWNr9BrIAPreKQjO6Sn7XIkfJVOzv8=;\n"+-- , " b=AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB\n"+-- , " 4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHut\n"+-- , " KVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV\n"+-- , " 4bmp/YzhwvcubU4=;"+-- ]+-- in pPrintNoColor $ parseDKIM dkim+-- :}+-- Just +-- ( DKIM +-- { dkimVersion = "1"+-- , dkimSigAlgo = RSA_SHA256+-- , dkimSignature = "AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHutKVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV4bmp/YzhwvcubU4="+-- , dkimBodyHash = "2jUSOH9NhtVGCQWNr9BrIAPreKQjO6Sn7XIkfJVOzv8="+-- , dkimHeaderCanon = DKIM_SIMPLE+-- , dkimBodyCanon = DKIM_SIMPLE+-- , dkimDomain0 = "example.com"+-- , dkimFields = +-- [ "received"+-- , "from"+-- , "to"+-- , "subject"+-- , "date"+-- , "message-id"+-- ] +-- , dkimLength = Nothing+-- , dkimSelector0 = "brisbane"+-- } +-- ) parseDKIM :: RawFieldValue -> Maybe DKIM parseDKIM val = toDKIM domkey where
Network/DomainAuth/DKIM/Types.hs view
@@ -8,9 +8,7 @@ ---------------------------------------------------------------- -{-|- Canonicalized key for DKIM-Signature:.--}+-- | Canonicalized key for DKIM-Signature:. dkimFieldKey :: CanonFieldKey dkimFieldKey = "dkim-signature" @@ -32,14 +30,10 @@ , dkimSelector0 :: ByteString } deriving (Eq,Show) -{-|- Getting of the value of the \"d\" tag in DKIM-Signature:.--}+-- | Getting of the value of the \"d\" tag in DKIM-Signature:. dkimDomain :: DKIM -> Domain dkimDomain = dkimDomain0 -{-|- Getting of the value of the \"s\" tag in DKIM-Signature:.--}+-- | Getting of the value of the \"s\" tag in DKIM-Signature:. dkimSelector :: DKIM -> ByteString dkimSelector = dkimSelector0
Network/DomainAuth/DKIM/Verify.hs view
@@ -4,12 +4,15 @@ verifyDKIM, prepareDKIM ) where -import Blaze.ByteString.Builder-import Codec.Crypto.RSA+import Crypto.Hash+import Crypto.PubKey.RSA+import Crypto.PubKey.RSA.PKCS15+import Data.ByteArray import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder) import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL-import Data.Digest.Pure.SHA import Network.DomainAuth.DKIM.Btag import Network.DomainAuth.DKIM.Types import Network.DomainAuth.Mail@@ -23,7 +26,7 @@ where dkimField:fields = fieldsFrom dkimFieldKey (mailHeader mail) hCanon = canonDkimField (dkimHeaderCanon dkim)- canon = fromByteString . removeBtagValue . hCanon+ canon = BB.byteString . removeBtagValue . hCanon targets = fieldsWith (dkimFields dkim) fields header = concatCRLFWith hCanon targets +++ canon dkimField @@ -47,19 +50,18 @@ verifyDKIM :: Mail -> DKIM -> PublicKey -> Bool verifyDKIM mail dkim pub = bodyHash1 mail == bodyHash2 dkim &&- rsassa_pkcs1_v1_5_verify hashfunc pub cmail sig+ verify' (dkimSigAlgo dkim) pub cmail sig where- hashfunc = hashAlgo1 (dkimSigAlgo dkim)- hashfunc2 = hashAlgo2 (dkimSigAlgo dkim) sig = B.decode . dkimSignature $ dkim- cmail = toLazyByteString (prepareDKIM dkim mail)- bodyHash1 = hashfunc2 . toLazyByteString . canonDkimBody (dkimBodyCanon dkim) . mailBody+ cmail = BL.toStrict $ BB.toLazyByteString $ prepareDKIM dkim mail+ bodyHash1 = hashAlgo2 (dkimSigAlgo dkim) . BL.toStrict . BB.toLazyByteString . canonDkimBody (dkimBodyCanon dkim) . mailBody bodyHash2 = B.decode . dkimBodyHash -hashAlgo1 :: DkimSigAlgo -> HashInfo-hashAlgo1 RSA_SHA1 = hashSHA1-hashAlgo1 RSA_SHA256 = hashSHA256+verify' :: DkimSigAlgo-> PublicKey -> ByteString -> ByteString -> Bool+verify' RSA_SHA1 = verify (Just SHA1)+verify' RSA_SHA256 = verify (Just SHA256) -hashAlgo2 :: DkimSigAlgo -> BL.ByteString -> BL.ByteString-hashAlgo2 RSA_SHA1 = bytestringDigest . sha1-hashAlgo2 RSA_SHA256 = bytestringDigest . sha256+hashAlgo2 :: ByteArray c => DkimSigAlgo -> ByteString -> c+hashAlgo2 RSA_SHA1 = convert . (hash :: ByteString -> Digest SHA1)+hashAlgo2 RSA_SHA256 = convert . (hash :: ByteString -> Digest SHA256)+
Network/DomainAuth/Mail.hs view
@@ -1,6 +1,4 @@-{-|- A library to parse e-mail messages both from a file and Milter(<https://www.milter.org/>).--}+-- | A library to parse e-mail messages both from a file and Milter(<https://www.milter.org/>). module Network.DomainAuth.Mail ( -- * Documentation
Network/DomainAuth/Mail/Mail.hs view
@@ -1,16 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.DomainAuth.Mail.Mail where+module Network.DomainAuth.Mail.Mail (+ lookupField+ , fieldsFrom+ , fieldsAfter+ , fieldsWith+ , fieldValueFolded+ , fieldValueUnfolded+ , fromBody+ , fromBodyWith+ , removeTrailingEmptyLine+ ) where -import Blaze.ByteString.Builder import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BL import qualified Data.Foldable as F (foldr) import Data.List import Data.Sequence (Seq, viewr, ViewR(..), empty) import Network.DomainAuth.Mail.Types-import Network.DomainAuth.Utils hiding (empty) import qualified Network.DomainAuth.Utils as B (empty)+import Network.DomainAuth.Utils hiding (empty) ---------------------------------------------------------------- @@ -33,9 +45,8 @@ safeTail [] = [] safeTail xs = tail xs -{-- RFC 4871 is ambiguous, so implement only normal case.--}+-- RFC 4871 is ambiguous, so implement only normal case.+ -- | Obtaining all fields with DKIM algorithm. fieldsWith :: [CanonFieldKey] -> Header -> Header fieldsWith [] _ = []@@ -60,11 +71,11 @@ -- | Obtaining folded (raw) field value. fieldValueFolded :: Field -> RawFieldValue-fieldValueFolded = toByteString . concatCRLF . fieldValue+fieldValueFolded = BL.toStrict . BB.toLazyByteString . concatCRLF . fieldValue -- | Obtaining unfolded (removing CRLF) field value. fieldValueUnfolded :: Field -> RawFieldValue-fieldValueUnfolded = BS.concat . fieldValue+fieldValueUnfolded = BS8.concat . fieldValue ----------------------------------------------------------------
Network/DomainAuth/Mail/Parser.hs view
@@ -1,14 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.DomainAuth.Mail.Parser where+module Network.DomainAuth.Mail.Parser (+ readMail+ , getMail+ , parseTaggedValue+ ) where -import Control.Applicative import qualified Data.ByteString as BS import Data.Word import Network.DomainAuth.Mail.Types import Network.DomainAuth.Mail.XMail import Network.DomainAuth.Utils +-- $setup+-- >>> :set -XOverloadedStrings+ ---------------------------------------------------------------- -- | Obtain 'Mail' from a file.@@ -18,6 +24,16 @@ ---------------------------------------------------------------- -- | Obtain 'Mail' from 'RawMail'.+--+-- >>> let out1 = finalizeMail $ pushBody "body" $ pushField "to" "val" $ pushField "from" "val" initialXMail+-- >>> getMail "from: val\nto: val\n\nbody" == out1+-- True+-- >>> let out2 = finalizeMail $ pushBody "body" $ pushField "to" "val" $ pushField "from" "val\tval" initialXMail+-- >>> getMail "from: val\tval\nto: val\n\nbody" == out2+-- True+-- >>> let out3 = finalizeMail $ pushBody "" $ pushField "to" "val" $ pushField "from" "val" initialXMail+-- >>> getMail "from: val\nto: val\n" == out3+-- True getMail :: RawMail -> Mail getMail bs = finalizeMail $ pushBody rbdy xmail where@@ -103,11 +119,14 @@ else v ------------------------------------------------------------------{-|- Parsing field value of tag=value.--} -- This breaks spaces in the note tag.++-- | Parsing field value of tag=value.+--+-- >>> parseTaggedValue " k = rsa ; p= MIGfMA0G; n=A 1024 bit key;"+-- [("k","rsa"),("p","MIGfMA0G"),("n","A1024bitkey")]+-- >>> parseTaggedValue " k = \nrsa ;\n p= MIGfMA0G;\n n=A 1024 bit key"+-- [("k","rsa"),("p","MIGfMA0G"),("n","A1024bitkey")] parseTaggedValue :: RawFieldValue -> [(BS.ByteString,BS.ByteString)] parseTaggedValue xs = vss where
Network/DomainAuth/Mail/Types.hs view
@@ -20,9 +20,7 @@ ---------------------------------------------------------------- -{-|- Type for parsed e-mail message.--}+-- | Type for parsed e-mail message. data Mail = Mail { mailHeader :: Header , mailBody :: Body@@ -31,14 +29,10 @@ isEmpty :: Body -> Bool isEmpty = (== empty) -{-|- Header type for parsed e-mail message.--}+-- | Header type for parsed e-mail message. type Header = [Field] -{-|- Field type for parsed e-mail message.--}+-- | Field type for parsed e-mail message. data Field = Field { fieldSearchKey :: CanonFieldKey , fieldKey :: FieldKey
Network/DomainAuth/Mail/XMail.hs view
@@ -1,4 +1,10 @@-module Network.DomainAuth.Mail.XMail where+module Network.DomainAuth.Mail.XMail (+ XMail(..)+ , initialXMail+ , pushField+ , pushBody+ , finalizeMail+ ) where import qualified Data.ByteString.Char8 as BS import Data.Sequence (fromList)
Network/DomainAuth/PRD.hs view
@@ -1,6 +1,4 @@-{-|- Utilities to decide Purported Responsible Domain (<http://www.ietf.org/rfc/rfc4407>).--}+-- | Utilities to decide Purported Responsible Domain (<http://www.ietf.org/rfc/rfc4407.txt>). module Network.DomainAuth.PRD ( module Network.DomainAuth.PRD.PRD
Network/DomainAuth/PRD/Domain.hs view
@@ -1,18 +1,31 @@-module Network.DomainAuth.PRD.Domain (extractDomain) where+{-# LANGUAGE OverloadedStrings #-} +module Network.DomainAuth.PRD.Domain (+ extractDomain+ ) where+ import Network.DNS (Domain) import Network.DomainAuth.Mail import Network.DomainAuth.PRD.Lexer-import Text.Appar.ByteString+import qualified Data.Attoparsec.ByteString as P import qualified Data.ByteString.Char8 as BS -{-|- Extract a domain from a value of a header field.--}+-- | Extract a domain from a value of a header field.+--+-- >>> extractDomain "Alice Brown <alice.brown@example.com>"+-- Just "example.com"+-- >>> extractDomain "\"Alice . Brown\" <alice.brown@example.com> (Nickname here)"+-- Just "example.com"+-- >>> extractDomain "alice.brown@example.com"+-- Just "example.com"+-- >>> extractDomain "Alice Brown <example.com>"+-- Nothing extractDomain :: RawFieldValue -> Maybe Domain-extractDomain bs = parse structured bs >>= takeDomain+extractDomain bs = case P.parseOnly structured bs of+ Left _ -> Nothing+ Right st -> takeDomain st where takeDomain = dropTail . dropWhile (/="@") dropTail [] = Nothing- dropTail xs = (Just . BS.pack . concat . takeWhile (/=">") . tail) xs+ dropTail xs = (Just . BS.concat . takeWhile (/=">") . tail) xs
Network/DomainAuth/PRD/Lexer.hs view
@@ -1,99 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}+ module Network.DomainAuth.PRD.Lexer ( structured ) where -import Text.Appar.ByteString+import Control.Applicative+import Data.Attoparsec.ByteString (Parser)+import qualified Data.Attoparsec.ByteString as P+import qualified Data.Attoparsec.Combinator as P (choice)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Char8 ()+import Data.Word8 ---------------------------------------------------------------- -concatSpace :: [String] -> String-concatSpace = unwords+concatSpace :: [ByteString] -> ByteString+concatSpace = BS.intercalate " " ---------------------------------------------------------------- -skipChar :: Char -> Parser ()-skipChar c = () <$ char c+skipChar :: Word8 -> Parser ()+skipChar c = () <$ P.word8 c -wsp :: Parser Char-wsp = oneOf " \t\n"+skipWsp :: Parser ()+skipWsp = P.skipWhile $ P.inClass " \t\n" ---------------------------------------------------------------- -structured :: Parser [String]-structured = removeComments <$> many (choice choices)+-- |+--+-- >>> P.parseOnly structured "From: Kazu Yamamoto (=?iso-2022-jp?B?GyRCOzNLXE9CSScbKEI=?=)\n <kazu@example.net>"+-- Right ["From",":","Kazu","Yamamoto","<","kazu","@","example",".","net",">"]+-- >>> P.parseOnly structured "To:A Group(Some people)\n :Chris Jones <c@(Chris's host.)public.example>,\n joe@example.org,\n John <jdoe@one.test> (my dear friend); (the end of the group)\n"+-- Right ["To",":","A","Group",":","Chris","Jones","<","c","@","public",".","example",">",",","joe","@","example",".","org",",","John","<","jdoe","@","one",".","test",">",";"]+-- >>> P.parseOnly structured "Date: Thu,\n 13\n Feb\n 1969\n 23:32\n -0330 (Newfoundland Time)\n"+-- Right ["Date",":","Thu",",","13","Feb","1969","23",":","32","-0330"]+-- >>> P.parseOnly structured "From: Pete(A nice \\) chap) <pete(his account)@silly.test(his host)>\n"+-- Right ["From",":","Pete","<","pete","@","silly",".","test",">"]+structured :: Parser [ByteString]+structured = removeComments <$> many (P.choice choices) where removeComments = filter (/="") choices = [specials,quotedString,domainLiteral,atom,comment] -specials :: Parser String-specials = toStr <$> (specialChar <* skipMany wsp)+specials :: Parser ByteString+specials = specialChar <* skipWsp where -- removing "()[]\\\""- specialChar = oneOf "<>:;@=,."- toStr c = [c]+ specialChar = BS.singleton <$> word8in "<>:;@=,." ---------------------------------------------------------------- -atext :: Parser Char-atext = alphaNum <|> oneOf "!#$%&'*+-/=?^_`{|}~"--atom :: Parser String-atom = some atext <* skipMany wsp+atom :: Parser ByteString+atom = atext <* skipWsp+ where+ atext = P.takeWhile1 $ P.inClass "0-9a-zA-Z!#$%&'*+/=?^_`{|}~-" ---------------------------------------------------------------- -dtext :: Parser Char-dtext = oneOf $ ['!' .. 'Z'] ++ ['^' .. '~']--domainLiteral :: Parser String+domainLiteral :: Parser ByteString domainLiteral = do- skipChar '['- ds <- many (some dtext <* skipMany wsp)- skipChar ']'- skipMany wsp- return (concatSpace ds)+ skipChar _bracketleft+ ds <- many (dtext <* skipWsp)+ skipChar _bracketright+ skipWsp+ return $ concatSpace ds+ where+ dtext = P.takeWhile1 $ P.inClass "!-Z^-~" ---------------------------------------------------------------- -qtext :: Parser Char-qtext = oneOf $ "!" ++ ['#' .. '['] ++ [']' .. '~']+word8in :: String -> Parser Word8+word8in = P.satisfy . P.inClass -qcontent :: Parser Char+qtext :: Parser Word8+qtext = word8in "!#-[]-~"++qcontent :: Parser Word8 qcontent = qtext <|> quoted_pair -quotedString :: Parser String+quotedString :: Parser ByteString quotedString = do- skipChar '"'- skipMany wsp- qs <- many (some qcontent <* skipMany wsp)- skipChar '"'- skipMany wsp- return (concatSpace qs)+ skipChar _quotedbl+ skipWsp+ qs <- map BS.pack <$> many (some qcontent <* skipWsp)+ skipChar _quotedbl+ skipWsp+ return $ concatSpace qs ---------------------------------------------------------------- -vchar :: Parser Char-vchar = oneOf ['!'..'~']--quoted_pair :: Parser Char-quoted_pair = skipChar '\\' >> (vchar <|> wsp)+quoted_pair :: Parser Word8+quoted_pair = skipChar _backslash >> word8in "!-~ \t\n" -- vchar ++ wsp ---------------------------------------------------------------- -ctext :: Parser Char-ctext = oneOf $ ['!' .. '\''] ++ ['*' .. '['] ++ [']' .. '~']+ctext :: Parser Word8+ctext = word8in "!-'*-[]-~" -ccontent :: Parser String-ccontent = some (ctext <|> quoted_pair)+ccontent :: Parser ()+ccontent = () <$ some (ctext <|> quoted_pair) -comment' :: Parser String+comment' :: Parser () comment' = do- skipChar '('- skipMany wsp- cs <- many ((ccontent <|> comment') <* skipMany wsp)- skipChar ')'- skipMany wsp- return (concatSpace cs)+ skipChar _parenleft+ skipWsp+ _ <- many ((ccontent <|> comment') <* skipWsp)+ skipChar _parenright+ skipWsp+ return () -comment :: Parser String+comment :: Parser ByteString comment = "" <$ comment'
Network/DomainAuth/PRD/PRD.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-|- Purported Responsible Domain, RFC 4407.--}+-- | Purported Responsible Domain, RFC 4407. module Network.DomainAuth.PRD.PRD ( PRD@@ -24,10 +22,8 @@ data DST = DST_Zero | DST_Invalid | DST_Valid Domain deriving (Eq, Show) -{-|- Abstract type for context to decide PRD(purported responsible domain)- according to RFC 4407.--}+-- | Abstract type for context to decide PRD(purported responsible domain)+-- according to RFC 4407. data PRD = PRD { praFrom :: DST , praSender :: DST@@ -36,9 +32,7 @@ , praHeader :: HD } deriving Show -{-|- Initial context of PRD.--}+-- | Initial context of PRD. initialPRD :: PRD initialPRD = PRD { praFrom = DST_Zero@@ -50,9 +44,7 @@ ---------------------------------------------------------------- -{-|- Pushing a field key and its value in to the PRD context.--}+-- | Pushing a field key and its value in to the PRD context. pushPRD :: RawFieldKey -> RawFieldValue -> PRD -> PRD pushPRD key val ctx = case ckey of "from" -> pushFrom ctx' jdom@@ -65,9 +57,81 @@ jdom = extractDomain val ctx' = ctx { praHeader = (ckey,val) : praHeader ctx } -{-|- Deciding PRD from the RPD context.--}+-- | Deciding PRD from the RPD context.+--+-- >>> let maddr1 = "alice@alice.example.jp"+-- >>> let maddr2 = "bob@bob.example.jp"+-- >>> let maddr3 = "chris@chris.example.jp"+-- >>> let maddr4 = "dave@dave.example.jp"+-- >>> decidePRD (pushPRD "from" "alice@alice.example.jp" initialPRD)+-- Just "alice.example.jp"+-- >>> :{+-- decidePRD (pushPRD "from" maddr1+-- $ pushPRD "from" maddr1 initialPRD)+-- :}+-- Nothing+--+-- >>> :{+-- decidePRD (pushPRD "sender" maddr2+-- $ pushPRD "from" maddr1+-- $ pushPRD "from" maddr1 initialPRD)+-- :}+-- Just "bob.example.jp"+--+-- >>> :{+-- decidePRD (pushPRD "sender" maddr2+-- $ pushPRD "sender" maddr2+-- $ pushPRD "from" maddr1+-- $ pushPRD "from" maddr1 initialPRD)+-- :}+-- Nothing+--+-- >>> :{+-- decidePRD (pushPRD "resent-from" maddr3+-- $ pushPRD "sender" maddr2+-- $ pushPRD "sender" maddr2+-- $ pushPRD "from" maddr1+-- $ pushPRD "from" maddr1 initialPRD)+-- :}+-- Just "chris.example.jp"+--+-- >>> :{+-- decidePRD (pushPRD "resent-sender" maddr4+-- $ pushPRD "resent-from" maddr3+-- $ pushPRD "sender" maddr2+-- $ pushPRD "sender" maddr2+-- $ pushPRD "from" maddr1+-- $ pushPRD "from" maddr1 initialPRD)+-- :}+-- Just "dave.example.jp"+--+-- >>> :{+-- decidePRD (pushPRD "resent-sender" maddr4+-- $ pushPRD "resent-from" maddr3+-- $ pushPRD "sender" maddr2+-- $ pushPRD "received" "dummy"+-- $ pushPRD "from" maddr1 initialPRD)+-- :}+-- Just "dave.example.jp"+--+-- >>> :{+-- decidePRD (pushPRD "resent-sender" maddr4+-- $ pushPRD "received" "dummy"+-- $ pushPRD "resent-from" maddr3+-- $ pushPRD "sender" maddr2+-- $ pushPRD "from" maddr1 initialPRD)+-- :}+-- Just "chris.example.jp"+--+-- >>> :{+-- decidePRD (pushPRD "received" "dummy"+-- $ pushPRD "resent-sender" maddr4+-- $ pushPRD "resent-from" maddr3+-- $ pushPRD "sender" maddr2+-- $ pushPRD "from" maddr1 initialPRD)+-- :}+-- Just "dave.example.jp"+ decidePRD :: PRD -> Maybe Domain decidePRD ctx = let jds = [ praResentSender ctx@@ -76,9 +140,11 @@ , praFrom ctx ] in foldl' mplus mzero $ map toMaybe jds-{-|- Taking the value of From: from the RPD context.--}++-- | Taking the value of From: from the RPD context.+--+-- >>> decideFrom (pushPRD "from" "alice@alice.example.jp" initialPRD)+-- Just "alice.example.jp" decideFrom :: PRD -> Maybe Domain decideFrom = toMaybe . praFrom
Network/DomainAuth/Pubkey/Base64.hs view
@@ -1,21 +1,29 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.DomainAuth.Pubkey.Base64 where+module Network.DomainAuth.Pubkey.Base64 (+ decode+ , decode'+ ) where -import Blaze.ByteString.Builder import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder) import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL+import Data.Monoid ((<>)) import Data.Word import Network.DomainAuth.Utils isBase64 :: Word8 -> Bool isBase64 c = isAlphaNum c || (c `elem` [cPlus,cSlash,cEqual]) -decode :: ByteString -> BL.ByteString-decode = toLazyByteString . dec . BS.filter isBase64+decode :: ByteString -> ByteString+decode = BL.toStrict . decode' +decode' :: ByteString -> BL.ByteString+decode' = BB.toLazyByteString . dec . BS.filter isBase64+ dec :: ByteString -> Builder dec bs | BS.null bs = empty@@ -36,19 +44,19 @@ bs' = BS.drop 4 bs dec' :: Word8 -> Word8 -> Word8 -> Word8 -> Builder-dec' x1 x2 x3 x4 = fromWord8s [d1,d2,d3]+dec' x1 x2 x3 x4 = BB.word8 d1 <> BB.word8 d2 <> BB.word8 d3 where d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4) d2 = ((x2 `shiftL` 4) .&. 0xF0) .|. (x3 `shiftR` 2) d3 = ((x3 `shiftL` 6) .&. 0xC0) .|. x4 dec1' :: Word8 -> Word8 -> Builder-dec1' x1 x2 = fromWord8 d1+dec1' x1 x2 = BB.word8 d1 where d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4) dec2' :: Word8 -> Word8 -> Word8 -> Builder-dec2' x1 x2 x3 = fromWord8s [d1,d2]+dec2' x1 x2 x3 = BB.word8 d1 <> BB.word8 d2 where d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4) d2 = ((x2 `shiftL` 4) .&. 0xF0) .|. (x3 `shiftR` 2)@@ -62,7 +70,9 @@ | c == cSlash = 63 | otherwise = error ("fromChar: Can't happen: Bad input: " ++ show c) +{- splits :: Int -> [a] -> [[a]] splits _ [] = [] splits n xs = case splitAt n xs of (ys, zs) -> ys:splits n zs+-}
− Network/DomainAuth/Pubkey/Der.hs
@@ -1,179 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Network.DomainAuth.Pubkey.Der (- decode- , Class (..)- , TLV (..)- ) where--import Control.Applicative hiding (many)-import Control.Monad-import Data.Binary.Get-import Data.Bits-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as BL--------------------------------------------------------------------data TLV = Term- | Prim { cls :: Class- , tag :: Tag- , siz :: Size- , cnt :: ByteString- }- | Cons { cls :: Class- , tag :: Tag- , siz :: Size- , tlv :: [TLV]- }- deriving Show--data Class = Univ | Appl | Cont | Priv deriving (Show, Eq, Enum)-type Tag = Int-type Size = Int--------------------------------------------------------------------decode :: BL.ByteString -> TLV-decode = runGet der--------------------------------------------------------------------der :: Get TLV-der = do- first <- nonZero- let clss = getClass first- cons = getConstructor first- tg <- getTag first- len <- singleLength- if cons- then construct clss tg len- else primitive clss tg len--primitive :: Class -> Tag -> Int -> Get TLV-primitive clss tg len = Prim clss tg len <$> getByteString (fromIntegral len)--construct :: Class -> Tag -> Int -> Get TLV-construct = definite- {-- if len == indefiniteMark- then indefinite clss tg len- else definite clss tg len- -}--definite :: Class -> Tag -> Int -> Get TLV-definite clss tg len = do- start <- fromIntegral <$> bytesRead- let end = start + len- Cons clss tg len <$> withinLimit end []- where- withinLimit end ps = do- p <- der- end2 <- fromIntegral <$> bytesRead -- xxx- if end2 == end- then return (ps ++ [p])- else withinLimit end (ps ++ [p])--{--terminate :: Get TLV-terminate = Term <$ (zer0 >> zer0)--indefinite :: Class -> Tag -> Int -> Get TLV-indefinite clss tg len = Cons clss tg len <$> (many der <* terminate)--}--getClass :: Int -> Class-getClass first = toEnum (shift (first .&. classMask) (- classShift)) :: Class--getConstructor :: Int -> Bool-getConstructor first = first .&. consFlag == consFlag--getTag :: Int -> Get Int-getTag first = if tg == tagMask- then multiTag 0- else return tg- where- tg = first .&. tagMask--multiTag :: Int -> Get Int-multiTag len = do- i <- anyInt- if (i .&. tagEnd) == 0- then return (incTag len i)- else multiTag (incTag len i)--incTag :: Int -> Int -> Int-incTag len i = len * 128 + (i .&. tagLenMask)--singleLength :: Get Int-singleLength = do- second <- anyInt- let multi = getMulti second- len = getLen second- if multi- then definiteLength len- else return len--getMulti :: Int -> Bool-getMulti second = second .&. lenFlag == lenFlag--getLen :: Int -> Int-getLen second = second .&. lenMask--definiteLength :: Int -> Get Int-definiteLength bytes = if bytes == 0- then return indefiniteMark- else multiLength 0 bytes--multiLength :: Int -> Int -> Get Int-multiLength len bytes = do- i <- anyInt- if bytes == 1- then return (incLen len i)- else multiLength (incLen len i) (bytes - 1)--incLen :: Int -> Int -> Int-incLen len i = len * 256 + i--------------------------------------------------------------------anyInt :: Get Int-anyInt = fromIntegral <$> getWord8--nonZero :: Get Int-nonZero = do- n <- anyInt- when (n == 0) (error "nonZero")- return n--{--zer0 :: Get Int-zer0 = do- n <- anyInt- when (n /= 0) (error "zer0")- return n--}--------------------------------------------------------------------classMask :: Int-classMask = 0xc0-classShift :: Int-classShift = 6-consFlag :: Int-consFlag = 0x20--tagMask :: Int-tagMask = 0x1f-tagEnd :: Int-tagEnd = 0x80-tagLenMask :: Int-tagLenMask = 0x7f--lenFlag :: Int-lenFlag = 0x80-lenMask :: Int-lenMask = 0x7f--indefiniteMark :: Int-indefiniteMark = -1 -- xxx
Network/DomainAuth/Pubkey/RSAPub.hs view
@@ -1,24 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.DomainAuth.Pubkey.RSAPub where+module Network.DomainAuth.Pubkey.RSAPub (+ lookupPublicKey+ ) where -import Codec.Crypto.RSA-import Control.Applicative-import Crypto.Types.PubKey.RSA+import Crypto.PubKey.RSA (PublicKey)+import Data.ASN1.BinaryEncoding (DER)+import Data.ASN1.Encoding (decodeASN1')+import Data.ASN1.Types (fromASN1) import Data.ByteString (ByteString)-import qualified Data.ByteString as BS (foldl', dropWhile, length, tail) import qualified Data.ByteString.Char8 as BS ()-import qualified Data.ByteString.Lazy as BL+import Data.X509 (PubKey(PubKeyRSA)) import Network.DNS (Domain)-import qualified Network.DNS as DNS hiding (Domain)+import qualified Network.DNS as DNS import Network.DomainAuth.Mail import qualified Network.DomainAuth.Pubkey.Base64 as B-import qualified Network.DomainAuth.Pubkey.Der as D +-- $setup+-- >>> import Network.DNS++-- | Looking up an RSA public key+--+-- >>> rs <- DNS.makeResolvSeed DNS.defaultResolvConf+-- >>> withResolver rs $ \rslv -> lookupPublicKey rslv "dk200510._domainkey.yahoo.co.jp"+-- Just (PublicKey {public_size = 128, public_n = 124495277115430906234131617223399742059624761592171426860362133400468320289284068350453787798555522712914036293436636386707903510390018044090096883314714401752103035965668114514933570840775088208966674120428191313530595210688523478828022953238411688594634270571841869051696953556782155414877029327479844990933, public_e = 65537})+-- >>> withResolver rs $ \rslv -> lookupPublicKey rslv "20161025._domainkey.gmail.com"+-- Just (PublicKey {public_size = 256, public_n = 24002918530496096406691035681124918576525139397315303508411989678485471042094243709057313703002506577481962009015943359911855470236184740304869372300375695346466126498491672986773463137306714366250125164042667360646066116764211863426455899157774209331432246892273100824803003088472583507901403747123280231573655315087668569169140244507741538460717772392364103610973022227332742456151275783849571119048507254523999452581754451573432729267867937880516609319975372273089173378196646435625090021348583100824870283641053888848697729241628460935831026221013673635926904278136940569963717548356154570137751386534390787055991, public_e = 65537}) lookupPublicKey :: DNS.Resolver -> Domain -> IO (Maybe PublicKey)-lookupPublicKey resolver domain = decode <$> lookupPublicKey' resolver domain- where- decode = (>>= return . decodeRSAPublicyKey)+lookupPublicKey resolver domain = do+ mpub <- lookupPublicKey' resolver domain+ return $ case mpub of+ Nothing -> Nothing+ Just pub -> Just $ decodeRSAPublicyKey pub lookupPublicKey' :: DNS.Resolver -> Domain -> IO (Maybe ByteString) lookupPublicKey' resolver domain = do@@ -31,17 +44,8 @@ extractPub = lookup "p" . parseTaggedValue . head decodeRSAPublicyKey :: ByteString -> PublicKey-decodeRSAPublicyKey bs = PublicKey size n e+decodeRSAPublicyKey b64 = pub where- subjectPublicKeyInfo = D.decode . B.decode $ bs- [_, subjectPublicKey] = D.tlv subjectPublicKeyInfo- rsaPublicKey = D.decode . toLazy . bitString . D.cnt $ subjectPublicKey- [bn',be'] = D.tlv rsaPublicKey- bn = BS.dropWhile (== 0) $ D.cnt bn'- be = D.cnt be'- n = toNum bn- e = toNum be- size = fromIntegral . BS.length $ bn- toNum = BS.foldl' (\x y -> x*256 + fromIntegral y) 0- bitString = BS.tail- toLazy x = BL.fromChunks [x]+ der = B.decode b64+ Right ans1 = decodeASN1' (undefined :: DER) der+ Right (PubKeyRSA pub,[]) = fromASN1 ans1
Network/DomainAuth/SPF.hs view
@@ -1,7 +1,6 @@-{-|- A library for SPF(<http://www.ietf.org/rfc/rfc4408>)- and Sender-ID(<http://www.ietf.org/rfc/rfc4406>).--}+-- | A library for SPF(<http://www.ietf.org/rfc/rfc4408.txt>)+-- and Sender-ID(<http://www.ietf.org/rfc/rfc4406.txt>).+ module Network.DomainAuth.SPF ( runSPF , Limit(..)@@ -16,13 +15,45 @@ import Network.DomainAuth.Types import System.IO.Error -{-|- Process SPF authentication. 'IP' is an IP address of an SMTP peer.- If 'Domain' is specified from SMTP MAIL FROM, authentication is- based on SPF. If 'Domain' is specified from the From field of mail- header, authentication is based on SenderID. If condition reaches- 'Limit', 'SpfPermError' is returned.--}+-- $setup+-- >>> import Network.DNS++-- | Process SPF authentication. 'IP' is an IP address of an SMTP peer.+-- If 'Domain' is specified from SMTP MAIL FROM, authentication is+-- based on SPF. If 'Domain' is specified from the From field of mail+-- header, authentication is based on SenderID. If condition reaches+-- 'Limit', 'SpfPermError' is returned.+--+-- >>> rs <- makeResolvSeed defaultResolvConf+--+-- pass (IPv4 & IPv6):+--+-- >>> withResolver rs $ \rslv -> runSPF defaultLimit rslv "mew.org" "210.130.207.72"+-- pass+-- >>> withResolver rs $ \rslv -> runSPF defaultLimit rslv "iij.ad.jp" "2001:240:bb42:8010::1:126"+-- pass+--+-- hardfail:+--+-- >>> withResolver rs $ \rslv -> runSPF defaultLimit rslv "example.org" "192.0.2.1"+-- hardfail+--+-- redirect and include:+--+-- >>> withResolver rs $ \rslv -> runSPF defaultLimit rslv "gmail.com" "72.14.192.1"+-- pass+-- >>> withResolver rs $ \rslv -> runSPF defaultLimit rslv "gmail.com" "72.14.128.1"+-- softfail+--+-- limit:+--+-- >>> let limit1 = defaultLimit { ipv4_masklen = 24 }+-- >>> withResolver rs $ \rslv -> runSPF limit1 rslv "gmail.com" "72.14.192.1"+-- softfail+-- >>> let limit2 = defaultLimit { limit = 2 }+-- >>> withResolver rs $ \rslv -> runSPF limit2 rslv "nifty.com" "202.248.88.1"+-- permerror+ runSPF :: Limit -> Resolver -> Domain -> IP -> IO DAResult runSPF lim resolver dom ip = (resolveSPF resolver dom ip >>= evalSPF lim ip) `E.catch` spfErrorHandle
Network/DomainAuth/SPF/Eval.hs view
@@ -1,17 +1,19 @@-module Network.DomainAuth.SPF.Eval (evalSPF, Limit(..), defaultLimit) where+module Network.DomainAuth.SPF.Eval (+ evalSPF+ , Limit(..)+ , defaultLimit+ ) where -import Control.Applicative import Data.IORef import Data.IP import Data.Maybe import Network.DomainAuth.SPF.Types import Network.DomainAuth.Types -{-|- Limit for SPF authentication.--}+-- | Limit for SPF authentication. data Limit = Limit { -- | How many \"redirect\"/\"include\" should be followed.+ -- 'DAPermError' is returned if reached to this limit. limit :: Int -- | Ignoring IPv4 range whose mask length is shorter than this. , ipv4_masklen :: Int@@ -19,12 +21,13 @@ , ipv6_masklen :: Int -- | Whether or not \"+all\" is rejected. , reject_plus_all :: Bool- }+ } deriving (Eq, Show) -{-|- Default 'Limit'. 'limit' is 10. 'ipv4_masklen' is 16.- 'ipv6_masklen' is 48. 'reject_plus_all' is 'True'.--}+-- | Default value for 'Limit'.+--+-- >>> defaultLimit+-- Limit {limit = 10, ipv4_masklen = 16, ipv6_masklen = 48, reject_plus_all = True}+ defaultLimit :: Limit defaultLimit = Limit { limit = 10@@ -55,10 +58,8 @@ res -> return res -----------------------------------------------------------------{--Follow N of redirect/include. But the last one is not-evaluated.--}+-- Follow N of redirect/include. But the last one is not+-- evaluated. eval :: IORef Int -> Limit -> IP -> IO SpfSeq -> IO (Maybe DAResult) eval ref lim ip is = do
Network/DomainAuth/SPF/Parser.hs view
@@ -1,21 +1,32 @@-module Network.DomainAuth.SPF.Parser (parseSPF) where+{-# LANGUAGE OverloadedStrings #-} -import Data.ByteString (ByteString)-import Data.ByteString.Char8 as BS (pack)+module Network.DomainAuth.SPF.Parser (+ parseSPF+ ) where++import Control.Applicative+import Data.Attoparsec.ByteString (Parser)+import qualified Data.Attoparsec.ByteString as P+import Data.ByteString (ByteString, ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Word8 import Network.DNS (Domain) import Network.DomainAuth.SPF.Types import Prelude hiding (all)-import Text.Appar.ByteString+import Text.Read (readMaybe) ---------------------------------------------------------------- parseSPF :: ByteString -> Maybe [SPF]-parseSPF = parse spf+parseSPF inp = case P.parseOnly spf inp of+ Left _ -> Nothing+ Right res -> Just res ---------------------------------------------------------------- spaces1 :: Parser ()-spaces1 = skipSome space+spaces1 = P.skipWhile isSpace ---------------------------------------------------------------- @@ -26,12 +37,12 @@ modifier <|> directive spfPrefix :: Parser ()-spfPrefix = () <$ string "v=spf1"+spfPrefix = () <$ P.string "v=spf1" ---------------------------------------------------------------- modifier :: Parser SPF-modifier = SPF_Redirect <$> (string "redirect=" *> domain)+modifier = SPF_Redirect <$> (P.string "redirect=" *> domain) directive :: Parser SPF directive = qualifier >>= mechanism@@ -39,51 +50,63 @@ ---------------------------------------------------------------- qualifier :: Parser Qualifier-qualifier = option Q_Pass (choice quals)+qualifier = P.option Q_Pass (P.choice quals) where- func sym res = res <$ char sym- quals = zipWith func qualifierSymbol [minBound..maxBound]+ func sym res = res <$ P.word8 sym+ quals = zipWith func (BS.unpack qualifierSymbol) [minBound..maxBound] ---------------------------------------------------------------- type Directive = Qualifier -> Parser SPF mechanism :: Directive-mechanism q = choice $ map ($ q) [ip4,ip6,all,address,mx,include]+mechanism q = P.choice $ map ($ q) [ip4,ip6,all,address,mx,include] ip4 :: Directive-ip4 q = try $ SPF_IPv4Range q . read <$> (string "ip4:" *> some (noneOf " "))+ip4 q = P.try $ do+ mip <- readMaybe . BS8.unpack <$> ip4range+ case mip of+ Nothing -> fail "ip4"+ Just ip -> return $ SPF_IPv4Range q ip+ where+ ip4range = P.string "ip4:" *> P.takeWhile1 (P.notInClass " ") ip6 :: Directive-ip6 q = try $ SPF_IPv6Range q . read <$> (string "ip6:" *> some (noneOf " "))+ip6 q = P.try $ do+ mip <- readMaybe . BS8.unpack <$> ip6range+ case mip of+ Nothing -> fail "ip6"+ Just ip -> return $ SPF_IPv6Range q ip+ where+ ip6range = P.string "ip6:" *> P.takeWhile1 (P.notInClass " ") all :: Directive-all q = try $ SPF_All q <$ string "all"+all q = P.try $ SPF_All q <$ P.string "all" address :: Directive-address q = SPF_Address q <$> (string "a" *> optionalDomain)+address q = SPF_Address q <$> (P.string "a" *> optionalDomain) <*> optionalMask mx :: Directive-mx q = SPF_MX q <$> (string "mx" *> optionalDomain)+mx q = SPF_MX q <$> (P.string "mx" *> optionalDomain) <*> optionalMask include :: Directive-include q = SPF_Include q <$> (string "include:" *> domain)+include q = SPF_Include q <$> (P.string "include:" *> domain) ---------------------------------------------------------------- domain :: Parser Domain-domain = BS.pack <$> some (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_-.")+domain = P.takeWhile1 (P.inClass "a-zA-Z0-9_.-") optionalDomain :: Parser (Maybe Domain)-optionalDomain = option Nothing (Just <$> (char ':' *> domain))+optionalDomain = P.option Nothing (Just <$> (P.word8 _colon *> domain)) mask :: Parser Int-mask = read <$> (some . oneOf $ ['0'..'9'])+mask = read . BS8.unpack <$> P.takeWhile1 (P.inClass "0-9") optionalMask :: Parser (Int,Int)-optionalMask = try both <|> try v4 <|> try v6 <|> none+optionalMask = P.try both <|> P.try v4 <|> P.try v6 <|> none where both = (,) <$> ipv4Mask <*> ipv6Mask v4 = ipv4Mask >>= \l4 -> return (l4,128)@@ -91,7 +114,7 @@ none = return (32,128) ipv4Mask :: Parser Int-ipv4Mask = char '/' *> mask+ipv4Mask = P.word8 _slash *> mask ipv6Mask :: Parser Int-ipv6Mask = string "//" *> mask+ipv6Mask = P.string "//" *> mask
Network/DomainAuth/SPF/Resolver.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.DomainAuth.SPF.Resolver (resolveSPF) where+module Network.DomainAuth.SPF.Resolver (+ resolveSPF+ ) where -import Control.Applicative import Control.Monad import Data.IP import qualified Data.ByteString.Char8 as BS
Network/DomainAuth/SPF/Types.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+ module Network.DomainAuth.SPF.Types where import Data.IP import Network.DNS (Domain)+import Data.ByteString (ByteString) ---------------------------------------------------------------- @@ -10,7 +13,7 @@ deriving (Eq,Enum,Bounded,Show) -- Depends on Qualifier-qualifierSymbol :: String+qualifierSymbol :: ByteString qualifierSymbol = "+-~?" data SPF = SPF_IPv4Range Qualifier (AddrRange IPv4)
Network/DomainAuth/Types.hs view
@@ -1,16 +1,13 @@-{-|- Type for Message Authentication Status (<http://www.ietf.org/rfc/rfc5451.txt>).--}+-- | Type for Message Authentication Status (<http://www.ietf.org/rfc/rfc5451.txt>). module Network.DomainAuth.Types where ---------------------------------------------------------------- -{-|- The result of domain authentication. For more information, see- <http://www.ietf.org/rfc/rfc5451.txt>.--} -- See Qualifier in Network.DomainAuth.SPF.Types++-- | The result of domain authentication. For more information, see+-- <http://www.ietf.org/rfc/rfc5451.txt>. data DAResult = DAPass | DAHardFail | DASoftFail@@ -28,7 +25,7 @@ instance Show DAResult where show DAPass = "pass" show DAHardFail = "hardfail"- show DASoftFail = "fail"+ show DASoftFail = "softfail" show DANeutral = "neutral" show DAFail = "fail" show DATempError = "temperror"
Network/DomainAuth/Utils.hs view
@@ -2,15 +2,14 @@ module Network.DomainAuth.Utils where -import Blaze.ByteString.Builder import Data.ByteString (ByteString) import qualified Data.ByteString as BS+import Data.ByteString.Builder import qualified Data.ByteString.Char8 as BS (lines)-import Data.Monoid import Data.Word crlf :: Builder-crlf = fromByteString "\r\n"+crlf = byteString "\r\n" (+++) :: Monoid a => a -> a -> a (+++) = mappend@@ -27,10 +26,10 @@ appendCRLF x y = x +++ crlf +++ y appendCRLF' :: ByteString -> Builder -> Builder-appendCRLF' x = appendCRLF (fromByteString x)+appendCRLF' = appendCRLF . byteString appendCRLFWith :: (a -> ByteString) -> a -> Builder -> Builder-appendCRLFWith modify x y = fromByteString (modify x) +++ crlf +++ y+appendCRLFWith modify x y = byteString (modify x) +++ crlf +++ y concatCRLF :: [ByteString] -> Builder concatCRLF = foldr appendCRLF' empty@@ -40,9 +39,7 @@ ---------------------------------------------------------------- -{-|- Replaces multiple WPSs to a single SP.--}+-- | Replaces multiple WPSs to a single SP. reduceWSP :: Cook reduceWSP "" = "" reduceWSP bs@@ -95,6 +92,12 @@ | BS.last bs == 13 = BS.init bs -- 13 == '\r' | otherwise = bs +-- |+--+-- >>> blines "foo\r\n\r\nbar\r\nbaz"+-- ["foo","","bar","baz"]+-- >>> blines "foo\r\n"+-- ["foo"] blines :: ByteString -> [ByteString] blines = map chop . BS.lines
domain-auth.cabal view
@@ -1,5 +1,5 @@ Name: domain-auth-Version: 0.2.1+Version: 0.2.2 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -8,9 +8,11 @@ Description: Library for Sender Policy Framework, SenderID, DomainKeys and DKIM. Category: Network-Cabal-Version: >= 1.6+Cabal-Version: >= 1.10 Build-Type: Simple+ library+ Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Network.DomainAuth Network.DomainAuth.Mail@@ -32,7 +34,6 @@ Network.DomainAuth.DKIM.Types Network.DomainAuth.DKIM.Verify Network.DomainAuth.Pubkey.Base64- Network.DomainAuth.Pubkey.Der Network.DomainAuth.Pubkey.RSAPub Network.DomainAuth.PRD.Domain Network.DomainAuth.PRD.Lexer@@ -42,18 +43,29 @@ Network.DomainAuth.SPF.Resolver Network.DomainAuth.SPF.Types Build-Depends: base >= 4 && < 5- , RSA >= 2.0- , SHA- , appar- , binary- , blaze-builder+ , attoparsec+ , asn1-encoding+ , asn1-types , bytestring , containers- , crypto-pubkey-types+ , cryptonite , dns >= 1.0 , iproute+ , memory , network+ , x509+ , word8++Test-Suite doctest+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ HS-Source-Dirs: test+ Ghc-Options: -Wall+ Main-Is: doctests.hs+ Build-Depends: base >= 4 && < 5+ , doctest >= 0.9.3+ , pretty-simple+ Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/domain-auth.git-
+ test/doctests.hs view
@@ -0,0 +1,10 @@+module Main where++import Test.DocTest++main :: IO ()+main = do+ doctest [+ "-XOverloadedStrings"+ , "Network/DomainAuth"+ ]