diff --git a/Network/DomainAuth.hs b/Network/DomainAuth.hs --- a/Network/DomainAuth.hs +++ b/Network/DomainAuth.hs @@ -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 diff --git a/Network/DomainAuth/DK.hs b/Network/DomainAuth/DK.hs --- a/Network/DomainAuth/DK.hs +++ b/Network/DomainAuth/DK.hs @@ -1,9 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -{-| - A library for DomainKeys (). - Currently, only receiver side is implemented. --} +-- | A library for DomainKeys (). +-- 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 diff --git a/Network/DomainAuth/DK/Parser.hs b/Network/DomainAuth/DK/Parser.hs --- a/Network/DomainAuth/DK/Parser.hs +++ b/Network/DomainAuth/DK/Parser.hs @@ -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 diff --git a/Network/DomainAuth/DK/Types.hs b/Network/DomainAuth/DK/Types.hs --- a/Network/DomainAuth/DK/Types.hs +++ b/Network/DomainAuth/DK/Types.hs @@ -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 diff --git a/Network/DomainAuth/DK/Verify.hs b/Network/DomainAuth/DK/Verify.hs --- a/Network/DomainAuth/DK/Verify.hs +++ b/Network/DomainAuth/DK/Verify.hs @@ -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 diff --git a/Network/DomainAuth/DKIM.hs b/Network/DomainAuth/DKIM.hs --- a/Network/DomainAuth/DKIM.hs +++ b/Network/DomainAuth/DKIM.hs @@ -1,9 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -{-| - A library for DKIM (). - Currently, only receiver side is implemented. --} +-- | A library for DKIM (). +-- 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 " +-- ,"Date: Wed, 20 Sep 2017 17:19:02 +0900" +-- ,"Message-ID: " +-- ,"Subject: test for DKIM" +-- ,"To: Kazu Yamamoto " +-- ,"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 diff --git a/Network/DomainAuth/DKIM/Btag.hs b/Network/DomainAuth/DKIM/Btag.hs --- a/Network/DomainAuth/DKIM/Btag.hs +++ b/Network/DomainAuth/DKIM/Btag.hs @@ -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) + diff --git a/Network/DomainAuth/DKIM/Parser.hs b/Network/DomainAuth/DKIM/Parser.hs --- a/Network/DomainAuth/DKIM/Parser.hs +++ b/Network/DomainAuth/DKIM/Parser.hs @@ -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 diff --git a/Network/DomainAuth/DKIM/Types.hs b/Network/DomainAuth/DKIM/Types.hs --- a/Network/DomainAuth/DKIM/Types.hs +++ b/Network/DomainAuth/DKIM/Types.hs @@ -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 diff --git a/Network/DomainAuth/DKIM/Verify.hs b/Network/DomainAuth/DKIM/Verify.hs --- a/Network/DomainAuth/DKIM/Verify.hs +++ b/Network/DomainAuth/DKIM/Verify.hs @@ -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) + diff --git a/Network/DomainAuth/Mail.hs b/Network/DomainAuth/Mail.hs --- a/Network/DomainAuth/Mail.hs +++ b/Network/DomainAuth/Mail.hs @@ -1,6 +1,4 @@ -{-| - A library to parse e-mail messages both from a file and Milter(). --} +-- | A library to parse e-mail messages both from a file and Milter(). module Network.DomainAuth.Mail ( -- * Documentation diff --git a/Network/DomainAuth/Mail/Mail.hs b/Network/DomainAuth/Mail/Mail.hs --- a/Network/DomainAuth/Mail/Mail.hs +++ b/Network/DomainAuth/Mail/Mail.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/DomainAuth/Mail/Parser.hs b/Network/DomainAuth/Mail/Parser.hs --- a/Network/DomainAuth/Mail/Parser.hs +++ b/Network/DomainAuth/Mail/Parser.hs @@ -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 diff --git a/Network/DomainAuth/Mail/Types.hs b/Network/DomainAuth/Mail/Types.hs --- a/Network/DomainAuth/Mail/Types.hs +++ b/Network/DomainAuth/Mail/Types.hs @@ -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 diff --git a/Network/DomainAuth/Mail/XMail.hs b/Network/DomainAuth/Mail/XMail.hs --- a/Network/DomainAuth/Mail/XMail.hs +++ b/Network/DomainAuth/Mail/XMail.hs @@ -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) diff --git a/Network/DomainAuth/PRD.hs b/Network/DomainAuth/PRD.hs --- a/Network/DomainAuth/PRD.hs +++ b/Network/DomainAuth/PRD.hs @@ -1,6 +1,4 @@ -{-| - Utilities to decide Purported Responsible Domain (). --} +-- | Utilities to decide Purported Responsible Domain (). module Network.DomainAuth.PRD ( module Network.DomainAuth.PRD.PRD diff --git a/Network/DomainAuth/PRD/Domain.hs b/Network/DomainAuth/PRD/Domain.hs --- a/Network/DomainAuth/PRD/Domain.hs +++ b/Network/DomainAuth/PRD/Domain.hs @@ -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 " +-- Just "example.com" +-- >>> extractDomain "\"Alice . Brown\" (Nickname here)" +-- Just "example.com" +-- >>> extractDomain "alice.brown@example.com" +-- Just "example.com" +-- >>> extractDomain "Alice Brown " +-- 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 diff --git a/Network/DomainAuth/PRD/Lexer.hs b/Network/DomainAuth/PRD/Lexer.hs --- a/Network/DomainAuth/PRD/Lexer.hs +++ b/Network/DomainAuth/PRD/Lexer.hs @@ -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 " +-- Right ["From",":","Kazu","Yamamoto","<","kazu","@","example",".","net",">"] +-- >>> P.parseOnly structured "To:A Group(Some people)\n :Chris Jones ,\n joe@example.org,\n John (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) \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' diff --git a/Network/DomainAuth/PRD/PRD.hs b/Network/DomainAuth/PRD/PRD.hs --- a/Network/DomainAuth/PRD/PRD.hs +++ b/Network/DomainAuth/PRD/PRD.hs @@ -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 diff --git a/Network/DomainAuth/Pubkey/Base64.hs b/Network/DomainAuth/Pubkey/Base64.hs --- a/Network/DomainAuth/Pubkey/Base64.hs +++ b/Network/DomainAuth/Pubkey/Base64.hs @@ -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 +-} diff --git a/Network/DomainAuth/Pubkey/Der.hs b/Network/DomainAuth/Pubkey/Der.hs deleted file mode 100644 --- a/Network/DomainAuth/Pubkey/Der.hs +++ /dev/null @@ -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 diff --git a/Network/DomainAuth/Pubkey/RSAPub.hs b/Network/DomainAuth/Pubkey/RSAPub.hs --- a/Network/DomainAuth/Pubkey/RSAPub.hs +++ b/Network/DomainAuth/Pubkey/RSAPub.hs @@ -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 diff --git a/Network/DomainAuth/SPF.hs b/Network/DomainAuth/SPF.hs --- a/Network/DomainAuth/SPF.hs +++ b/Network/DomainAuth/SPF.hs @@ -1,7 +1,6 @@ -{-| - A library for SPF() - and Sender-ID(). --} +-- | A library for SPF() +-- and Sender-ID(). + 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 diff --git a/Network/DomainAuth/SPF/Eval.hs b/Network/DomainAuth/SPF/Eval.hs --- a/Network/DomainAuth/SPF/Eval.hs +++ b/Network/DomainAuth/SPF/Eval.hs @@ -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 diff --git a/Network/DomainAuth/SPF/Parser.hs b/Network/DomainAuth/SPF/Parser.hs --- a/Network/DomainAuth/SPF/Parser.hs +++ b/Network/DomainAuth/SPF/Parser.hs @@ -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 diff --git a/Network/DomainAuth/SPF/Resolver.hs b/Network/DomainAuth/SPF/Resolver.hs --- a/Network/DomainAuth/SPF/Resolver.hs +++ b/Network/DomainAuth/SPF/Resolver.hs @@ -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 diff --git a/Network/DomainAuth/SPF/Types.hs b/Network/DomainAuth/SPF/Types.hs --- a/Network/DomainAuth/SPF/Types.hs +++ b/Network/DomainAuth/SPF/Types.hs @@ -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) diff --git a/Network/DomainAuth/Types.hs b/Network/DomainAuth/Types.hs --- a/Network/DomainAuth/Types.hs +++ b/Network/DomainAuth/Types.hs @@ -1,16 +1,13 @@ -{-| - Type for Message Authentication Status (). --} +-- | Type for Message Authentication Status (). module Network.DomainAuth.Types where ---------------------------------------------------------------- -{-| - The result of domain authentication. For more information, see - . --} -- See Qualifier in Network.DomainAuth.SPF.Types + +-- | The result of domain authentication. For more information, see +-- . 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" diff --git a/Network/DomainAuth/Utils.hs b/Network/DomainAuth/Utils.hs --- a/Network/DomainAuth/Utils.hs +++ b/Network/DomainAuth/Utils.hs @@ -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 diff --git a/domain-auth.cabal b/domain-auth.cabal --- a/domain-auth.cabal +++ b/domain-auth.cabal @@ -1,5 +1,5 @@ Name: domain-auth -Version: 0.2.1 +Version: 0.2.2 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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 - diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = do + doctest [ + "-XOverloadedStrings" + , "Network/DomainAuth" + ]