domain-auth 0.2.3 → 0.2.4
raw patch · 31 files changed
+743/−685 lines, 31 filesdep −doctestsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies removed: doctest
API changes (from Hackage documentation)
Files
- Network/DomainAuth.hs +8/−9
- Network/DomainAuth/DK.hs +18/−13
- Network/DomainAuth/DK/Parser.hs +54/−52
- Network/DomainAuth/DK/Types.hs +14/−12
- Network/DomainAuth/DK/Verify.hs +12/−9
- Network/DomainAuth/DKIM.hs +28/−21
- Network/DomainAuth/DKIM/Btag.hs +4/−5
- Network/DomainAuth/DKIM/Parser.hs +106/−98
- Network/DomainAuth/DKIM/Types.hs +15/−14
- Network/DomainAuth/DKIM/Verify.hs +19/−13
- Network/DomainAuth/Mail.hs +48/−32
- Network/DomainAuth/Mail/Mail.hs +28/−28
- Network/DomainAuth/Mail/Parser.hs +42/−36
- Network/DomainAuth/Mail/Types.hs +19/−9
- Network/DomainAuth/Mail/XMail.hs +24/−20
- Network/DomainAuth/PRD.hs +4/−6
- Network/DomainAuth/PRD/Domain.hs +10/−11
- Network/DomainAuth/PRD/Lexer.hs +5/−5
- Network/DomainAuth/PRD/PRD.hs +51/−48
- Network/DomainAuth/Pubkey/Base64.hs +17/−17
- Network/DomainAuth/Pubkey/RSAPub.hs +17/−16
- Network/DomainAuth/SPF.hs +7/−9
- Network/DomainAuth/SPF/Eval.hs +58/−56
- Network/DomainAuth/SPF/Parser.hs +32/−26
- Network/DomainAuth/SPF/Resolver.hs +32/−33
- Network/DomainAuth/SPF/Types.hs +19/−17
- Network/DomainAuth/Types.hs +26/−26
- Network/DomainAuth/Utils.hs +22/−21
- Setup.hs +1/−0
- domain-auth.cabal +3/−13
- test/doctests.hs +0/−10
Network/DomainAuth.hs view
@@ -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
Network/DomainAuth/DK.hs view
@@ -2,18 +2,24 @@ -- | A library for DomainKeys (<http://www.ietf.org/rfc/rfc4870.txt>). -- 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.
Network/DomainAuth/DK/Parser.hs view
@@ -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}
Network/DomainAuth/DK/Types.hs view
@@ -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
Network/DomainAuth/DK/Verify.hs view
@@ -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 ----------------------------------------------------------------
Network/DomainAuth/DKIM.hs view
@@ -2,18 +2,23 @@ -- | A library for DKIM (<http://www.ietf.org/rfc/rfc6376.txt>). -- 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: <CAKipW39HW14nu7NN6xsdnNtu_PakrgeOAXo6agtkm=ScFmXqJQ@mail.gmail.com>"--- ,"Date: Thu, 17 Aug 2023 11:33:46 +0900"+-- ,"Message-ID: <CAKipW39hxTzXh28waC4fuu=qVFfy9EF=H8zH_k8wgM9RBR6_dg@mail.gmail.com>"+-- ,"Date: Thu, 4 Apr 2024 10:53:59 +0900" -- ,"From: Kazu Yamamoto <kazu.yamamoto@gmail.com>" -- ,"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.
Network/DomainAuth/DKIM/Btag.hs view
@@ -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)-
Network/DomainAuth/DKIM/Parser.hs view
@@ -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}
Network/DomainAuth/DKIM/Types.hs view
@@ -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
Network/DomainAuth/DKIM/Verify.hs view
@@ -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)-
Network/DomainAuth/Mail.hs view
@@ -1,37 +1,53 @@ -- | A library to parse e-mail messages both from a file and Milter(<https://www.milter.org/>).- 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
Network/DomainAuth/Mail/Mail.hs view
@@ -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
Network/DomainAuth/Mail/Parser.hs view
@@ -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
Network/DomainAuth/Mail/Types.hs view
@@ -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
Network/DomainAuth/Mail/XMail.hs view
@@ -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+ }
Network/DomainAuth/PRD.hs view
@@ -1,10 +1,8 @@ -- | Utilities to decide Purported Responsible Domain (<http://www.ietf.org/rfc/rfc4407.txt>).- 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
Network/DomainAuth/PRD/Domain.hs view
@@ -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 <example.com>" -- 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
Network/DomainAuth/PRD/Lexer.hs view
@@ -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^-~" ----------------------------------------------------------------
Network/DomainAuth/PRD/PRD.hs view
@@ -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
Network/DomainAuth/Pubkey/Base64.hs view
@@ -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]]
Network/DomainAuth/Pubkey/RSAPub.hs view
@@ -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)"
Network/DomainAuth/SPF.hs view
@@ -1,11 +1,10 @@ -- | A library for SPF(<http://www.ietf.org/rfc/rfc4408.txt>) -- and Sender-ID(<http://www.ietf.org/rfc/rfc4406.txt>).- module Network.DomainAuth.SPF (- runSPF- , Limit(..)- , 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
Network/DomainAuth/SPF/Eval.hs view
@@ -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
Network/DomainAuth/SPF/Parser.hs view
@@ -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
Network/DomainAuth/SPF/Resolver.hs view
@@ -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
Network/DomainAuth/SPF/Types.hs view
@@ -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]
Network/DomainAuth/Types.hs view
@@ -1,5 +1,4 @@ -- | Type for Message Authentication Status (<http://www.ietf.org/rfc/rfc5451.txt>).- module Network.DomainAuth.Types where ----------------------------------------------------------------@@ -8,30 +7,31 @@ -- | The result of domain authentication. For more information, see -- <http://www.ietf.org/rfc/rfc5451.txt>.-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"
Network/DomainAuth/Utils.hs view
@@ -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
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
domain-auth.cabal view
@@ -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 <kazu@iij.ad.jp>@@ -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
− test/doctests.hs
@@ -1,10 +0,0 @@-module Main where--import Test.DocTest--main :: IO ()-main = do- doctest [- "-XOverloadedStrings"- , "Network/DomainAuth"- ]