domain-auth 0.2.4 → 0.2.5
raw patch · 14 files changed
+537/−175 lines, 14 filesdep +crypton-asn1-encodingdep +crypton-asn1-typesdep +hspecdep −asn1-encodingdep −asn1-typesdep −memorydep ~crypton-x509dep ~dnsPVP ok
version bump matches the API change (PVP)
Dependencies added: crypton-asn1-encoding, crypton-asn1-types, hspec
Dependencies removed: asn1-encoding, asn1-types, memory
Dependency ranges changed: crypton-x509, dns
API changes (from Hackage documentation)
Files
- ChangeLog.md +15/−0
- Network/DomainAuth/DK/Parser.hs +15/−12
- Network/DomainAuth/DK/Verify.hs +3/−2
- Network/DomainAuth/DKIM/Parser.hs +15/−3
- Network/DomainAuth/DKIM/Verify.hs +28/−20
- Network/DomainAuth/Mail/Mail.hs +6/−4
- Network/DomainAuth/Pubkey/Base64.hs +28/−33
- Network/DomainAuth/Pubkey/RSAPub.hs +9/−8
- Network/DomainAuth/SPF.hs +2/−11
- Network/DomainAuth/SPF/Eval.hs +34/−27
- Network/DomainAuth/SPF/Parser.hs +8/−4
- Network/DomainAuth/SPF/Resolver.hs +110/−46
- domain-auth.cabal +47/−5
- test/Spec.hs +217/−0
+ ChangeLog.md view
@@ -0,0 +1,15 @@+# ChangeLog for domain-auth++## 0.2.5++* Supporting crypton >= 1.1 and crypton-x509 >= 1.8.+* DKIM/DomainKeys: malformed signatures and public keys (unknown+ algorithms or canonicalizations, duplicated tags, bad base64) no+ longer throw exceptions; they are treated as permerror or fail.+* DKIM: signed header fields are selected bottom-up from the entire+ header (RFC 6376 Section 5.4.2). `fieldsWith` now selects the last+ instance first. This fixes an oversigning bypass by adding a field+ above DKIM-Signature.+* SPF: "a", "mx", "include" and "redirect" are counted against `limit`.+ More than 10 MX records or more than 2 void lookups are permerror+ (RFC 7208 Section 4.6.4). Out-of-range CIDR lengths are rejected.
Network/DomainAuth/DK/Parser.hs view
@@ -9,6 +9,7 @@ import Data.List import qualified Data.Map as M import Data.Maybe+import qualified Data.Set as Set import Network.DomainAuth.DK.Types import Network.DomainAuth.Mail @@ -38,11 +39,13 @@ -- } -- ) parseDK :: RawFieldValue -> Maybe DK-parseDK val = toDK domkey+parseDK val+ | Set.size (Set.fromList ts) /= length ts = Nothing -- duplicated tags+ | otherwise = toDK domkey where (ts, vs) = unzip $ parseTaggedValue val fs = map tagToSetter ts- tagToSetter tag = fromMaybe (\_ mdk -> mdk) $ lookup (BS.head tag) dkTagDB+ tagToSetter tag = fromMaybe (\_ mdk -> mdk) $ lookup (BS.unpack tag) dkTagDB pfs = zipWith ($) fs vs domkey = foldr ($) initialMDK pfs toDK mdk = do@@ -84,20 +87,20 @@ type DKSetter = ByteString -> MDK -> MDK -dkTagDB :: [(Char, DKSetter)]+dkTagDB :: [(String, DKSetter)] dkTagDB =- [ ('a', setDkAlgorithm)- , ('b', setDkSignature)- , ('c', setDkCanonAlgo)- , ('d', setDkDomain)- , ('h', setDkFields)- , -- , ('q',setDkQuery)- ('s', setDkSelector)+ [ ("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 _ dk = dk{mdkAlgorithm = Nothing} setDkSignature :: DKSetter setDkSignature sig dk = dk{mdkSignature = Just sig}@@ -105,7 +108,7 @@ setDkCanonAlgo :: DKSetter setDkCanonAlgo "simple" dk = dk{mdkCanonAlgo = Just DK_SIMPLE} setDkCanonAlgo "nofws" dk = dk{mdkCanonAlgo = Just DK_NOFWS}-setDkCanonAlgo _ _ = error "setDkCanonAlgo"+setDkCanonAlgo _ dk = dk{mdkCanonAlgo = Nothing} setDkDomain :: DKSetter setDkDomain dom dk = dk{mdkDomain = Just dom}
Network/DomainAuth/DK/Verify.hs view
@@ -60,7 +60,8 @@ ---------------------------------------------------------------- verifyDK :: Mail -> DK -> PublicKey -> Bool-verifyDK mail dk pub = verify (Just SHA1) pub cmail sig+verifyDK mail dk pub = case B.decode (dkSignature dk) of+ Nothing -> False+ Just sig -> verify (Just SHA1) pub cmail sig where- sig = B.decode . dkSignature $ dk cmail = BL.toStrict $ BB.toLazyByteString $ prepareDK dk mail
Network/DomainAuth/DKIM/Parser.hs view
@@ -7,6 +7,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Maybe+import qualified Data.Set as Set import Network.DomainAuth.DKIM.Types import Network.DomainAuth.Mail @@ -86,7 +87,9 @@ -- } -- ) parseDKIM :: RawFieldValue -> Maybe DKIM-parseDKIM val = toDKIM domkey+parseDKIM val+ | Set.size (Set.fromList ts) /= length ts = Nothing -- duplicated tags+ | otherwise = toDKIM domkey where (ts, vs) = unzip $ parseTaggedValue val fs = map tagToSetter ts@@ -167,7 +170,7 @@ setDkimSigAlgo :: DKIMSetter setDkimSigAlgo "rsa-sha1" dkim = dkim{mdkimSigAlgo = Just RSA_SHA1} setDkimSigAlgo "rsa-sha256" dkim = dkim{mdkimSigAlgo = Just RSA_SHA256}-setDkimSigAlgo _ _ = error "setDkimSigAlgo"+setDkimSigAlgo _ dkim = dkim{mdkimSigAlgo = Nothing} setDkimSignature :: DKIMSetter setDkimSignature sig dkim = dkim{mdkimSignature = Just sig}@@ -176,6 +179,11 @@ setDkimBodyHash bh dkim = dkim{mdkimBodyHash = Just bh} setDkimCanonAlgo :: DKIMSetter+setDkimCanonAlgo "simple" dkim =+ dkim+ { mdkimHeaderCanon = Just DKIM_SIMPLE+ , mdkimBodyCanon = Just DKIM_SIMPLE+ } setDkimCanonAlgo "relaxed" dkim = dkim { mdkimHeaderCanon = Just DKIM_RELAXED@@ -201,7 +209,11 @@ { mdkimHeaderCanon = Just DKIM_SIMPLE , mdkimBodyCanon = Just DKIM_SIMPLE }-setDkimCanonAlgo _ _ = error "setDkimCanonAlgo"+setDkimCanonAlgo _ dkim =+ dkim+ { mdkimHeaderCanon = Nothing+ , mdkimBodyCanon = Nothing+ } setDkimDomain :: DKIMSetter setDkimDomain dom dkim = dkim{mdkimDomain = Just dom}
Network/DomainAuth/DKIM/Verify.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Network.DomainAuth.DKIM.Verify ( verifyDKIM,@@ -9,13 +8,13 @@ import Crypto.Hash import Crypto.PubKey.RSA import Crypto.PubKey.RSA.PKCS15-import Data.ByteArray import Data.ByteString (ByteString) 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+import Network.DomainAuth.DKIM.Parser import Network.DomainAuth.DKIM.Types import Network.DomainAuth.Mail import qualified Network.DomainAuth.Pubkey.Base64 as B@@ -23,14 +22,20 @@ ---------------------------------------------------------------- -prepareDKIM :: DKIM -> Mail -> Builder-prepareDKIM dkim mail = header+-- | Fields are selected from the entire header except the signature+-- being verified, bottom-up (RFC 6376 Section 5.4.2).+prepareDKIM :: DKIM -> Mail -> Maybe Builder+prepareDKIM dkim mail = case break isTheSig (mailHeader mail) of+ (_, []) -> Nothing+ (pre, dkimField : post) ->+ let targets = fieldsWith (dkimFields dkim) (pre ++ post)+ in Just $ concatCRLFWith hCanon targets +++ canon dkimField where- dkimField : fields = fieldsFrom dkimFieldKey (mailHeader mail)+ isTheSig fld =+ fieldSearchKey fld == dkimFieldKey+ && parseDKIM (fieldValueUnfolded fld) == Just dkim hCanon = canonDkimField (dkimHeaderCanon dkim) canon = BB.byteString . removeBtagValue . hCanon- targets = fieldsWith (dkimFields dkim) fields- header = concatCRLFWith hCanon targets +++ canon dkimField ---------------------------------------------------------------- @@ -51,24 +56,27 @@ ---------------------------------------------------------------- verifyDKIM :: Mail -> DKIM -> PublicKey -> Bool-verifyDKIM mail dkim pub =- bodyHash1 mail == bodyHash2 dkim- && verify' (dkimSigAlgo dkim) pub cmail sig+verifyDKIM mail dkim pub = case (mbh, msig, mhdr) of+ (Just bh, Just sig, Just hdr) ->+ matchHash alg bh body && verify' alg pub (toBS hdr) sig+ _ -> False where- sig = B.decode . dkimSignature $ dkim- cmail = BL.toStrict $ BB.toLazyByteString $ prepareDKIM dkim mail- bodyHash1 =- hashAlgo2 (dkimSigAlgo dkim)- . BL.toStrict+ alg = dkimSigAlgo dkim+ mbh = B.decode $ dkimBodyHash dkim+ msig = B.decode $ dkimSignature dkim+ mhdr = prepareDKIM dkim mail+ toBS = BL.toStrict . BB.toLazyByteString+ body =+ BL.toStrict . BB.toLazyByteString . canonDkimBody (dkimBodyCanon dkim)- . mailBody- bodyHash2 = B.decode . dkimBodyHash+ $ mailBody mail 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_SHA256 = convert . (hash :: ByteString -> Digest SHA256)+-- | Checking if the body hash matches the decoded "bh" value.+matchHash :: DkimSigAlgo -> ByteString -> ByteString -> Bool+matchHash RSA_SHA1 bh txt = digestFromByteString bh == Just (hashWith SHA1 txt)+matchHash RSA_SHA256 bh txt = digestFromByteString bh == Just (hashWith SHA256 txt)
Network/DomainAuth/Mail/Mail.hs view
@@ -50,14 +50,16 @@ safeTail [] = [] safeTail xs = tail xs --- RFC 4871 is ambiguous, so implement only normal case.---- | Obtaining all fields with DKIM algorithm.+-- | Obtaining all fields with DKIM algorithm (RFC 6376 Section 5.4.2).+-- Each key selects the last unused instance (bottom-up).+-- Keys of nonexistent instances are ignored. --+-- >>> fieldsWith ["from","from","subject"] [Field "from" "From" ["1"],Field "subject" "Subject" ["2"],Field "from" "From" ["3"]]+-- [Field {fieldSearchKey = "from", fieldKey = "From", fieldValue = ["3"]},Field {fieldSearchKey = "from", fieldKey = "From", fieldValue = ["1"]},Field {fieldSearchKey = "subject", fieldKey = "Subject", fieldValue = ["2"]}] -- >>> fieldsWith ["from","to","subject","date","message-id"] [Field "from" "From" ["foo"],Field "to" "To" ["bar"],Field "subject" "Subject" ["baz"],Field "date" "Date" ["qux"],Field "message-id" "Message-Id" ["quux"], Field "received" "Received" ["fiz"], Field "filtered-out" "Filtered-Out" ["buzz"], Field "not-needed" "Not-Needed" ["fizz"]] -- [Field {fieldSearchKey = "from", fieldKey = "From", fieldValue = ["foo"]},Field {fieldSearchKey = "to", fieldKey = "To", fieldValue = ["bar"]},Field {fieldSearchKey = "subject", fieldKey = "Subject", fieldValue = ["baz"]},Field {fieldSearchKey = "date", fieldKey = "Date", fieldValue = ["qux"]},Field {fieldSearchKey = "message-id", fieldKey = "Message-Id", fieldValue = ["quux"]}] fieldsWith :: [CanonFieldKey] -> Header -> Header-fieldsWith kx hx = catMaybes $ enm kx hx (\k h -> k == fieldSearchKey h)+fieldsWith kx hx = catMaybes $ enm kx (reverse hx) (\k h -> k == fieldSearchKey h) -- | RFC 6376 says: -- Signers MAY claim to have signed header fields that do not exist
Network/DomainAuth/Pubkey/Base64.hs view
@@ -2,7 +2,6 @@ module Network.DomainAuth.Pubkey.Base64 ( decode,- decode', ) where import Data.Bits (shiftL, shiftR, (.&.), (.|.))@@ -14,30 +13,33 @@ import Data.Word import Network.DomainAuth.Utils -isBase64 :: Word8 -> Bool-isBase64 c = isAlphaNum c || (c `elem` [cPlus, cSlash, cEqual])--decode :: ByteString -> ByteString-decode = BL.toStrict . decode'--decode' :: ByteString -> BL.ByteString-decode' = BB.toLazyByteString . dec . BS.filter isBase64+-- | Decoding base64 with folding white spaces.+-- 'Nothing' is returned for malformed input.+--+-- >>> decode "aGVs bG8="+-- Just "hello"+-- >>> decode "aGVsbG8"+-- Nothing+-- >>> decode "aGV*bG8="+-- Nothing+-- >>> decode "=AAA"+-- Nothing+decode :: ByteString -> Maybe ByteString+decode bs = BL.toStrict . BB.toLazyByteString <$> dec (BS.filter (not . isSpace) bs) -dec :: ByteString -> Builder+dec :: ByteString -> Maybe Builder dec bs- | 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"+ | BS.null bs = Just empty+ | len < 4 = Nothing+ | len == 4 && c3 == cEqual && c4 == cEqual = dec1' <$> x1 <*> x2+ | len == 4 && c4 == cEqual = dec2' <$> x1 <*> x2 <*> x3+ | otherwise = (+++) <$> (dec' <$> x1 <*> x2 <*> x3 <*> x4) <*> dec bs' where len = BS.length bs- c1 = bs !!! 0- c2 = bs !!! 1 c3 = bs !!! 2 c4 = bs !!! 3- x1 = fromChar c1- x2 = fromChar c2+ x1 = fromChar (bs !!! 0)+ x2 = fromChar (bs !!! 1) x3 = fromChar c3 x4 = fromChar c4 bs' = BS.drop 4 bs@@ -60,18 +62,11 @@ d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4) d2 = ((x2 `shiftL` 4) .&. 0xF0) .|. (x3 `shiftR` 2) -fromChar :: Word8 -> Word8+fromChar :: Word8 -> Maybe 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)--{--splits :: Int -> [a] -> [[a]]-splits _ [] = []-splits n xs = case splitAt n xs of- (ys, zs) -> ys:splits n zs--}+ | isUpper c = Just (c - cA)+ | isLower c = Just (c - cSmallA + 26)+ | isDigit c = Just (c - cZero + 52)+ | c == cPlus = Just 62+ | c == cSlash = Just 63+ | otherwise = Nothing
Network/DomainAuth/Pubkey/RSAPub.hs view
@@ -2,10 +2,11 @@ module Network.DomainAuth.Pubkey.RSAPub ( lookupPublicKey,+ decodeRSAPublicyKey, ) where import Crypto.PubKey.RSA (PublicKey)-import Data.ASN1.BinaryEncoding (DER)+import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1') import Data.ASN1.Types (fromASN1) import Data.ByteString (ByteString)@@ -46,10 +47,10 @@ (x : _) -> lookup "p" (parseTaggedValue x) 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+decodeRSAPublicyKey b64 = do+ der <- B.decode b64+ case decodeASN1' DER der of+ Left _ -> Nothing+ Right ans1 -> case fromASN1 ans1 of+ Right (PubKeyRSA p, []) -> Just p+ _ -> Nothing
Network/DomainAuth/SPF.hs view
@@ -6,13 +6,11 @@ defaultLimit, ) where -import Control.Exception as E import Data.IP import Network.DNS (Domain, Resolver) import Network.DomainAuth.SPF.Eval import Network.DomainAuth.SPF.Resolver import Network.DomainAuth.Types-import System.IO.Error -- $setup -- >>> import Network.DNS@@ -21,7 +19,7 @@ -- If 'Domain' is specified from SMTP MAIL FROM, authentication is -- based on SPF. If 'Domain' is specified from the From field of mail -- header, authentication is based on SenderID. If condition reaches--- 'Limit', 'SpfPermError' is returned.+-- 'Limit', 'DAPermError' is returned. -- -- >>> rs <- makeResolvSeed defaultResolvConf --@@ -50,11 +48,4 @@ -- >>> 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+runSPF lim resolver = runSPFWith lim (dnsLookup resolver)
Network/DomainAuth/SPF/Eval.hs view
@@ -1,20 +1,24 @@ module Network.DomainAuth.SPF.Eval (+ runSPFWith, evalSPF, Limit (..), defaultLimit, ) where -import Data.IORef+import Control.Exception as E import Data.IP import Data.Maybe+import Network.DNS (Domain)+import Network.DomainAuth.SPF.Resolver import Network.DomainAuth.SPF.Types import Network.DomainAuth.Types+import System.IO.Error -- | Limit for SPF authentication. data Limit = Limit { limit :: Int- -- ^ How many \"redirect\"/\"include\" should be followed.- -- 'DAPermError' is returned if reached to this limit.+ -- ^ How many DNS-querying terms (\"a\", \"mx\", \"include\" and+ -- \"redirect\") are allowed. 'DAPermError' is returned if exceeded. , ipv4_masklen :: Int -- ^ Ignoring IPv4 range whose mask length is shorter than this. , ipv6_masklen :: Int@@ -39,32 +43,38 @@ ---------------------------------------------------------------- +-- | Running SPF with the given lookup functions.+runSPFWith :: Limit -> SpfLookup -> Domain -> IP -> IO DAResult+runSPFWith lim lk dom ip = do+ ctx <- newSpfCtx lk (limit lim)+ (resolveSPF ctx False 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++----------------------------------------------------------------++-- | DNS lookup limits are enforced in "Network.DomainAuth.SPF.Resolver". evalSPF :: Limit -> IP -> [IO SpfSeq] -> IO DAResult-evalSPF lim ip ss = do- ref <- newIORef (0 :: Int)- fromJust <$> evalspf ref lim ip ss+evalSPF lim ip ss = fromJust <$> evalspf lim ip ss ---------------------------------------------------------------- -evalspf :: IORef Int -> Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)-evalspf _ _ _ [] = return (Just DANeutral) -- default result-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+evalspf :: Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)+evalspf _ _ [] = return (Just DANeutral) -- default result+evalspf lim ip (s : ss) = do+ mres <- eval lim ip s+ case mres of+ Nothing -> evalspf lim ip ss+ res -> return res ------------------------------------------------------------------- Follow N of redirect/include. But the last one is not--- evaluated. -eval :: IORef Int -> Limit -> IP -> IO SpfSeq -> IO (Maybe DAResult)-eval ref lim ip is = do- cnt <- readIORef ref+eval :: Limit -> IP -> IO SpfSeq -> IO (Maybe DAResult)+eval lim ip is = do s <- is case s of SS_All q ->@@ -88,14 +98,11 @@ | 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+ r <- evalspf 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_SpfSeq ss -> evalspf lim ip ss where ret = return . Just . toEnum . fromEnum result = return . Just
Network/DomainAuth/SPF/Parser.hs view
@@ -108,8 +108,12 @@ optionalDomain :: Parser (Maybe Domain) optionalDomain = P.option Nothing (Just <$> (P.word8 _colon *> domain)) -mask :: Parser Int-mask = read . BS8.unpack <$> P.takeWhile1 (P.inClass "0-9")+mask :: Int -> Parser Int+mask maxlen = do+ ds <- P.takeWhile1 (P.inClass "0-9")+ case readMaybe (BS8.unpack ds) of+ Just n | BS.length ds <= 3 && n <= maxlen -> return n+ _ -> fail "mask" optionalMask :: Parser (Int, Int) optionalMask = P.try both <|> P.try v4 <|> P.try v6 <|> none@@ -120,7 +124,7 @@ none = return (32, 128) ipv4Mask :: Parser Int-ipv4Mask = P.word8 _slash *> mask+ipv4Mask = P.word8 _slash *> mask 32 ipv6Mask :: Parser Int-ipv6Mask = P.string "//" *> mask+ipv6Mask = P.string "//" *> mask 128
Network/DomainAuth/SPF/Resolver.hs view
@@ -2,10 +2,16 @@ module Network.DomainAuth.SPF.Resolver ( resolveSPF,+ SpfLookup (..),+ dnsLookup,+ SpfCtx,+ newSpfCtx, ) where import Control.Monad+import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS+import Data.IORef import Data.IP import Data.Maybe import Network.DNS@@ -14,23 +20,77 @@ ---------------------------------------------------------------- -resolveSPF :: Resolver -> Domain -> IP -> IO [IO SpfSeq]-resolveSPF resolver dom ip = do- jrc <- lookupTXT resolver dom- checkDNS jrc "TempError"- let rr = getSPFRR jrc- checkExistence rr "None"+-- | DNS lookup functions used by SPF.+data SpfLookup = SpfLookup+ { spfLookupTXT :: Domain -> IO (Either DNSError [ByteString])+ , spfLookupA :: Domain -> IO (Either DNSError [IPv4])+ , spfLookupAAAA :: Domain -> IO (Either DNSError [IPv6])+ , spfLookupMX :: Domain -> IO (Either DNSError [(Domain, Int)])+ }++dnsLookup :: Resolver -> SpfLookup+dnsLookup r =+ SpfLookup+ { spfLookupTXT = lookupTXT r+ , spfLookupA = lookupA r+ , spfLookupAAAA = lookupAAAA r+ , spfLookupMX = lookupMX r+ }++-- | Shared state for one SPF evaluation.+data SpfCtx = SpfCtx+ { ctxLookup :: SpfLookup+ , ctxLimit :: Int+ , ctxCount :: IORef Int+ , ctxVoid :: IORef Int+ }++newSpfCtx :: SpfLookup -> Int -> IO SpfCtx+newSpfCtx lk lim = SpfCtx lk lim <$> newIORef 0 <*> newIORef 0++-- RFC 7208 Section 4.6.4+voidLookupLimit, mxLimit :: Int+voidLookupLimit = 2+mxLimit = 10++-- | Charging one DNS-querying term against the limit.+charge :: SpfCtx -> IO ()+charge ctx = do+ n <- atomicModifyIORef' (ctxCount ctx) $ \x -> (x + 1, x + 1)+ when (n > ctxLimit ctx) $ fail "PermError"++-- | NXDOMAIN is treated as empty. Empty answers are void lookups.+checkVoid :: SpfCtx -> Either DNSError [a] -> IO [a]+checkVoid ctx r = case r of+ Left NameError -> void' >> return []+ Left _ -> fail "TempError"+ Right [] -> void' >> return []+ Right xs -> return xs+ where+ void' = do+ n <- atomicModifyIORef' (ctxVoid ctx) $ \x -> (x + 1, x + 1)+ when (n > voidLookupLimit) $ fail "PermError"++----------------------------------------------------------------++-- | 'True' for include/redirect, where no SPF record is PermError.+resolveSPF :: SpfCtx -> Bool -> Domain -> IP -> IO [IO SpfSeq]+resolveSPF ctx nested dom ip = do+ jrc <- spfLookupTXT (ctxLookup ctx) dom+ rc <- case jrc of+ Left NameError -> return []+ Left _ -> fail "TempError"+ Right rc -> return rc+ let rr = getSPFRR rc+ checkExistence rr (if nested then "PermError" else "None") let jrs = parseSPF rr checkSyntax jrs "PermError" let is = filterSPFWithIP ip (fromJust jrs)- return $ map (toSpfSeq resolver dom ip) is+ return $ map (toSpfSeq ctx dom ip) is where- getSPFRR (Left _) = error "getSPRRR"- getSPFRR (Right rc)- | null ts = ""- | otherwise = head ts- where- ts = filter ("v=spf1" `BS.isPrefixOf`) rc+ getSPFRR rc = case filter ("v=spf1" `BS.isPrefixOf`) rc of+ [] -> ""+ t : _ -> t checkSyntax rs estr = when (isNothing rs) (fail estr) checkExistence rr estr = when (BS.null rr) (fail estr) @@ -50,43 +110,47 @@ ---------------------------------------------------------------- -toSpfSeq :: Resolver -> Domain -> IP -> SPF -> IO SpfSeq+toSpfSeq :: SpfCtx -> 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--doit4 :: Qualifier -> Int -> Either DNSError [IPv4] -> IO SpfSeq-doit4 _ _ (Left _) = fail "TempError"-doit4 q l4 (Right is) = return $ SS_IPv4Ranges q $ map (mkr l4) is+toSpfSeq ctx _ ip (SPF_Include q dom) = do+ charge ctx+ SS_IF_Pass q <$> resolveSPF ctx True dom ip+toSpfSeq ctx _ ip (SPF_Redirect dom) = do+ charge ctx+ SS_SpfSeq <$> resolveSPF ctx True dom ip+toSpfSeq ctx dom0 ip (SPF_MX q mdom (l4, l6)) = do+ charge ctx+ mxs <- spfLookupMX lk dom >>= checkVoid ctx+ when (length mxs > mxLimit) $ fail "PermError"+ let hosts = map fst mxs+ case ip of+ IPv4 _ ->+ SS_IPv4Ranges q . ranges l4 . concat <$> mapM (lookupHost (spfLookupA lk)) hosts+ IPv6 _ ->+ SS_IPv6Ranges q . ranges l6 . concat+ <$> mapM (lookupHost (spfLookupAAAA lk)) hosts where- mkr = flip makeAddrRange--doit6 :: Qualifier -> Int -> Either DNSError [IPv6] -> IO SpfSeq-doit6 _ _ (Left _) = fail "TempError"-doit6 q l6 (Right is) = return $ SS_IPv6Ranges q $ map (mkr l6) is+ lk = ctxLookup ctx+ dom = fromMaybe dom0 mdom+toSpfSeq ctx dom0 ip (SPF_Address q mdom (l4, l6)) = do+ charge ctx+ case ip of+ IPv4 _ -> SS_IPv4Ranges q . ranges l4 <$> (spfLookupA lk dom >>= checkVoid ctx)+ IPv6 _ -> SS_IPv6Ranges q . ranges l6 <$> (spfLookupAAAA lk dom >>= checkVoid ctx) where- mkr = flip makeAddrRange+ lk = ctxLookup ctx+ dom = fromMaybe dom0 mdom -----------------------------------------------------------------+ranges :: Addr a => Int -> [a] -> [AddrRange a]+ranges len = map (`makeAddrRange` len) -checkDNS :: Either DNSError a -> String -> IO ()-checkDNS (Right _) _ = return ()-checkDNS (Left _) estr = fail estr+-- | Lookups for MX hosts are not counted as void lookups.+lookupHost :: (Domain -> IO (Either DNSError [a])) -> Domain -> IO [a]+lookupHost f d = do+ r <- f d+ case r of+ Left NameError -> return []+ Left _ -> fail "TempError"+ Right xs -> return xs
domain-auth.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: domain-auth-version: 0.2.4+version: 0.2.5 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto <kazu@iij.ad.jp>@@ -12,6 +12,7 @@ category: Network build-type: Simple+extra-source-files: ChangeLog.md source-repository head type: git@@ -55,15 +56,56 @@ build-depends: base >=4 && <5, attoparsec,- asn1-encoding,- asn1-types, bytestring, containers, crypton,- crypton-x509,+ crypton-asn1-encoding >=0.10 && <0.11,+ crypton-asn1-types >=0.4.1 && <0.5,+ crypton-x509 >=1.8, dns >=1.0, iproute,- memory, network, pretty-simple,+ word8++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test .+ other-modules:+ Network.DomainAuth.Utils+ Network.DomainAuth.Mail+ Network.DomainAuth.Mail.Mail+ Network.DomainAuth.Mail.Parser+ Network.DomainAuth.Mail.Types+ Network.DomainAuth.Mail.XMail+ Network.DomainAuth.DK.Parser+ Network.DomainAuth.DK.Types+ Network.DomainAuth.DK.Verify+ Network.DomainAuth.DKIM.Btag+ Network.DomainAuth.DKIM.Parser+ Network.DomainAuth.DKIM.Types+ Network.DomainAuth.DKIM.Verify+ Network.DomainAuth.Pubkey.Base64+ Network.DomainAuth.Pubkey.RSAPub+ Network.DomainAuth.SPF.Eval+ Network.DomainAuth.SPF.Parser+ Network.DomainAuth.SPF.Resolver+ Network.DomainAuth.SPF.Types+ Network.DomainAuth.Types++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4 && <5,+ attoparsec,+ bytestring,+ containers,+ crypton,+ crypton-asn1-encoding,+ crypton-asn1-types,+ crypton-x509,+ dns,+ hspec,+ iproute, word8
+ test/Spec.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Main where++import qualified Crypto.Hash as H+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as PK+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BL+import Data.Char (digitToInt)+import Data.IORef+import Data.IP+import Data.Maybe (isJust, isNothing)+import Data.Word (Word32, Word8)+import Network.DNS (DNSError (..), Domain)+import Test.Hspec++import Network.DomainAuth.DK.Parser+import Network.DomainAuth.DKIM.Parser+import Network.DomainAuth.DKIM.Types+import Network.DomainAuth.DKIM.Verify+import Network.DomainAuth.Mail+import qualified Network.DomainAuth.Pubkey.Base64 as B64+import Network.DomainAuth.Pubkey.RSAPub+import Network.DomainAuth.SPF.Eval+import Network.DomainAuth.SPF.Parser+import Network.DomainAuth.SPF.Resolver+import Network.DomainAuth.Types++main :: IO ()+main = do+ (pub, priv) <- RSA.generate 128 65537+ hspec $ do+ parserSpec+ dkimSpec pub priv+ spfSpec++----------------------------------------------------------------++parserSpec :: Spec+parserSpec = do+ describe "parseDKIM" $ do+ it "rejects unknown algorithms" $+ parseDKIM (sig "a=ed25519-sha256; c=relaxed") `shouldBe` Nothing+ it "rejects unknown canonicalization" $+ parseDKIM (sig "a=rsa-sha256; c=foo") `shouldBe` Nothing+ it "accepts c=simple" $+ dkimBodyCanon <$> parseDKIM (sig "a=rsa-sha256; c=simple")+ `shouldBe` Just DKIM_SIMPLE+ it "rejects duplicated tags" $+ parseDKIM (sig "a=rsa-sha256; c=relaxed; d=evil.example")+ `shouldBe` Nothing+ it "does not crash on empty tags" $+ parseDKIM ("=x;" <> sig "a=rsa-sha256") `shouldSatisfy` isJust+ describe "parseDK" $ do+ it "does not crash on empty tags" $+ parseDK "=x; a=rsa-sha1; c=simple; d=x; s=y; b=AAAA"+ `shouldSatisfy` isJust+ it "rejects unknown algorithms" $+ parseDK "a=rsa-sha256; c=simple; d=x; s=y; b=AAAA" `shouldBe` Nothing+ it "rejects unknown canonicalization" $+ parseDK "a=rsa-sha1; c=foo; d=x; s=y; b=AAAA" `shouldBe` Nothing+ describe "Base64.decode" $ do+ it "decodes with white spaces" $+ B64.decode "aGVs bG8=" `shouldBe` Just "hello"+ it "rejects bad length" $ B64.decode "abc" `shouldBe` Nothing+ it "rejects bad characters" $ B64.decode "aGV*bG8=" `shouldBe` Nothing+ it "rejects misplaced padding" $ B64.decode "=AAA" `shouldBe` Nothing+ describe "decodeRSAPublicyKey" $+ it "rejects malformed keys" $ do+ decodeRSAPublicyKey "abc" `shouldSatisfy` isNothing+ decodeRSAPublicyKey "!!!!" `shouldSatisfy` isNothing+ decodeRSAPublicyKey "AAAA" `shouldSatisfy` isNothing+ describe "parseSPF" $+ it "does not accept out-of-range masks" $ do+ show (parseSPF "v=spf1 a/99 -all") `shouldNotContain` "99"+ show (parseSPF "v=spf1 mx//999 -all") `shouldNotContain` "999"+ where+ sig x = "v=1; " <> x <> "; d=example.com; s=sel; h=from; bh=AAAA; b=AAAA"++----------------------------------------------------------------++dkimSpec :: RSA.PublicKey -> RSA.PrivateKey -> Spec+dkimSpec pub priv = describe "verifyDKIM" $ do+ it "verifies a signed mail" $+ verifyDKIM (mkMail $ hdrs sigv) dkim pub `shouldBe` True+ it "rejects a From added below the signature" $+ verifyDKIM (mkMail $ hdrs sigv ++ [evil]) dkim pub `shouldBe` False+ it "rejects a From added above the signature" $+ verifyDKIM (mkMail $ evil : hdrs sigv) dkim pub `shouldBe` False+ it "returns False if the signature field is missing" $+ verifyDKIM (mkMail $ drop 1 $ hdrs sigv) dkim pub `shouldBe` False+ it "selects fields bottom-up from the entire header" $ do+ let v = sigTmpl bhash "AAAA"+ Just d = parseDKIM v+ m = mkMail ["From: a1", "DKIM-Signature: " <> v, "From: a2", "Subject: s "]+ toStrict' <$> prepareDKIM d m+ `shouldBe` Just ("from:a2\r\nfrom:a1\r\nsubject:s\r\ndkim-signature:" <> sigTmpl bhash "")+ it "returns False for malformed b=" $ do+ let v = sigTmpl bhash "abc"+ Just d = parseDKIM v+ verifyDKIM (mkMail $ hdrs v) d pub `shouldBe` False+ it "returns False for malformed bh=" $ do+ let v = sigTmpl "=AAA" b64+ Just d = parseDKIM v+ verifyDKIM (mkMail $ hdrs v) d pub `shouldBe` False+ where+ body = "hello\r\n"+ bhash = encode64 $ fromHex $ show (H.hashWith H.SHA256 (body :: BS8.ByteString))+ evil = "From: mallory@evil.example"+ hdrs v = ["DKIM-Signature: " <> v, "From: alice@example.com", "Subject: hi"]+ mkMail hs = getMail (BS8.intercalate "\r\n" hs <> "\r\n\r\n" <> body)+ Just dkim0 = parseDKIM (sigTmpl bhash "AAAA")+ Just toSign' = prepareDKIM dkim0 (mkMail $ hdrs $ sigTmpl bhash "AAAA")+ toSign = toStrict' toSign'+ Right s = PK.sign Nothing (Just H.SHA256) priv toSign+ b64 = encode64 s+ sigv = sigTmpl bhash b64+ Just dkim = parseDKIM sigv++sigTmpl :: BS8.ByteString -> BS8.ByteString -> BS8.ByteString+sigTmpl bh b =+ "v=1; a=rsa-sha256; c=relaxed/relaxed; d=example.com; s=sel; h=from:from:subject; bh="+ <> bh+ <> "; b="+ <> b++toStrict' :: BB.Builder -> BS8.ByteString+toStrict' = BL.toStrict . BB.toLazyByteString++fromHex :: String -> BS8.ByteString+fromHex = BS.pack . go+ where+ go (a : b : xs) = fromIntegral (digitToInt a * 16 + digitToInt b) : go xs+ go _ = []++encode64 :: BS8.ByteString -> BS8.ByteString+encode64 = BS8.pack . go . BS.unpack+ where+ tbl = ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ "+/"+ ch n = tbl !! fromIntegral (n .&. 63)+ go (a : b : c : xs) =+ let n = w a `shiftL` 16 .|. w b `shiftL` 8 .|. w c+ in map (ch . (n `shiftR`)) [18, 12, 6, 0] ++ go xs+ go [a, b] =+ let n = w a `shiftL` 16 .|. w b `shiftL` 8+ in map (ch . (n `shiftR`)) [18, 12, 6] ++ "="+ go [a] = map (ch . ((w a `shiftL` 16) `shiftR`)) [18, 12] ++ "=="+ go [] = []+ w :: Word8 -> Word32+ w = fromIntegral++----------------------------------------------------------------++-- | A fake DNS: "aN" has an A record, "mxN" has N MX records,+-- others are NXDOMAIN. Returns the number of queries.+fakeSPF :: [(Domain, BS8.ByteString)] -> Domain -> IO (DAResult, Int)+fakeSPF txts dom = do+ cnt <- newIORef (0 :: Int)+ let tick = modifyIORef' cnt (+ 1)+ lk =+ SpfLookup+ { spfLookupTXT = \d -> tick >> return (maybe (Left NameError) (Right . (: [])) $ lookup d txts)+ , spfLookupA = \d ->+ tick >> return (if "a" `BS8.isPrefixOf` d then Right [ip1] else Left NameError)+ , spfLookupAAAA = \_ -> tick >> return (Left NameError)+ , spfLookupMX = \d -> tick >> return (mxs d)+ }+ r <- runSPFWith defaultLimit lk dom (IPv4 "192.0.2.1")+ n <- readIORef cnt+ return (r, n)+ where+ ip1 = "198.51.100.1"+ mxs d = case BS8.stripPrefix "mx" d >>= BS8.readInt of+ Just (n, _) -> Right [(BS8.pack ("a" ++ show i), 10) | i <- [1 .. n]]+ Nothing -> Left NameError++spfSpec :: Spec+spfSpec = describe "runSPF" $ do+ it "allows 10 DNS-querying terms" $+ fst <$> fakeSPF [("example.com", terms 10 "a:a")] "example.com"+ `shouldReturn` DAHardFail+ it "rejects more than 10 a terms" $ do+ (r, n) <- fakeSPF [("example.com", terms 1000 "a:a")] "example.com"+ r `shouldBe` DAPermError+ n `shouldSatisfy` (<= 11)+ it "counts mx, include and redirect" $ do+ let txts =+ [ ("example.com", "v=spf1 mx:mx1 include:inc.example redirect=red.example")+ , ("inc.example", terms 4 "a:a")+ , ("red.example", terms 4 "mx:mx")+ ]+ fst <$> fakeSPF txts "example.com" `shouldReturn` DAPermError+ it "rejects more than 10 MX records" $ do+ fst <$> fakeSPF [("example.com", "v=spf1 mx:mx10 -all")] "example.com"+ `shouldReturn` DAHardFail+ fst <$> fakeSPF [("example.com", "v=spf1 mx:mx11 -all")] "example.com"+ `shouldReturn` DAPermError+ it "rejects more than 2 void lookups" $ do+ fst <$> fakeSPF [("example.com", terms 2 "a:x")] "example.com"+ `shouldReturn` DAHardFail+ fst <$> fakeSPF [("example.com", terms 3 "a:x")] "example.com"+ `shouldReturn` DAPermError+ it "returns permerror for include without SPF record" $+ fst+ <$> fakeSPF [("example.com", "v=spf1 include:none.example -all")] "example.com"+ `shouldReturn` DAPermError+ where+ terms :: Int -> BS8.ByteString -> BS8.ByteString+ terms n t =+ "v=spf1 "+ <> BS8.unwords [t <> BS8.pack (show i) | i <- [1 .. n]]+ <> " -all"