{-# 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"