diff --git a/Network/DomainAuth.hs b/Network/DomainAuth.hs --- a/Network/DomainAuth.hs +++ b/Network/DomainAuth.hs @@ -1,17 +1,16 @@ -- | Library for Sender Policy Framework, SenderID, DomainKeys and DKIM. - module Network.DomainAuth ( - module Network.DomainAuth.Mail - , module Network.DomainAuth.DK - , module Network.DomainAuth.DKIM - , module Network.DomainAuth.PRD - , module Network.DomainAuth.SPF - , module Network.DomainAuth.Types - ) where + module Network.DomainAuth.Mail, + module Network.DomainAuth.DK, + module Network.DomainAuth.DKIM, + module Network.DomainAuth.PRD, + module Network.DomainAuth.SPF, + module Network.DomainAuth.Types, +) where -import Network.DomainAuth.Mail import Network.DomainAuth.DK import Network.DomainAuth.DKIM +import Network.DomainAuth.Mail import Network.DomainAuth.PRD import Network.DomainAuth.SPF import Network.DomainAuth.Types diff --git a/Network/DomainAuth/DK.hs b/Network/DomainAuth/DK.hs --- a/Network/DomainAuth/DK.hs +++ b/Network/DomainAuth/DK.hs @@ -2,18 +2,24 @@ -- | A library for DomainKeys (). -- Currently, only receiver side is implemented. - module Network.DomainAuth.DK ( - -- * Documentation - -- ** Authentication with DK - runDK, runDK' - -- ** Parsing DomainKey-Signature: - , parseDK - , DK, dkDomain, dkSelector - -- ** Field key for DomainKey-Signature: - , dkFieldKey - ) where + -- * Documentation + -- ** Authentication with DK + runDK, + runDK', + + -- ** Parsing DomainKey-Signature: + parseDK, + DK, + dkDomain, + dkSelector, + + -- ** Field key for DomainKey-Signature: + dkFieldKey, +) where + +import qualified Data.ByteString as BS (append) import Network.DNS as DNS (Resolver) import Network.DomainAuth.DK.Parser import Network.DomainAuth.DK.Types @@ -21,15 +27,14 @@ import Network.DomainAuth.Mail import Network.DomainAuth.Pubkey.RSAPub import Network.DomainAuth.Types -import qualified Data.ByteString as BS (append) -- | Verifying 'Mail' with DomainKeys. runDK :: Resolver -> Mail -> IO DAResult runDK resolver mail = dk1 where - dk1 = maybe (return DANone) dk2 $ lookupField dkFieldKey (mailHeader mail) + dk1 = maybe (return DANone) dk2 $ lookupField dkFieldKey (mailHeader mail) dk2 dkv = maybe (return DAPermError) dk3 $ parseDK (fieldValueUnfolded dkv) - dk3 = runDK' resolver mail + dk3 = runDK' resolver mail -- | Verifying 'Mail' with DomainKeys. The value of DomainKey-Signature: -- should be parsed beforehand. 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,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.DK.Parser ( - parseDK - ) where + parseDK, +) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS @@ -16,7 +16,6 @@ -- >>> import Text.Pretty.Simple -- >>> import Data.ByteString.Char8 as BS8 - -- | Parsing DomainKey-Signature:. -- -- >>> :{ @@ -28,20 +27,20 @@ -- ] -- in pPrintNoColor $ parseDK dk -- :} --- Just --- ( 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 - (ts,vs) = unzip $ parseTaggedValue val + (ts, vs) = unzip $ parseTaggedValue val fs = map tagToSetter ts tagToSetter tag = fromMaybe (\_ mdk -> mdk) $ lookup (BS.head tag) dkTagDB pfs = zipWith ($) fs vs @@ -50,66 +49,69 @@ alg <- mdkAlgorithm mdk sig <- mdkSignature mdk cal <- mdkCanonAlgo mdk - dom <- mdkDomain mdk - sel <- mdkSelector mdk - return DK { - dkAlgorithm = alg - , dkSignature = sig - , dkCanonAlgo = cal - , dkDomain0 = dom - , dkFields = mdkFields mdk - , dkSelector0 = sel - } + dom <- mdkDomain mdk + sel <- mdkSelector mdk + return + DK + { dkAlgorithm = alg + , dkSignature = sig + , dkCanonAlgo = cal + , dkDomain0 = dom + , dkFields = mdkFields mdk + , dkSelector0 = sel + } -data MDK = MDK { - mdkAlgorithm :: Maybe DkAlgorithm - , mdkSignature :: Maybe ByteString - , mdkCanonAlgo :: Maybe DkCanonAlgo - , mdkDomain :: Maybe ByteString - , mdkFields :: Maybe DkFields - , mdkSelector :: Maybe ByteString - } deriving (Eq,Show) +data MDK = MDK + { mdkAlgorithm :: Maybe DkAlgorithm + , mdkSignature :: Maybe ByteString + , mdkCanonAlgo :: Maybe DkCanonAlgo + , mdkDomain :: Maybe ByteString + , mdkFields :: Maybe DkFields + , mdkSelector :: Maybe ByteString + } + deriving (Eq, Show) initialMDK :: MDK -initialMDK = MDK { - mdkAlgorithm = Just DK_RSA_SHA1 - , mdkSignature = Nothing - , mdkCanonAlgo = Nothing - , mdkDomain = Nothing - , mdkFields = Nothing - , mdkSelector = Nothing - } +initialMDK = + MDK + { mdkAlgorithm = Just DK_RSA_SHA1 + , mdkSignature = Nothing + , mdkCanonAlgo = Nothing + , mdkDomain = Nothing + , mdkFields = Nothing + , mdkSelector = Nothing + } type DKSetter = ByteString -> MDK -> MDK -dkTagDB :: [(Char,DKSetter)] -dkTagDB = [ - ('a',setDkAlgorithm) - , ('b',setDkSignature) - , ('c',setDkCanonAlgo) - , ('d',setDkDomain) - , ('h',setDkFields) --- , ('q',setDkQuery) - , ('s',setDkSelector) - ] +dkTagDB :: [(Char, DKSetter)] +dkTagDB = + [ ('a', setDkAlgorithm) + , ('b', setDkSignature) + , ('c', setDkCanonAlgo) + , ('d', setDkDomain) + , ('h', setDkFields) + , -- , ('q',setDkQuery) + ('s', setDkSelector) + ] setDkAlgorithm :: DKSetter -setDkAlgorithm "rsa-sha1" dk = dk { mdkAlgorithm = Just DK_RSA_SHA1 } -setDkAlgorithm _ _ = error "setDkAlgorithm" +setDkAlgorithm "rsa-sha1" dk = dk{mdkAlgorithm = Just DK_RSA_SHA1} +setDkAlgorithm _ _ = error "setDkAlgorithm" setDkSignature :: DKSetter -setDkSignature sig dk = dk { mdkSignature = Just sig } +setDkSignature sig dk = dk{mdkSignature = Just sig} setDkCanonAlgo :: DKSetter -setDkCanonAlgo "simple" dk = dk { mdkCanonAlgo = Just DK_SIMPLE } -setDkCanonAlgo "nofws" dk = dk { mdkCanonAlgo = Just DK_NOFWS } -setDkCanonAlgo _ _ = error "setDkCanonAlgo" +setDkCanonAlgo "simple" dk = dk{mdkCanonAlgo = Just DK_SIMPLE} +setDkCanonAlgo "nofws" dk = dk{mdkCanonAlgo = Just DK_NOFWS} +setDkCanonAlgo _ _ = error "setDkCanonAlgo" setDkDomain :: DKSetter -setDkDomain dom dk = dk { mdkDomain = Just dom } +setDkDomain dom dk = dk{mdkDomain = Just dom} setDkFields :: DKSetter -setDkFields keys dk = dk { mdkFields = Just mx } +setDkFields keys dk = dk{mdkFields = Just mx} where flds = BS.split ':' keys mx = foldl' func M.empty flds @@ -122,4 +124,4 @@ -} setDkSelector :: DKSetter -setDkSelector sel dk = dk { mdkSelector = Just sel } +setDkSelector sel dk = dk{mdkSelector = Just sel} 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 @@ -15,21 +15,23 @@ ---------------------------------------------------------------- -data DkAlgorithm = DK_RSA_SHA1 deriving (Eq,Show) -data DkCanonAlgo = DK_SIMPLE | DK_NOFWS deriving (Eq,Show) ---data DkQuery = DK_DNS deriving (Eq,Show) +data DkAlgorithm = DK_RSA_SHA1 deriving (Eq, Show) +data DkCanonAlgo = DK_SIMPLE | DK_NOFWS deriving (Eq, Show) + +-- data DkQuery = DK_DNS deriving (Eq,Show) type DkFields = M.Map ByteString Bool -- Key Bool -- | Abstract type for DomainKey-Signature: -data DK = DK { - dkAlgorithm :: DkAlgorithm - , dkSignature :: ByteString - , dkCanonAlgo :: DkCanonAlgo - , dkDomain0 :: ByteString - , dkFields :: Maybe DkFields --- , dkQuery :: Maybe DkQuery -- gmail does not provide, sigh - , dkSelector0 :: ByteString - } deriving (Eq,Show) +data DK = DK + { dkAlgorithm :: DkAlgorithm + , dkSignature :: ByteString + , dkCanonAlgo :: DkCanonAlgo + , dkDomain0 :: ByteString + , dkFields :: Maybe DkFields + , -- , dkQuery :: Maybe DkQuery -- gmail does not provide, sigh + dkSelector0 :: ByteString + } + deriving (Eq, Show) -- | Getting of the value of the \"d\" tag in DomainKey-Signature:. dkDomain :: DK -> Domain 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 @@ -1,8 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.DK.Verify ( - verifyDK, prepareDK - ) where + verifyDK, + prepareDK, +) where import Crypto.Hash import Crypto.PubKey.RSA @@ -23,11 +24,13 @@ prepareDK dk mail = cmail where header' = canonDkHeader dk (mailHeader mail) - body' = canonDkBody (dkCanonAlgo dk) (mailBody mail) - cmail = if isEmpty (mailBody mail) then - header' - else - header' `appendCRLF` body' + body' = canonDkBody (dkCanonAlgo dk) (mailBody mail) + cmail = + if isEmpty (mailBody mail) + then + header' + else + header' `appendCRLF` body' ---------------------------------------------------------------- @@ -40,7 +43,7 @@ canonDkField :: DkCanonAlgo -> Field -> ByteString canonDkField DK_SIMPLE fld = fieldKey fld +++ ": " +++ fieldValueFolded fld -canonDkField DK_NOFWS fld = fieldKey fld +++ ":" +++ removeFWS (fieldValueUnfolded fld) +canonDkField DK_NOFWS fld = fieldKey fld +++ ":" +++ removeFWS (fieldValueUnfolded fld) prepareDkHeader :: Maybe DkFields -> Header -> Header prepareDkHeader Nothing hdr = fieldsAfter dkFieldKey hdr @@ -52,7 +55,7 @@ canonDkBody :: DkCanonAlgo -> Body -> Builder canonDkBody DK_SIMPLE = fromBody . removeTrailingEmptyLine -canonDkBody DK_NOFWS = fromBodyWith removeFWS . removeTrailingEmptyLine +canonDkBody DK_NOFWS = fromBodyWith removeFWS . removeTrailingEmptyLine ---------------------------------------------------------------- diff --git a/Network/DomainAuth/DKIM.hs b/Network/DomainAuth/DKIM.hs --- a/Network/DomainAuth/DKIM.hs +++ b/Network/DomainAuth/DKIM.hs @@ -2,18 +2,23 @@ -- | A library for DKIM (). -- Currently, only receiver side is implemented. - module Network.DomainAuth.DKIM ( - -- * Documentation - -- ** Authentication with DKIM - runDKIM, runDKIM' - -- ** Parsing DKIM-Signature: - , parseDKIM - , DKIM, dkimDomain, dkimSelector - -- ** Field key for DKIM-Signature: - , dkimFieldKey - ) where + -- * Documentation + -- ** Authentication with DKIM + runDKIM, + runDKIM', + + -- ** Parsing DKIM-Signature: + parseDKIM, + DKIM, + dkimDomain, + dkimSelector, + + -- ** Field key for DKIM-Signature: + dkimFieldKey, +) where + import qualified Data.ByteString as BS import Network.DNS as DNS (Resolver) import Network.DomainAuth.DKIM.Parser @@ -24,6 +29,7 @@ import Network.DomainAuth.Types -- $setup +-- >>> :set -XOverloadedStrings -- >>> import Network.DNS -- >>> import Data.ByteString.Char8 as BS8 @@ -32,20 +38,20 @@ -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> :{ -- let lst = ["DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;" --- ," d=gmail.com; s=20221208; t=1692239637; x=1692844437;" +-- ," d=gmail.com; s=20230601; t=1712195651; x=1712800451; darn=iij.ad.jp;" -- ," h=to:subject:message-id:date:from:mime-version:from:to:cc:subject" -- ," :date:message-id:reply-to;" -- ," bh=g3zLYH4xKxcPrHOD18z9YfpQcnk/GaJedfustWU5uGs=;" --- ," b=ceWXhAaIcvcQCkqTELkw1Bk7v+0pwT8VjmmE49M2nNhXQqA/DXR/aRljXAxGFIm2eU" --- ," qhHFwQBh9JHbDWXUpltPWisIEDVI+rgOZFRQ7s9OrhJ4Vfmi+Y9Tu3LqmrzvacjdRM2Z" --- ," 9RNfk4Wv1xk4jGas+JU0T296Z2BYOR5qxB5X/rmMhPNanKeZDmrhUOk+DWrbC+uJ0wcn" --- ," P/jb76YBwTKBN1ySRrB0SdbruOIm0kYHYZoNMW/QWsR8f9PGthbAedCZrdjyixb7uXkz" --- ," YmmGi6+XlLL3czZrj+RRrQlFn/xANIrE7sc0YYkhnehvBM6zZtgqesPflVbTlVEMMQg2" --- ," N22A==" +-- ," b=YXB6AlsJFBYK+32OfzPKYoRHVHL/L01KgEV9YIxIiyF2LiLMgGlIdQdTnFnKKgaOKN" +-- ," EX/233mgKR3Vn4I9yTdlgli6d5Eni4XU064hJ4b4Xm+/AuiW67LiuZlDkQIHSOXYg7y9" +-- ," PiBPz5+5FQL2w/svoty7mYkUh59xWmbUCZXXUYoXA+MSnyNvV187TYlx/L6CWeb3Tc4E" +-- ," EX/DEROnzKST/O0LVrnYzqJWv/H0NTytA+JxE1dT/1/ObHkHWqb/ip4DxPlE6KB2ycOu" +-- ," vhtPyambWkKEsEtR5UTMcMweVc2qsdFciqupFAYIcJIopFyL4rxai8E32q6V1hZmpdzr" +-- ," uW/Q==" -- ,"To: kazu@iij.ad.jp" -- ,"Subject: test" --- ,"Message-ID: " --- ,"Date: Thu, 17 Aug 2023 11:33:46 +0900" +-- ,"Message-ID: " +-- ,"Date: Thu, 4 Apr 2024 10:53:59 +0900" -- ,"From: Kazu Yamamoto " -- ,"MIME-Version: 1.0" -- ,"Content-Type: text/plain; charset=\"UTF-8\"" @@ -59,9 +65,10 @@ runDKIM :: Resolver -> Mail -> IO DAResult runDKIM resolver mail = dkim1 where - dkim1 = maybe (return DANone) dkim2 $ lookupField dkimFieldKey (mailHeader mail) + dkim1 = + maybe (return DANone) dkim2 $ lookupField dkimFieldKey (mailHeader mail) dkim2 dkimv = maybe (return DAPermError) dkim3 $ parseDKIM (fieldValueUnfolded dkimv) - dkim3 = runDKIM' resolver mail + dkim3 = runDKIM' resolver mail -- | Verifying 'Mail' with DKIM. The value of DKIM-Signature: -- should be parsed beforehand. 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,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.DKIM.Btag ( - removeBtagValue - ) where + removeBtagValue, +) where import Control.Applicative import Control.Monad @@ -20,8 +20,8 @@ -- "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 inp = case P.parseOnly remBtagValue inp of - Left _ -> "" - Right bs -> toStrict $ B.toLazyByteString bs + Left _ -> "" + Right bs -> toStrict $ B.toLazyByteString bs remBtagValue :: Parser Builder remBtagValue = (<>) <$> inFix btag <*> anyString @@ -41,4 +41,3 @@ 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,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.DKIM.Parser ( - parseDKIM - ) where + parseDKIM, +) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS @@ -29,8 +29,8 @@ -- ] -- in pPrintNoColor $ parseDKIM dkim -- :} --- Just --- ( DKIM +-- Just +-- ( DKIM -- { dkimVersion = "1" -- , dkimSigAlgo = RSA_SHA256 -- , dkimSignature = "AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHutKVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV4bmp/YzhwvcubU4=" @@ -38,17 +38,17 @@ -- , dkimHeaderCanon = DKIM_RELAXED -- , dkimBodyCanon = DKIM_SIMPLE -- , dkimDomain0 = "example.com" --- , dkimFields = +-- , dkimFields = -- [ "received" -- , "from" -- , "to" -- , "subject" -- , "date" -- , "message-id" --- ] +-- ] -- , dkimLength = Nothing -- , dkimSelector0 = "brisbane" --- } +-- } -- ) -- -- >>> :{ @@ -64,8 +64,8 @@ -- ] -- in pPrintNoColor $ parseDKIM dkim -- :} --- Just --- ( DKIM +-- Just +-- ( DKIM -- { dkimVersion = "1" -- , dkimSigAlgo = RSA_SHA256 -- , dkimSignature = "AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHutKVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV4bmp/YzhwvcubU4=" @@ -73,138 +73,146 @@ -- , dkimHeaderCanon = DKIM_SIMPLE -- , dkimBodyCanon = DKIM_SIMPLE -- , dkimDomain0 = "example.com" --- , dkimFields = +-- , dkimFields = -- [ "received" -- , "from" -- , "to" -- , "subject" -- , "date" -- , "message-id" --- ] +-- ] -- , dkimLength = Nothing -- , dkimSelector0 = "brisbane" --- } +-- } -- ) parseDKIM :: RawFieldValue -> Maybe DKIM parseDKIM val = toDKIM domkey where - (ts,vs) = unzip $ parseTaggedValue val + (ts, vs) = unzip $ parseTaggedValue val fs = map tagToSetter ts tagToSetter tag = fromMaybe (\_ mdkim -> mdkim) $ lookup (BS.unpack tag) dkimTagDB pfs = zipWith ($) fs vs domkey = foldr ($) initialMDKIM pfs toDKIM mdkim = do - ver <- mdkimVersion mdkim - alg <- mdkimSigAlgo mdkim - sig <- mdkimSignature mdkim - bhs <- mdkimBodyHash mdkim + ver <- mdkimVersion mdkim + alg <- mdkimSigAlgo mdkim + sig <- mdkimSignature mdkim + bhs <- mdkimBodyHash mdkim hca <- mdkimHeaderCanon mdkim - bca <- mdkimBodyCanon mdkim - dom <- mdkimDomain mdkim - fld <- mdkimFields mdkim - sel <- mdkimSelector mdkim - return DKIM { - dkimVersion = ver - , dkimSigAlgo = alg - , dkimSignature = sig - , dkimBodyHash = bhs - , dkimHeaderCanon = hca - , dkimBodyCanon = bca - , dkimDomain0 = dom - , dkimFields = fld - , dkimLength = mdkimLength mdkim - , dkimSelector0 = sel - } + bca <- mdkimBodyCanon mdkim + dom <- mdkimDomain mdkim + fld <- mdkimFields mdkim + sel <- mdkimSelector mdkim + return + DKIM + { dkimVersion = ver + , dkimSigAlgo = alg + , dkimSignature = sig + , dkimBodyHash = bhs + , dkimHeaderCanon = hca + , dkimBodyCanon = bca + , dkimDomain0 = dom + , dkimFields = fld + , dkimLength = mdkimLength mdkim + , dkimSelector0 = sel + } -data MDKIM = MDKIM { - mdkimVersion :: Maybe ByteString - , mdkimSigAlgo :: Maybe DkimSigAlgo - , mdkimSignature :: Maybe ByteString - , mdkimBodyHash :: Maybe ByteString - , mdkimHeaderCanon :: Maybe DkimCanonAlgo - , mdkimBodyCanon :: Maybe DkimCanonAlgo - , mdkimDomain :: Maybe ByteString - , mdkimFields :: Maybe [CanonFieldKey] - , mdkimLength :: Maybe Int - , mdkimSelector :: Maybe ByteString - } deriving (Eq,Show) +data MDKIM = MDKIM + { mdkimVersion :: Maybe ByteString + , mdkimSigAlgo :: Maybe DkimSigAlgo + , mdkimSignature :: Maybe ByteString + , mdkimBodyHash :: Maybe ByteString + , mdkimHeaderCanon :: Maybe DkimCanonAlgo + , mdkimBodyCanon :: Maybe DkimCanonAlgo + , mdkimDomain :: Maybe ByteString + , mdkimFields :: Maybe [CanonFieldKey] + , mdkimLength :: Maybe Int + , mdkimSelector :: Maybe ByteString + } + deriving (Eq, Show) initialMDKIM :: MDKIM -initialMDKIM = MDKIM { - mdkimVersion = Nothing - , mdkimSigAlgo = Nothing - , mdkimSignature = Nothing - , mdkimBodyHash = Nothing - , mdkimHeaderCanon = Just DKIM_SIMPLE - , mdkimBodyCanon = Just DKIM_SIMPLE - , mdkimDomain = Nothing - , mdkimFields = Nothing - , mdkimLength = Nothing - , mdkimSelector = Nothing - } +initialMDKIM = + MDKIM + { mdkimVersion = Nothing + , mdkimSigAlgo = Nothing + , mdkimSignature = Nothing + , mdkimBodyHash = Nothing + , mdkimHeaderCanon = Just DKIM_SIMPLE + , mdkimBodyCanon = Just DKIM_SIMPLE + , mdkimDomain = Nothing + , mdkimFields = Nothing + , mdkimLength = Nothing + , mdkimSelector = Nothing + } type DKIMSetter = ByteString -> MDKIM -> MDKIM -dkimTagDB :: [(String,DKIMSetter)] -dkimTagDB = [ - ("v",setDkimVersion) - , ("a",setDkimSigAlgo) - , ("b",setDkimSignature) - , ("bh",setDkimBodyHash) - , ("c",setDkimCanonAlgo) - , ("d",setDkimDomain) - , ("h",setDkimFields) - , ("l",setDkimLength) - , ("s",setDkimSelector) - ] +dkimTagDB :: [(String, DKIMSetter)] +dkimTagDB = + [ ("v", setDkimVersion) + , ("a", setDkimSigAlgo) + , ("b", setDkimSignature) + , ("bh", setDkimBodyHash) + , ("c", setDkimCanonAlgo) + , ("d", setDkimDomain) + , ("h", setDkimFields) + , ("l", setDkimLength) + , ("s", setDkimSelector) + ] setDkimVersion :: DKIMSetter -setDkimVersion ver dkim = dkim { mdkimVersion = Just ver } +setDkimVersion ver dkim = dkim{mdkimVersion = Just ver} setDkimSigAlgo :: DKIMSetter -setDkimSigAlgo "rsa-sha1" dkim = dkim { mdkimSigAlgo = Just RSA_SHA1 } -setDkimSigAlgo "rsa-sha256" dkim = dkim { mdkimSigAlgo = Just RSA_SHA256 } +setDkimSigAlgo "rsa-sha1" dkim = dkim{mdkimSigAlgo = Just RSA_SHA1} +setDkimSigAlgo "rsa-sha256" dkim = dkim{mdkimSigAlgo = Just RSA_SHA256} setDkimSigAlgo _ _ = error "setDkimSigAlgo" setDkimSignature :: DKIMSetter -setDkimSignature sig dkim = dkim { mdkimSignature = Just sig } +setDkimSignature sig dkim = dkim{mdkimSignature = Just sig} setDkimBodyHash :: DKIMSetter -setDkimBodyHash bh dkim = dkim { mdkimBodyHash = Just bh } +setDkimBodyHash bh dkim = dkim{mdkimBodyHash = Just bh} setDkimCanonAlgo :: DKIMSetter -setDkimCanonAlgo "relaxed" dkim = dkim { - mdkimHeaderCanon = Just DKIM_RELAXED - , mdkimBodyCanon = Just DKIM_SIMPLE - } -setDkimCanonAlgo "relaxed/relaxed" dkim = dkim { - mdkimHeaderCanon = Just DKIM_RELAXED - , mdkimBodyCanon = Just DKIM_RELAXED - } -setDkimCanonAlgo "relaxed/simple" dkim = dkim { - mdkimHeaderCanon = Just DKIM_RELAXED - , mdkimBodyCanon = Just DKIM_SIMPLE - } -setDkimCanonAlgo "simple/relaxed" dkim = dkim { - mdkimHeaderCanon = Just DKIM_SIMPLE - , mdkimBodyCanon = Just DKIM_RELAXED - } -setDkimCanonAlgo "simple/simple" dkim = dkim { - mdkimHeaderCanon = Just DKIM_SIMPLE - , mdkimBodyCanon = Just DKIM_SIMPLE - } +setDkimCanonAlgo "relaxed" dkim = + dkim + { mdkimHeaderCanon = Just DKIM_RELAXED + , mdkimBodyCanon = Just DKIM_SIMPLE + } +setDkimCanonAlgo "relaxed/relaxed" dkim = + dkim + { mdkimHeaderCanon = Just DKIM_RELAXED + , mdkimBodyCanon = Just DKIM_RELAXED + } +setDkimCanonAlgo "relaxed/simple" dkim = + dkim + { mdkimHeaderCanon = Just DKIM_RELAXED + , mdkimBodyCanon = Just DKIM_SIMPLE + } +setDkimCanonAlgo "simple/relaxed" dkim = + dkim + { mdkimHeaderCanon = Just DKIM_SIMPLE + , mdkimBodyCanon = Just DKIM_RELAXED + } +setDkimCanonAlgo "simple/simple" dkim = + dkim + { mdkimHeaderCanon = Just DKIM_SIMPLE + , mdkimBodyCanon = Just DKIM_SIMPLE + } setDkimCanonAlgo _ _ = error "setDkimCanonAlgo" setDkimDomain :: DKIMSetter -setDkimDomain dom dkim = dkim { mdkimDomain = Just dom } +setDkimDomain dom dkim = dkim{mdkimDomain = Just dom} setDkimFields :: DKIMSetter -setDkimFields keys dkim = dkim { mdkimFields = Just flds } +setDkimFields keys dkim = dkim{mdkimFields = Just flds} where flds = map canonicalizeKey $ BS.split ':' keys setDkimLength :: DKIMSetter -setDkimLength len dkim = dkim { mdkimLength = fst <$> BS.readInt len } +setDkimLength len dkim = dkim{mdkimLength = fst <$> BS.readInt len} setDkimSelector :: DKIMSetter -setDkimSelector sel dkim = dkim { mdkimSelector = Just sel } +setDkimSelector sel dkim = dkim{mdkimSelector = Just sel} 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 @@ -14,21 +14,22 @@ ---------------------------------------------------------------- -data DkimSigAlgo = RSA_SHA1 | RSA_SHA256 deriving (Eq,Show) -data DkimCanonAlgo = DKIM_SIMPLE | DKIM_RELAXED deriving (Eq,Show) +data DkimSigAlgo = RSA_SHA1 | RSA_SHA256 deriving (Eq, Show) +data DkimCanonAlgo = DKIM_SIMPLE | DKIM_RELAXED deriving (Eq, Show) -data DKIM = DKIM { - dkimVersion :: ByteString - , dkimSigAlgo :: DkimSigAlgo - , dkimSignature :: ByteString - , dkimBodyHash :: ByteString - , dkimHeaderCanon :: DkimCanonAlgo - , dkimBodyCanon :: DkimCanonAlgo - , dkimDomain0 :: ByteString - , dkimFields :: [CanonFieldKey] - , dkimLength :: Maybe Int - , dkimSelector0 :: ByteString - } deriving (Eq,Show) +data DKIM = DKIM + { dkimVersion :: ByteString + , dkimSigAlgo :: DkimSigAlgo + , dkimSignature :: ByteString + , dkimBodyHash :: ByteString + , dkimHeaderCanon :: DkimCanonAlgo + , dkimBodyCanon :: DkimCanonAlgo + , dkimDomain0 :: ByteString + , dkimFields :: [CanonFieldKey] + , dkimLength :: Maybe Int + , dkimSelector0 :: ByteString + } + deriving (Eq, Show) -- | Getting of the value of the \"d\" tag in DKIM-Signature:. dkimDomain :: DKIM -> Domain 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 @@ -2,16 +2,17 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Network.DomainAuth.DKIM.Verify ( - verifyDKIM, prepareDKIM - ) where + verifyDKIM, + prepareDKIM, +) where 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 Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL import Network.DomainAuth.DKIM.Btag @@ -25,7 +26,7 @@ prepareDKIM :: DKIM -> Mail -> Builder prepareDKIM dkim mail = header where - dkimField:fields = fieldsFrom dkimFieldKey (mailHeader mail) + dkimField : fields = fieldsFrom dkimFieldKey (mailHeader mail) hCanon = canonDkimField (dkimHeaderCanon dkim) canon = BB.byteString . removeBtagValue . hCanon targets = fieldsWith (dkimFields dkim) fields @@ -34,7 +35,7 @@ ---------------------------------------------------------------- canonDkimField :: DkimCanonAlgo -> Field -> ByteString -canonDkimField DKIM_SIMPLE fld = fieldKey fld +++ ": " +++ fieldValueFolded fld +canonDkimField DKIM_SIMPLE fld = fieldKey fld +++ ": " +++ fieldValueFolded fld canonDkimField DKIM_RELAXED fld = fieldSearchKey fld +++ ":" +++ canon fld where canon = BS.dropWhile isSpace . removeTrailingWSP . reduceWSP . BS.concat . fieldValue @@ -42,7 +43,7 @@ ---------------------------------------------------------------- canonDkimBody :: DkimCanonAlgo -> Body -> Builder -canonDkimBody DKIM_SIMPLE = fromBody . removeTrailingEmptyLine +canonDkimBody DKIM_SIMPLE = fromBody . removeTrailingEmptyLine canonDkimBody DKIM_RELAXED = fromBodyWith relax . removeTrailingEmptyLine where relax = removeTrailingWSP . reduceWSP @@ -50,19 +51,24 @@ ---------------------------------------------------------------- verifyDKIM :: Mail -> DKIM -> PublicKey -> Bool -verifyDKIM mail dkim pub = bodyHash1 mail == bodyHash2 dkim && - verify' (dkimSigAlgo dkim) pub cmail sig +verifyDKIM mail dkim pub = + bodyHash1 mail == bodyHash2 dkim + && verify' (dkimSigAlgo dkim) pub cmail sig where sig = B.decode . dkimSignature $ dkim cmail = BL.toStrict $ BB.toLazyByteString $ prepareDKIM dkim mail - bodyHash1 = hashAlgo2 (dkimSigAlgo dkim) . BL.toStrict . BB.toLazyByteString . canonDkimBody (dkimBodyCanon dkim) . mailBody + bodyHash1 = + hashAlgo2 (dkimSigAlgo dkim) + . BL.toStrict + . BB.toLazyByteString + . canonDkimBody (dkimBodyCanon dkim) + . mailBody bodyHash2 = B.decode . dkimBodyHash -verify' :: DkimSigAlgo-> PublicKey -> ByteString -> ByteString -> Bool -verify' RSA_SHA1 = verify (Just SHA1) +verify' :: DkimSigAlgo -> PublicKey -> ByteString -> ByteString -> Bool +verify' RSA_SHA1 = verify (Just SHA1) verify' RSA_SHA256 = verify (Just SHA256) hashAlgo2 :: ByteArray c => DkimSigAlgo -> ByteString -> c -hashAlgo2 RSA_SHA1 = convert . (hash :: ByteString -> Digest SHA1) +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,37 +1,53 @@ -- | A library to parse e-mail messages both from a file and Milter(). - module Network.DomainAuth.Mail ( - -- * Documentation - -- ** Types for raw e-mail message - RawMail - , RawFieldKey - , RawFieldValue - , RawBodyChunk - -- ** Types for parsed e-mail message - , Mail(..), Header, Field(..), CanonFieldKey, FieldKey, FieldValue, Body - , canonicalizeKey - -- ** Obtaining 'Mail' - , readMail, getMail - -- ** Obtaining 'Mail' incrementally. - , XMail(..) - , initialXMail - , pushField, pushBody, finalizeMail - -- ** Functions to manipulate 'Header' - , lookupField - , fieldsFrom - , fieldsAfter - , fieldsWith - -- ** Functions to manipulate 'Field' - , fieldValueFolded - , fieldValueUnfolded - -- ** Functions to manipulate 'Body' - , isEmpty - , fromBody - , fromBodyWith - , removeTrailingEmptyLine - -- ** Special function for DomainKeys and DKIM - , parseTaggedValue - ) where + -- * Documentation + + -- ** Types for raw e-mail message + RawMail, + RawFieldKey, + RawFieldValue, + RawBodyChunk, + + -- ** Types for parsed e-mail message + Mail (..), + Header, + Field (..), + CanonFieldKey, + FieldKey, + FieldValue, + Body, + canonicalizeKey, + + -- ** Obtaining 'Mail' + readMail, + getMail, + + -- ** Obtaining 'Mail' incrementally. + XMail (..), + initialXMail, + pushField, + pushBody, + finalizeMail, + + -- ** Functions to manipulate 'Header' + lookupField, + fieldsFrom, + fieldsAfter, + fieldsWith, + + -- ** Functions to manipulate 'Field' + fieldValueFolded, + fieldValueUnfolded, + + -- ** Functions to manipulate 'Body' + isEmpty, + fromBody, + fromBodyWith, + removeTrailingEmptyLine, + + -- ** Special function for DomainKeys and DKIM + parseTaggedValue, +) where import Network.DomainAuth.Mail.Mail import Network.DomainAuth.Mail.Parser 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,16 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.Mail.Mail ( - lookupField - , fieldsFrom - , fieldsAfter - , fieldsWith - , fieldValueFolded - , fieldValueUnfolded - , fromBody - , fromBodyWith - , removeTrailingEmptyLine - ) where + lookupField, + fieldsFrom, + fieldsAfter, + fieldsWith, + fieldValueFolded, + fieldValueUnfolded, + fromBody, + fromBodyWith, + removeTrailingEmptyLine, +) where import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder) @@ -20,10 +20,10 @@ import qualified Data.Foldable as F (foldr) import Data.List import Data.Maybe (catMaybes) -import Data.Sequence (Seq, viewr, ViewR(..), empty) +import Data.Sequence (Seq, ViewR (..), empty, viewr) import Network.DomainAuth.Mail.Types -import qualified Network.DomainAuth.Utils as B (empty) import Network.DomainAuth.Utils hiding (empty) +import qualified Network.DomainAuth.Utils as B (empty) -- $setup -- >>> :set -XOverloadedStrings @@ -82,18 +82,18 @@ -- -- 'Notihng' represents the null above. -- --- >>> enm [1,2,3] [1,1,2,2,2,3,4,5] (==) +-- >>> enm [1::Int,2,3] [1,1,2,2,2,3,4,5] (==) -- [Just 1,Just 2,Just 3] --- >>> enm [1,1,2,3] [1,1,2,2,2,3,4,5] (==) +-- >>> enm [1::Int,1,2,3] [1,1,2,2,2,3,4,5] (==) -- [Just 1,Just 1,Just 2,Just 3] --- >>> enm [1,1,1,2,3] [1,1,2,2,2,3,4,5] (==) +-- >>> enm [1::Int,1,1,2,3] [1,1,2,2,2,3,4,5] (==) -- [Just 1,Just 1,Nothing,Just 2,Just 3] enm :: [a] -> [b] -> (a -> b -> Bool) -> [Maybe b] enm [] _ _ = [] enm _ [] _ = [] -enm (k:kx) hs0 eq = case fnd (eq k) hs0 of - Nothing -> Nothing : enm kx hs0 eq - Just (x,hs) -> Just x : enm kx hs eq +enm (k : kx) hs0 eq = case fnd (eq k) hs0 of + Nothing -> Nothing : enm kx hs0 eq + Just (x, hs) -> Just x : enm kx hs eq -- >>> fnd (== 1) [1,2,3] -- Just (1,[2,3]) @@ -103,13 +103,13 @@ -- Just (3,[1,2]) -- >>> fnd (== 4) [1,2,3] -- Nothing -fnd :: (a -> Bool) -> [a] -> Maybe (a,[a]) +fnd :: (a -> Bool) -> [a] -> Maybe (a, [a]) fnd _ [] = Nothing -fnd p (x:xs) - | p x = Just (x, xs) - | otherwise = case fnd p xs of - Nothing -> Nothing - Just (y,ys) -> Just (y, x:ys) +fnd p (x : xs) + | p x = Just (x, xs) + | otherwise = case fnd p xs of + Nothing -> Nothing + Just (y, ys) -> Just (y, x : ys) ---------------------------------------------------------------- @@ -141,12 +141,12 @@ -- | Removing trailing empty lines. removeTrailingEmptyLine :: Body -> Body -removeTrailingEmptyLine = dropWhileR (=="") +removeTrailingEmptyLine = dropWhileR (== "") -- dropWhileR is buggy, sigh. dropWhileR :: (a -> Bool) -> Seq a -> Seq a dropWhileR p xs = case viewr xs of - EmptyR -> empty + EmptyR -> empty xs' :> x - | p x -> dropWhileR p xs' - | otherwise -> xs + | p x -> dropWhileR p xs' + | otherwise -> xs 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,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.Mail.Parser ( - readMail - , getMail - , parseTaggedValue - ) where + readMail, + getMail, + parseTaggedValue, +) where import qualified Data.ByteString as BS import Data.Word @@ -37,25 +37,26 @@ getMail :: RawMail -> Mail getMail bs = finalizeMail $ pushBody rbdy xmail where - (rhdr,rbdy) = splitHeaderBody bs + (rhdr, rbdy) = splitHeaderBody bs rflds = splitFields rhdr xmail = foldl push initialXMail rflds - push m fld = let (k,v) = parseField fld - in pushField k v m + push m fld = + let (k, v) = parseField fld + in pushField k v m ---------------------------------------------------------------- -splitHeaderBody :: RawMail -> (RawHeader,RawBody) +splitHeaderBody :: RawMail -> (RawHeader, RawBody) splitHeaderBody bs = case mcnt of - Nothing -> (bs,"") + Nothing -> (bs, "") Just cnt -> check (BS.splitAt cnt bs) where mcnt = findEOH bs 0 - check (hdr,bdy) = (hdr, dropSep bdy) + check (hdr, bdy) = (hdr, dropSep bdy) dropSep bdy - | len == 0 = "" - | len == 1 = "" - | otherwise = if b1 == cCR then bdy3 else bdy2 + | len == 0 = "" + | len == 1 = "" + | otherwise = if b1 == cCR then bdy3 else bdy2 where len = BS.length bdy b1 = BS.head bdy @@ -65,16 +66,20 @@ findEOH :: RawMail -> Int -> Maybe Int findEOH "" _ = Nothing findEOH bs cnt - | b0 == cLF && bs1 /= "" && b1 == cLF = Just (cnt + 1) - | b0 == cLF && bs1 /= "" && b1 == cCR - && bs2 /= "" && b2 == cLF = Just (cnt + 1) - | otherwise = findEOH bs1 (cnt + 1) + | b0 == cLF && bs1 /= "" && b1 == cLF = Just (cnt + 1) + | b0 == cLF + && bs1 /= "" + && b1 == cCR + && bs2 /= "" + && b2 == cLF = + Just (cnt + 1) + | otherwise = findEOH bs1 (cnt + 1) where - b0 = BS.head bs + b0 = BS.head bs bs1 = BS.tail bs - b1 = BS.head bs1 + b1 = BS.head bs1 bs2 = BS.tail bs1 - b2 = BS.head bs2 + b2 = BS.head bs2 ---------------------------------------------------------------- @@ -83,25 +88,25 @@ splitFields bs = fld : splitFields bs'' where -- split before cLF for efficiency - (fld,bs') = BS.splitAt (findFieldEnd bs 0 - 1) bs + (fld, bs') = BS.splitAt (findFieldEnd bs 0 - 1) bs bs'' = BS.tail bs' findFieldEnd :: RawMail -> Int -> Int findFieldEnd bs cnt - | bs == "" = cnt - | b == cLF = begOfLine bs' (cnt + 1) - | otherwise = findFieldEnd bs' (cnt + 1) + | bs == "" = cnt + | b == cLF = begOfLine bs' (cnt + 1) + | otherwise = findFieldEnd bs' (cnt + 1) where - b = BS.head bs + b = BS.head bs bs' = BS.tail bs begOfLine :: RawMail -> Int -> Int begOfLine bs cnt - | bs == "" = cnt + | bs == "" = cnt | isContinued b = findFieldEnd bs' (cnt + 1) - | otherwise = cnt + | otherwise = cnt where - b = BS.head bs + b = BS.head bs bs' = BS.tail bs isContinued :: Word8 -> Bool @@ -109,14 +114,15 @@ ---------------------------------------------------------------- -parseField :: RawField -> (RawFieldKey,RawFieldValue) -parseField bs = (k,v') +parseField :: RawField -> (RawFieldKey, RawFieldValue) +parseField bs = (k, v') where - (k,v) = break' cColon bs + (k, v) = break' cColon bs -- Sendmail drops ' ' after ':'. - v' = if v /= "" && BS.head v == cSP - then BS.tail v - else v + v' = + if v /= "" && BS.head v == cSP + then BS.tail v + else v ---------------------------------------------------------------- -- This breaks spaces in the note tag. @@ -127,9 +133,9 @@ -- [("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 :: RawFieldValue -> [(BS.ByteString, BS.ByteString)] parseTaggedValue xs = vss where - v = BS.filter (not.isSpace) xs + v = BS.filter (not . isSpace) xs vs = filter (/= "") $ BS.split cSemiColon v vss = map (break' cEqual) vs 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 @@ -6,25 +6,31 @@ import Data.Sequence ---------------------------------------------------------------- + -- | Type for raw e-mail message. type RawMail = ByteString + type RawHeader = ByteString type RawBody = ByteString type RawField = ByteString + -- | Field key for raw e-mail message. type RawFieldKey = ByteString + -- | Field value for raw e-mail message. type RawFieldValue = ByteString + -- | Body chunk for raw e-mail message. type RawBodyChunk = ByteString ---------------------------------------------------------------- -- | Type for parsed e-mail message. -data Mail = Mail { - mailHeader :: Header - , mailBody :: Body - } deriving (Eq,Show) +data Mail = Mail + { mailHeader :: Header + , mailBody :: Body + } + deriving (Eq, Show) isEmpty :: Body -> Bool isEmpty = (== empty) @@ -33,18 +39,22 @@ type Header = [Field] -- | Field type for parsed e-mail message. -data Field = Field { - fieldSearchKey :: CanonFieldKey - , fieldKey :: FieldKey - , fieldValue :: FieldValue - } deriving (Eq,Show) +data Field = Field + { fieldSearchKey :: CanonFieldKey + , fieldKey :: FieldKey + , fieldValue :: FieldValue + } + deriving (Eq, Show) -- | Type for canonicalized field key of parsed e-mail message. type CanonFieldKey = ByteString + -- | Type for field key of parsed e-mail message. type FieldKey = ByteString + -- | Type for field value of parsed e-mail message. type FieldValue = [ByteString] + -- | Type for body of parsed e-mail message. type Body = Seq ByteString 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,10 +1,10 @@ module Network.DomainAuth.Mail.XMail ( - XMail(..) - , initialXMail - , pushField - , pushBody - , finalizeMail - ) where + XMail (..), + initialXMail, + pushField, + pushBody, + finalizeMail, +) where import qualified Data.ByteString.Char8 as BS import Data.Sequence (fromList) @@ -14,10 +14,11 @@ ---------------------------------------------------------------- -- | Type for temporary data to parse e-mail message. -data XMail = XMail { - xmailHeader :: Header - , xmailBody :: [RawBodyChunk] - } deriving (Eq,Show) +data XMail = XMail + { xmailHeader :: Header + , xmailBody :: [RawBodyChunk] + } + deriving (Eq, Show) -- | Initial value for 'XMail'. initialXMail :: XMail @@ -25,22 +26,25 @@ -- | Storing field key and field value to the temporary data. pushField :: RawFieldKey -> RawFieldValue -> XMail -> XMail -pushField key val xmail = xmail { - xmailHeader = fld : xmailHeader xmail - } +pushField key val xmail = + xmail + { xmailHeader = fld : xmailHeader xmail + } where fld = Field ckey key (blines val) ckey = canonicalizeKey key -- | Storing body chunk to the temporary data. pushBody :: RawBodyChunk -> XMail -> XMail -pushBody bc xmail = xmail { - xmailBody = bc : xmailBody xmail - } +pushBody bc xmail = + xmail + { xmailBody = bc : xmailBody xmail + } -- | Converting 'XMail' to 'Mail'. finalizeMail :: XMail -> Mail -finalizeMail xmail = Mail { - mailHeader = reverse . xmailHeader $ xmail - , mailBody = fromList . blines . BS.concat . reverse . xmailBody $ xmail - } +finalizeMail xmail = + Mail + { mailHeader = reverse . xmailHeader $ xmail + , mailBody = fromList . blines . BS.concat . reverse . xmailBody $ xmail + } diff --git a/Network/DomainAuth/PRD.hs b/Network/DomainAuth/PRD.hs --- a/Network/DomainAuth/PRD.hs +++ b/Network/DomainAuth/PRD.hs @@ -1,10 +1,8 @@ -- | Utilities to decide Purported Responsible Domain (). - module Network.DomainAuth.PRD ( - module Network.DomainAuth.PRD.PRD - , module Network.DomainAuth.PRD.Domain - ) where + module Network.DomainAuth.PRD.PRD, + module Network.DomainAuth.PRD.Domain, +) where -import Network.DomainAuth.PRD.PRD import Network.DomainAuth.PRD.Domain - +import 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,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.PRD.Domain ( - extractDomain - ) where + extractDomain, +) where +import qualified Data.Attoparsec.ByteString as P +import qualified Data.ByteString.Char8 as BS import Network.DNS (Domain) import Network.DomainAuth.Mail import Network.DomainAuth.PRD.Lexer -import qualified Data.Attoparsec.ByteString as P -import qualified Data.ByteString.Char8 as BS -- | Extract a domain from a value of a header field. -- @@ -20,12 +20,11 @@ -- Just "example.com" -- >>> extractDomain "Alice Brown " -- Nothing - extractDomain :: RawFieldValue -> Maybe Domain extractDomain bs = case P.parseOnly structured bs of - Left _ -> Nothing - Right st -> takeDomain st - where - takeDomain = dropTail . dropWhile (/="@") - dropTail [] = Nothing - dropTail xs = (Just . BS.concat . takeWhile (/=">") . tail) xs + Left _ -> Nothing + Right st -> takeDomain st + where + takeDomain = dropTail . dropWhile (/= "@") + dropTail [] = Nothing + 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,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.PRD.Lexer ( - structured - ) where + structured, +) where import Control.Applicative import Data.Attoparsec.ByteString (Parser) @@ -40,8 +40,8 @@ structured :: Parser [ByteString] structured = removeComments <$> many (P.choice choices) where - removeComments = filter (/="") - choices = [specials,quotedString,domainLiteral,atom,comment] + removeComments = filter (/= "") + choices = [specials, quotedString, domainLiteral, atom, comment] specials :: Parser ByteString specials = specialChar <* skipWsp @@ -66,7 +66,7 @@ skipWsp return $ concatSpace ds where - dtext = P.takeWhile1 $ P.inClass "!-Z^-~" + dtext = P.takeWhile1 $ P.inClass "!-Z^-~" ---------------------------------------------------------------- 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,12 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -- | Purported Responsible Domain, RFC 4407. - module Network.DomainAuth.PRD.PRD ( - PRD - , initialPRD, pushPRD - , decidePRD, decideFrom - ) where + PRD, + initialPRD, + pushPRD, + decidePRD, + decideFrom, +) where import Control.Monad import qualified Data.ByteString.Char8 as BS @@ -18,44 +19,46 @@ ---------------------------------------------------------------- -type HD = [(CanonFieldKey,RawFieldValue)] +type HD = [(CanonFieldKey, RawFieldValue)] 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. -data PRD = PRD { - praFrom :: DST - , praSender :: DST - , praResentFrom :: DST - , praResentSender :: DST - , praHeader :: HD - } deriving Show +data PRD = PRD + { praFrom :: DST + , praSender :: DST + , praResentFrom :: DST + , praResentSender :: DST + , praHeader :: HD + } + deriving (Show) -- | Initial context of PRD. initialPRD :: PRD -initialPRD = PRD { - praFrom = DST_Zero - , praSender = DST_Zero - , praResentFrom = DST_Zero - , praResentSender = DST_Zero - , praHeader = [] - } +initialPRD = + PRD + { praFrom = DST_Zero + , praSender = DST_Zero + , praResentFrom = DST_Zero + , praResentSender = DST_Zero + , praHeader = [] + } ---------------------------------------------------------------- -- | 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 - "sender" -> pushSender ctx' jdom - "resent-from" -> pushResentFrom ctx' jdom + "from" -> pushFrom ctx' jdom + "sender" -> pushSender ctx' jdom + "resent-from" -> pushResentFrom ctx' jdom "resent-sender" -> pushResentSender ctx' jdom - _ -> ctx' + _ -> ctx' where ckey = BS.map toLower key jdom = extractDomain val - ctx' = ctx { praHeader = (ckey,val) : praHeader ctx } + ctx' = ctx{praHeader = (ckey, val) : praHeader ctx} -- | Deciding PRD from the RPD context. -- @@ -131,15 +134,15 @@ -- $ pushPRD "from" maddr1 initialPRD) -- :} -- Just "dave.example.jp" - decidePRD :: PRD -> Maybe Domain decidePRD ctx = - let jds = [ praResentSender ctx - , praResentFrom ctx - , praSender ctx - , praFrom ctx - ] - in foldl' mplus mzero $ map toMaybe jds + let jds = + [ praResentSender ctx + , praResentFrom ctx + , praSender ctx + , praFrom ctx + ] + in foldl' mplus mzero $ map toMaybe jds -- | Taking the value of From: from the RPD context. -- @@ -150,44 +153,44 @@ toMaybe :: DST -> Maybe Domain toMaybe (DST_Valid d) = Just d -toMaybe _ = Nothing +toMaybe _ = Nothing ---------------------------------------------------------------- pushFrom :: PRD -> Maybe Domain -> PRD -pushFrom ctx Nothing = ctx { praFrom = DST_Invalid } -pushFrom ctx (Just dom) = ctx { praFrom = from } +pushFrom ctx Nothing = ctx{praFrom = DST_Invalid} +pushFrom ctx (Just dom) = ctx{praFrom = from} where from = case praFrom ctx of DST_Zero -> DST_Valid dom - _ -> DST_Invalid + _ -> DST_Invalid pushSender :: PRD -> Maybe Domain -> PRD -pushSender ctx Nothing = ctx { praSender = DST_Invalid } -pushSender ctx (Just dom) = ctx { praSender = sender } +pushSender ctx Nothing = ctx{praSender = DST_Invalid} +pushSender ctx (Just dom) = ctx{praSender = sender} where sender = case praSender ctx of DST_Zero -> DST_Valid dom - _ -> DST_Invalid + _ -> DST_Invalid pushResentFrom :: PRD -> Maybe Domain -> PRD -pushResentFrom ctx Nothing = ctx { praResentFrom = DST_Invalid } -pushResentFrom ctx (Just dom) = ctx { praResentFrom = rfrom } +pushResentFrom ctx Nothing = ctx{praResentFrom = DST_Invalid} +pushResentFrom ctx (Just dom) = ctx{praResentFrom = rfrom} where rfrom = case praResentFrom ctx of - DST_Zero -> DST_Valid dom + DST_Zero -> DST_Valid dom DST_Valid d -> DST_Valid d DST_Invalid -> DST_Invalid pushResentSender :: PRD -> Maybe Domain -> PRD -pushResentSender ctx Nothing = ctx { praResentSender = DST_Invalid } +pushResentSender ctx Nothing = ctx{praResentSender = DST_Invalid} pushResentSender ctx (Just dom) - | praResentFrom ctx == DST_Zero = ctx { praResentSender = rsender } - | isFirstBlock (praHeader ctx) = ctx { praResentSender = DST_Valid dom } - | otherwise = ctx { praResentSender = DST_Invalid } + | praResentFrom ctx == DST_Zero = ctx{praResentSender = rsender} + | isFirstBlock (praHeader ctx) = ctx{praResentSender = DST_Valid dom} + | otherwise = ctx{praResentSender = DST_Invalid} where rsender = case praResentSender ctx of - DST_Zero -> DST_Valid dom + DST_Zero -> DST_Valid dom DST_Valid d -> DST_Valid d DST_Invalid -> DST_Invalid @@ -195,4 +198,4 @@ isFirstBlock hdr = all rr . takeWhile end $ hdr where end = (/= "resent-from") . fst - rr = (`notElem` ["received", "return-path"]) . fst + rr = (`notElem` ["received", "return-path"]) . fst 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,21 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.Pubkey.Base64 ( - decode - , decode' - ) where + decode, + decode', +) where import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL import Data.Word import Network.DomainAuth.Utils isBase64 :: Word8 -> Bool -isBase64 c = isAlphaNum c || (c `elem` [cPlus,cSlash,cEqual]) +isBase64 c = isAlphaNum c || (c `elem` [cPlus, cSlash, cEqual]) decode :: ByteString -> ByteString decode = BL.toStrict . decode' @@ -25,11 +25,11 @@ dec :: ByteString -> Builder dec bs - | BS.null bs = empty + | BS.null bs = empty | len == 4 && c3 == cEqual = dec1' x1 x2 | len == 4 && c4 == cEqual = dec2' x1 x2 x3 - | len >= 4 = dec' x1 x2 x3 x4 +++ dec bs' - | otherwise = error "dec" + | len >= 4 = dec' x1 x2 x3 x4 +++ dec bs' + | otherwise = error "dec" where len = BS.length bs c1 = bs !!! 0 @@ -45,29 +45,29 @@ dec' :: Word8 -> Word8 -> Word8 -> Word8 -> Builder dec' x1 x2 x3 x4 = BB.word8 d1 <> BB.word8 d2 <> BB.word8 d3 where - d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4) + 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 = BB.word8 d1 where - d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4) + d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4) dec2' :: Word8 -> Word8 -> Word8 -> Builder dec2' x1 x2 x3 = BB.word8 d1 <> BB.word8 d2 where - d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4) + d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4) d2 = ((x2 `shiftL` 4) .&. 0xF0) .|. (x3 `shiftR` 2) fromChar :: Word8 -> Word8 fromChar c - | isUpper c = c - cA - | isLower c = c - cSmallA + 26 - | isDigit c = c - cZero + 52 - | c == cPlus = 62 - | c == cSlash = 63 - | otherwise = error ("fromChar: Can't happen: Bad input: " ++ show c) + | isUpper c = c - cA + | isLower c = c - cSmallA + 26 + | isDigit c = c - cZero + 52 + | c == cPlus = 62 + | c == cSlash = 63 + | otherwise = error ("fromChar: Can't happen: Bad input: " ++ show c) {- splits :: Int -> [a] -> [[a]] 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,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.Pubkey.RSAPub ( - lookupPublicKey - ) where + lookupPublicKey, +) where import Crypto.PubKey.RSA (PublicKey) import Data.ASN1.BinaryEncoding (DER) @@ -10,7 +10,7 @@ import Data.ASN1.Types (fromASN1) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS () -import Data.X509 (PubKey(PubKeyRSA)) +import Data.X509 (PubKey (PubKeyRSA)) import Network.DNS (Domain) import qualified Network.DNS as DNS import Network.DomainAuth.Mail @@ -24,31 +24,32 @@ -- >>> 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 "20221208._domainkey.gmail.com" --- Just (PublicKey {public_size = 256, public_n = 22678151869562939359899136428859256198402569240680475393086048829021713182010490409724483359945551283969506235489826762257419985891230334120904178414351809046671461143996599803281758436654811035615578092428632166371331342907633917876752170113620966009358291594609542956251740141784694619901495773614035042135465203364073740861194611021551592336450807473519143746970021740067888325723330796836146546417386918505126721680365151889317110944800331756379997471380657912089911948147086686452887197011845657708078311037666769039161141500897109834073427400667740315220146696437513966171590587213846521825862509466370365529359, public_e = 65537}) +-- >>> withResolver rs $ \rslv -> lookupPublicKey rslv "20230601._domainkey.gmail.com" +-- Just (PublicKey {public_size = 256, public_n = 20054049931062868895890884170436368122145070743595938421415808271536128118589158095389269883866014690926251520949836343482211446965168263353397278625494421205505467588876376305465260221818103647257858226961376710643349248303872103127777544119851941320649869060657585270523355729363214754986381410240666592048188131951162530964876952500210032559004364102337827202989395200573305906145708107347940692172630683838117810759589085094521858867092874903269345174914871903592244831151967447426692922405241398232069182007622735165026000699140578092635934951967194944536539675594791745699200646238889064236642593556016708235359, public_e = 65537}) lookupPublicKey :: DNS.Resolver -> Domain -> IO (Maybe PublicKey) lookupPublicKey resolver domain = do mpub <- lookupPublicKey' resolver domain return $ case mpub of - Nothing -> Nothing - Just pub -> Just $ decodeRSAPublicyKey pub + Nothing -> Nothing + Just pub -> decodeRSAPublicyKey pub lookupPublicKey' :: DNS.Resolver -> Domain -> IO (Maybe ByteString) lookupPublicKey' resolver domain = do ex <- DNS.lookupTXT resolver domain case ex of - Left _ -> return Nothing + Left _ -> return Nothing Right x -> return $ extractPub x extractPub :: [ByteString] -> Maybe ByteString -extractPub = lookup "p" . parseTaggedValue . head +extractPub xs = case xs of + [] -> Nothing + (x : _) -> lookup "p" (parseTaggedValue x) -decodeRSAPublicyKey :: ByteString -> PublicKey -decodeRSAPublicyKey b64 = pub +decodeRSAPublicyKey :: ByteString -> Maybe PublicKey +decodeRSAPublicyKey b64 = case decodeASN1' (undefined :: DER) der of + Left _ -> Nothing + Right ans1 -> case fromASN1 ans1 of + Right (PubKeyRSA p, []) -> Just p + _ -> Nothing where der = B.decode b64 - pub = case decodeASN1' (undefined :: DER) der of - Left _ -> error "decodeRSAPublicyKey (1)" - Right ans1 -> case fromASN1 ans1 of - Right (PubKeyRSA p,[]) -> p - _ -> error "decodeRSAPublicyKey (2)" diff --git a/Network/DomainAuth/SPF.hs b/Network/DomainAuth/SPF.hs --- a/Network/DomainAuth/SPF.hs +++ b/Network/DomainAuth/SPF.hs @@ -1,11 +1,10 @@ -- | A library for SPF() -- and Sender-ID(). - module Network.DomainAuth.SPF ( - runSPF - , Limit(..) - , defaultLimit - ) where + runSPF, + Limit (..), + defaultLimit, +) where import Control.Exception as E import Data.IP @@ -50,13 +49,12 @@ -- >>> let limit1 = defaultLimit { ipv4_masklen = 24 } -- >>> withResolver rs $ \rslv -> runSPF limit1 rslv "gmail.com" "72.14.192.1" -- softfail - runSPF :: Limit -> Resolver -> Domain -> IP -> IO DAResult runSPF lim resolver dom ip = (resolveSPF resolver dom ip >>= evalSPF lim ip) `E.catch` spfErrorHandle spfErrorHandle :: IOError -> IO DAResult spfErrorHandle e = case ioeGetErrorString e of - "TempError" -> return DATempError - "PermError" -> return DAPermError - _ -> return DANone + "TempError" -> return DATempError + "PermError" -> return DAPermError + _ -> return DANone 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,8 +1,8 @@ module Network.DomainAuth.SPF.Eval ( - evalSPF - , Limit(..) - , defaultLimit - ) where + evalSPF, + Limit (..), + defaultLimit, +) where import Data.IORef import Data.IP @@ -11,30 +11,31 @@ import Network.DomainAuth.Types -- | Limit for SPF authentication. -data Limit = Limit { - -- | How many \"redirect\"/\"include\" should be followed. +data Limit = Limit + { limit :: Int + -- ^ 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 - -- | Ignoring IPv6 range whose mask length is shorter than this. - , ipv6_masklen :: Int - -- | Whether or not \"+all\" is rejected. - , reject_plus_all :: Bool - } deriving (Eq, Show) + , ipv4_masklen :: Int + -- ^ Ignoring IPv4 range whose mask length is shorter than this. + , ipv6_masklen :: Int + -- ^ Ignoring IPv6 range whose mask length is shorter than this. + , reject_plus_all :: Bool + -- ^ Whether or not \"+all\" is rejected. + } + deriving (Eq, Show) -- | Default value for 'Limit'. -- -- >>> defaultLimit -- Limit {limit = 10, ipv4_masklen = 16, ipv6_masklen = 48, reject_plus_all = True} - defaultLimit :: Limit -defaultLimit = Limit { - limit = 10 - , ipv4_masklen = 16 - , ipv6_masklen = 48 - , reject_plus_all = True - } +defaultLimit = + Limit + { limit = 10 + , ipv4_masklen = 16 + , ipv6_masklen = 48 + , reject_plus_all = True + } ---------------------------------------------------------------- @@ -47,15 +48,15 @@ evalspf :: IORef Int -> Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult) evalspf _ _ _ [] = return (Just DANeutral) -- default result -evalspf ref lim ip (s:ss) = do +evalspf ref lim ip (s : ss) = do cnt <- readIORef ref if cnt > limit lim - then return (Just DAPermError) -- reached the limit - else do - mres <- eval ref lim ip s - case mres of - Nothing -> evalspf ref lim ip ss - res -> return res + then return (Just DAPermError) -- reached the limit + else do + mres <- eval ref lim ip s + case mres of + Nothing -> evalspf ref lim ip ss + res -> return res ---------------------------------------------------------------- -- Follow N of redirect/include. But the last one is not @@ -66,34 +67,35 @@ cnt <- readIORef ref s <- is case s of - SS_All q -> if q == Q_Pass && reject_plus_all lim - then result DAPermError - else ret q - SS_IPv4Range q ipr - | nastyMask4 lim ipr -> result DAPermError - | ipv4 ip `isMatchedTo` ipr -> ret q - | otherwise -> continue - SS_IPv4Ranges q iprs - | any (nastyMask4 lim) iprs -> result DAPermError - | any (ipv4 ip `isMatchedTo`) iprs -> ret q - | otherwise -> continue - SS_IPv6Range q ipr - | nastyMask6 lim ipr -> result DAPermError - | ipv6 ip `isMatchedTo` ipr -> ret q - | otherwise -> continue - SS_IPv6Ranges q iprs - | any (nastyMask6 lim) iprs -> result DAPermError - | any (ipv6 ip `isMatchedTo`) iprs -> ret q - | otherwise -> continue - SS_IF_Pass q ss -> do - writeIORef ref (cnt + 1) - r <- evalspf ref lim ip ss - if r == Just DAPass - then ret q - else continue - SS_SpfSeq ss -> do - writeIORef ref (cnt + 1) - evalspf ref lim ip ss + SS_All q -> + if q == Q_Pass && reject_plus_all lim + then result DAPermError + else ret q + SS_IPv4Range q ipr + | nastyMask4 lim ipr -> result DAPermError + | ipv4 ip `isMatchedTo` ipr -> ret q + | otherwise -> continue + SS_IPv4Ranges q iprs + | any (nastyMask4 lim) iprs -> result DAPermError + | any (ipv4 ip `isMatchedTo`) iprs -> ret q + | otherwise -> continue + SS_IPv6Range q ipr + | nastyMask6 lim ipr -> result DAPermError + | ipv6 ip `isMatchedTo` ipr -> ret q + | otherwise -> continue + SS_IPv6Ranges q iprs + | any (nastyMask6 lim) iprs -> result DAPermError + | any (ipv6 ip `isMatchedTo`) iprs -> ret q + | otherwise -> continue + SS_IF_Pass q ss -> do + writeIORef ref (cnt + 1) + r <- evalspf ref lim ip ss + if r == Just DAPass + then ret q + else continue + SS_SpfSeq ss -> do + writeIORef ref (cnt + 1) + evalspf ref lim ip ss where ret = return . Just . toEnum . fromEnum result = return . Just 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,27 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.SPF.Parser ( - parseSPF - ) where + parseSPF, +) where import Control.Applicative import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString as P -import Data.ByteString (ByteString, ByteString) +import Data.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.Read (readMaybe) +import Prelude hiding (all) ---------------------------------------------------------------- parseSPF :: ByteString -> Maybe [SPF] parseSPF inp = case P.parseOnly spf inp of - Left _ -> Nothing - Right res -> Just res + Left _ -> Nothing + Right res -> Just res ---------------------------------------------------------------- @@ -31,10 +31,12 @@ ---------------------------------------------------------------- spf :: Parser [SPF] -spf = do spfPrefix - some $ do spaces1 - -- modifier should be first since + is optional - modifier <|> directive +spf = do + spfPrefix + some $ do + spaces1 + -- modifier should be first since + is optional + modifier <|> directive spfPrefix :: Parser () spfPrefix = () <$ P.string "v=spf1" @@ -51,23 +53,23 @@ qualifier :: Parser Qualifier qualifier = P.option Q_Pass (P.choice quals) - where - func sym res = res <$ P.word8 sym - quals = zipWith func (BS.unpack qualifierSymbol) [minBound..maxBound] + where + func sym res = res <$ P.word8 sym + quals = zipWith func (BS.unpack qualifierSymbol) [minBound .. maxBound] ---------------------------------------------------------------- type Directive = Qualifier -> Parser SPF mechanism :: Directive -mechanism q = P.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 = P.try $ do mip <- readMaybe . BS8.unpack <$> ip4range case mip of - Nothing -> fail "ip4" - Just ip -> return $ SPF_IPv4Range q ip + Nothing -> fail "ip4" + Just ip -> return $ SPF_IPv4Range q ip where ip4range = P.string "ip4:" *> P.takeWhile1 (P.notInClass " ") @@ -75,8 +77,8 @@ ip6 q = P.try $ do mip <- readMaybe . BS8.unpack <$> ip6range case mip of - Nothing -> fail "ip6" - Just ip -> return $ SPF_IPv6Range q ip + Nothing -> fail "ip6" + Just ip -> return $ SPF_IPv6Range q ip where ip6range = P.string "ip6:" *> P.takeWhile1 (P.notInClass " ") @@ -84,12 +86,16 @@ all q = P.try $ SPF_All q <$ P.string "all" address :: Directive -address q = SPF_Address q <$> (P.string "a" *> optionalDomain) - <*> optionalMask +address q = + SPF_Address q + <$> (P.string "a" *> optionalDomain) + <*> optionalMask mx :: Directive -mx q = SPF_MX q <$> (P.string "mx" *> optionalDomain) - <*> optionalMask +mx q = + SPF_MX q + <$> (P.string "mx" *> optionalDomain) + <*> optionalMask include :: Directive include q = SPF_Include q <$> (P.string "include:" *> domain) @@ -105,13 +111,13 @@ mask :: Parser Int mask = read . BS8.unpack <$> P.takeWhile1 (P.inClass "0-9") -optionalMask :: Parser (Int,Int) +optionalMask :: Parser (Int, Int) optionalMask = P.try both <|> P.try v4 <|> P.try v6 <|> none where both = (,) <$> ipv4Mask <*> ipv6Mask - v4 = ipv4Mask >>= \l4 -> return (l4,128) - v6 = ipv6Mask >>= \l6 -> return (32,l6) - none = return (32,128) + v4 = ipv4Mask >>= \l4 -> return (l4, 128) + v6 = ipv6Mask >>= \l6 -> return (32, l6) + none = return (32, 128) ipv4Mask :: Parser Int ipv4Mask = P.word8 _slash *> 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,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Network.DomainAuth.SPF.Resolver ( - resolveSPF - ) where + resolveSPF, +) where import Control.Monad -import Data.IP import qualified Data.ByteString.Char8 as BS +import Data.IP import Data.Maybe import Network.DNS import Network.DomainAuth.SPF.Parser @@ -27,8 +27,8 @@ where getSPFRR (Left _) = error "getSPRRR" getSPFRR (Right rc) - | null ts = "" - | otherwise = head ts + | null ts = "" + | otherwise = head ts where ts = filter ("v=spf1" `BS.isPrefixOf`) rc checkSyntax rs estr = when (isNothing rs) (fail estr) @@ -42,46 +42,45 @@ exceptIPv4 :: SPF -> Bool exceptIPv4 (SPF_IPv6Range _ _) = False -exceptIPv4 _ = True +exceptIPv4 _ = True exceptIPv6 :: SPF -> Bool exceptIPv6 (SPF_IPv4Range _ _) = False -exceptIPv6 _ = True +exceptIPv6 _ = True ---------------------------------------------------------------- toSpfSeq :: Resolver -> Domain -> IP -> SPF -> IO SpfSeq -toSpfSeq _ _ _ (SPF_IPv4Range q ipr) = return $ SS_IPv4Range q ipr -toSpfSeq _ _ _ (SPF_IPv6Range q ipr) = return $ SS_IPv6Range q ipr -toSpfSeq _ _ _ (SPF_All q) = return $ SS_All q -toSpfSeq r _ ip (SPF_Include q dom) = SS_IF_Pass q <$> resolveSPF r dom ip -toSpfSeq r _ ip (SPF_Redirect dom) = SS_SpfSeq <$> resolveSPF r dom ip - -toSpfSeq r dom (IPv4 _) (SPF_MX q Nothing (l4,_)) - = lookupAviaMX r dom >>= doit4 q l4 -toSpfSeq r dom (IPv6 _) (SPF_MX q Nothing (_,l6)) - = lookupAAAAviaMX r dom >>= doit6 q l6 -toSpfSeq r _ (IPv4 _) (SPF_MX q (Just dom) (l4,_)) - = lookupAviaMX r dom >>= doit4 q l4 -toSpfSeq r _ (IPv6 _) (SPF_MX q (Just dom) (_,l6)) - = lookupAAAAviaMX r dom >>= doit6 q l6 -toSpfSeq r dom (IPv4 _) (SPF_Address q Nothing (l4,_)) - = lookupA r dom >>= doit4 q l4 -toSpfSeq r dom (IPv6 _) (SPF_Address q Nothing (_,l6)) - = lookupAAAA r dom >>= doit6 q l6 -toSpfSeq r _ (IPv4 _) (SPF_Address q (Just dom) (l4,_)) - = lookupA r dom >>= doit4 q l4 -toSpfSeq r _ (IPv6 _) (SPF_Address q (Just dom) (_,l6)) - = lookupAAAA r dom >>= doit6 q l6 +toSpfSeq _ _ _ (SPF_IPv4Range q ipr) = return $ SS_IPv4Range q ipr +toSpfSeq _ _ _ (SPF_IPv6Range q ipr) = return $ SS_IPv6Range q ipr +toSpfSeq _ _ _ (SPF_All q) = return $ SS_All q +toSpfSeq r _ ip (SPF_Include q dom) = SS_IF_Pass q <$> resolveSPF r dom ip +toSpfSeq r _ ip (SPF_Redirect dom) = SS_SpfSeq <$> resolveSPF r dom ip +toSpfSeq r dom (IPv4 _) (SPF_MX q Nothing (l4, _)) = + lookupAviaMX r dom >>= doit4 q l4 +toSpfSeq r dom (IPv6 _) (SPF_MX q Nothing (_, l6)) = + lookupAAAAviaMX r dom >>= doit6 q l6 +toSpfSeq r _ (IPv4 _) (SPF_MX q (Just dom) (l4, _)) = + lookupAviaMX r dom >>= doit4 q l4 +toSpfSeq r _ (IPv6 _) (SPF_MX q (Just dom) (_, l6)) = + lookupAAAAviaMX r dom >>= doit6 q l6 +toSpfSeq r dom (IPv4 _) (SPF_Address q Nothing (l4, _)) = + lookupA r dom >>= doit4 q l4 +toSpfSeq r dom (IPv6 _) (SPF_Address q Nothing (_, l6)) = + lookupAAAA r dom >>= doit6 q l6 +toSpfSeq r _ (IPv4 _) (SPF_Address q (Just dom) (l4, _)) = + lookupA r dom >>= doit4 q l4 +toSpfSeq r _ (IPv6 _) (SPF_Address q (Just dom) (_, l6)) = + lookupAAAA r dom >>= doit6 q l6 doit4 :: Qualifier -> Int -> Either DNSError [IPv4] -> IO SpfSeq -doit4 _ _ (Left _) = fail "TempError" +doit4 _ _ (Left _) = fail "TempError" doit4 q l4 (Right is) = return $ SS_IPv4Ranges q $ map (mkr l4) is where mkr = flip makeAddrRange doit6 :: Qualifier -> Int -> Either DNSError [IPv6] -> IO SpfSeq -doit6 _ _ (Left _) = fail "TempError" +doit6 _ _ (Left _) = fail "TempError" doit6 q l6 (Right is) = return $ SS_IPv6Ranges q $ map (mkr l6) is where mkr = flip makeAddrRange @@ -89,5 +88,5 @@ ---------------------------------------------------------------- checkDNS :: Either DNSError a -> String -> IO () -checkDNS (Right _) _ = return () -checkDNS (Left _) estr = fail estr +checkDNS (Right _) _ = return () +checkDNS (Left _) estr = fail estr 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 @@ -2,35 +2,37 @@ module Network.DomainAuth.SPF.Types where +import Data.ByteString (ByteString) import Data.IP import Network.DNS (Domain) -import Data.ByteString (ByteString) ---------------------------------------------------------------- -- See DAResult in Network.DomainAuth.Types data Qualifier = Q_Pass | Q_HardFail | Q_Softfail | Q_Neutral - deriving (Eq,Enum,Bounded,Show) + deriving (Eq, Enum, Bounded, Show) -- Depends on Qualifier qualifierSymbol :: ByteString qualifierSymbol = "+-~?" -data SPF = SPF_IPv4Range Qualifier (AddrRange IPv4) - | SPF_IPv6Range Qualifier (AddrRange IPv6) - | SPF_Address Qualifier (Maybe Domain) (Int,Int) - | SPF_MX Qualifier (Maybe Domain) (Int,Int) - | SPF_Include Qualifier Domain - | SPF_All Qualifier - | SPF_Redirect Domain - deriving Show +data SPF + = SPF_IPv4Range Qualifier (AddrRange IPv4) + | SPF_IPv6Range Qualifier (AddrRange IPv6) + | SPF_Address Qualifier (Maybe Domain) (Int, Int) + | SPF_MX Qualifier (Maybe Domain) (Int, Int) + | SPF_Include Qualifier Domain + | SPF_All Qualifier + | SPF_Redirect Domain + deriving (Show) ---------------------------------------------------------------- -data SpfSeq = SS_All Qualifier - | SS_IPv4Range Qualifier (AddrRange IPv4) - | SS_IPv6Range Qualifier (AddrRange IPv6) - | SS_IPv4Ranges Qualifier [AddrRange IPv4] - | SS_IPv6Ranges Qualifier [AddrRange IPv6] - | SS_IF_Pass Qualifier [IO SpfSeq] - | SS_SpfSeq [IO SpfSeq] +data SpfSeq + = SS_All Qualifier + | SS_IPv4Range Qualifier (AddrRange IPv4) + | SS_IPv6Range Qualifier (AddrRange IPv6) + | SS_IPv4Ranges Qualifier [AddrRange IPv4] + | SS_IPv6Ranges Qualifier [AddrRange IPv6] + | SS_IF_Pass Qualifier [IO SpfSeq] + | SS_SpfSeq [IO SpfSeq] diff --git a/Network/DomainAuth/Types.hs b/Network/DomainAuth/Types.hs --- a/Network/DomainAuth/Types.hs +++ b/Network/DomainAuth/Types.hs @@ -1,5 +1,4 @@ -- | Type for Message Authentication Status (). - module Network.DomainAuth.Types where ---------------------------------------------------------------- @@ -8,30 +7,31 @@ -- | The result of domain authentication. For more information, see -- . -data DAResult = DAPass - | DAHardFail - | DASoftFail - | DANeutral - | DAFail - | DATempError - | DAPermError - | DANone - | DAPolicy - | DANxDomain - | DADiscard - | DAUnknown - deriving (Eq,Enum,Bounded) +data DAResult + = DAPass + | DAHardFail + | DASoftFail + | DANeutral + | DAFail + | DATempError + | DAPermError + | DANone + | DAPolicy + | DANxDomain + | DADiscard + | DAUnknown + deriving (Eq, Enum, Bounded) instance Show DAResult where - show DAPass = "pass" - show DAHardFail = "hardfail" - show DASoftFail = "softfail" - show DANeutral = "neutral" - show DAFail = "fail" - show DATempError = "temperror" - show DAPermError = "permerror" - show DANone = "none" - show DAPolicy = "policy" - show DANxDomain = "nxdomain" - show DADiscard = "discard" - show DAUnknown = "unknown" + show DAPass = "pass" + show DAHardFail = "hardfail" + show DASoftFail = "softfail" + show DANeutral = "neutral" + show DAFail = "fail" + show DATempError = "temperror" + show DAPermError = "permerror" + show DANone = "none" + show DAPolicy = "policy" + show DANxDomain = "nxdomain" + show DADiscard = "discard" + show DAUnknown = "unknown" diff --git a/Network/DomainAuth/Utils.hs b/Network/DomainAuth/Utils.hs --- a/Network/DomainAuth/Utils.hs +++ b/Network/DomainAuth/Utils.hs @@ -43,27 +43,27 @@ reduceWSP :: Cook reduceWSP "" = "" reduceWSP bs - | isSpace (BS.head bs) = inSP bs - | otherwise = outSP bs + | isSpace (BS.head bs) = inSP bs + | otherwise = outSP bs inSP :: Cook inSP "" = "" inSP bs = " " +++ outSP bs' where - (_,bs') = BS.span isSpace bs + (_, bs') = BS.span isSpace bs outSP :: Cook outSP "" = "" outSP bs = nonSP +++ inSP bs' where - (nonSP,bs') = BS.break isSpace bs + (nonSP, bs') = BS.break isSpace bs ---------------------------------------------------------------- type FWSRemover = ByteString -> ByteString removeFWS :: FWSRemover -removeFWS = BS.filter (not.isSpace) +removeFWS = BS.filter (not . isSpace) ---------------------------------------------------------------- @@ -71,14 +71,14 @@ removeTrailingWSP :: Cook removeTrailingWSP bs - | slowPath = BS.reverse . BS.dropWhile isSpace . BS.reverse $ bs -- xxx - | otherwise = bs + | slowPath = BS.reverse . BS.dropWhile isSpace . BS.reverse $ bs -- xxx + | otherwise = bs where slowPath = hasTrailingWSP bs hasTrailingWSP :: ByteString -> Bool hasTrailingWSP bs - | len == 0 = False + | len == 0 = False | otherwise = isSpace lastChar where len = BS.length bs @@ -89,8 +89,8 @@ chop :: ByteString -> ByteString chop "" = "" chop bs - | BS.last bs == 13 = BS.init bs -- 13 == '\r' - | otherwise = bs + | BS.last bs == 13 = BS.init bs -- 13 == '\r' + | otherwise = bs -- | -- @@ -103,13 +103,14 @@ ---------------------------------------------------------------- -break' :: Word8 -> ByteString -> (ByteString,ByteString) -break' c bs = (f,s) +break' :: Word8 -> ByteString -> (ByteString, ByteString) +break' c bs = (f, s) where - (f,s') = BS.break (==c) bs - s = if s' == "" - then "" - else BS.tail s' + (f, s') = BS.break (== c) bs + s = + if s' == "" + then "" + else BS.tail s' ---------------------------------------------------------------- @@ -118,22 +119,22 @@ isDigit c = 48 <= c && c <= 57 isUpper c = 65 <= c && c <= 90 isLower c = 97 <= c && c <= 122 -isSpace c = c `elem` [cSP,cTB,cLF,cCR] +isSpace c = c `elem` [cSP, cTB, cLF, cCR] cCR, cLF, cSP, cTB :: Word8 cCR = 13 cLF = 10 cSP = 32 -cTB = 9 +cTB = 9 -cPlus,cSlash,cEqual,cSmallA,cA,cZero :: Word8 -cPlus = 43 +cPlus, cSlash, cEqual, cSmallA, cA, cZero :: Word8 +cPlus = 43 cSlash = 47 cEqual = 61 cSmallA = 97 cA = 65 cZero = 48 -cColon,cSemiColon :: Word8 +cColon, cSemiColon :: Word8 cColon = 58 cSemiColon = 59 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/domain-auth.cabal b/domain-auth.cabal --- a/domain-auth.cabal +++ b/domain-auth.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: domain-auth -version: 0.2.3 +version: 0.2.4 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto @@ -60,20 +60,10 @@ bytestring, containers, crypton, + crypton-x509, dns >=1.0, iproute, memory, network, - crypton-x509, + pretty-simple, word8 - -test-suite doctest - type: exitcode-stdio-1.0 - main-is: doctests.hs - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - base >=4 && <5, - doctest >=0.9.3, - pretty-simple diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Main where - -import Test.DocTest - -main :: IO () -main = do - doctest [ - "-XOverloadedStrings" - , "Network/DomainAuth" - ]