Verify.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.DomainAuth.DKIM.Verify (
    verifyDKIM,
    prepareDKIM,
) where

import Crypto.Hash
import Crypto.PubKey.RSA
import Crypto.PubKey.RSA.PKCS15
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
import Network.DomainAuth.Utils

----------------------------------------------------------------

-- | 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
    isTheSig fld =
        fieldSearchKey fld == dkimFieldKey
            && parseDKIM (fieldValueUnfolded fld) == Just dkim
    hCanon = canonDkimField (dkimHeaderCanon dkim)
    canon = BB.byteString . removeBtagValue . hCanon

----------------------------------------------------------------

canonDkimField :: DkimCanonAlgo -> Field -> ByteString
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

----------------------------------------------------------------

canonDkimBody :: DkimCanonAlgo -> Body -> Builder
canonDkimBody DKIM_SIMPLE = fromBody . removeTrailingEmptyLine
canonDkimBody DKIM_RELAXED = fromBodyWith relax . removeTrailingEmptyLine
  where
    relax = removeTrailingWSP . reduceWSP

----------------------------------------------------------------

verifyDKIM :: Mail -> DKIM -> PublicKey -> Bool
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
    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 mail

verify' :: DkimSigAlgo -> PublicKey -> ByteString -> ByteString -> Bool
verify' RSA_SHA1 = verify (Just SHA1)
verify' RSA_SHA256 = verify (Just 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)