{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

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.Types
import Network.DomainAuth.Mail
import qualified Network.DomainAuth.Pubkey.Base64 as B
import Network.DomainAuth.Utils

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

prepareDKIM :: DKIM -> Mail -> Builder
prepareDKIM :: DKIM -> Mail -> Builder
prepareDKIM DKIM
dkim Mail
mail = Builder
header
  where
    Field
dkimField : [Field]
fields = ByteString -> [Field] -> [Field]
fieldsFrom ByteString
dkimFieldKey (Mail -> [Field]
mailHeader Mail
mail)
    hCanon :: Field -> ByteString
hCanon = DkimCanonAlgo -> Field -> ByteString
canonDkimField (DKIM -> DkimCanonAlgo
dkimHeaderCanon DKIM
dkim)
    canon :: Field -> Builder
canon = ByteString -> Builder
BB.byteString (ByteString -> Builder)
-> (Field -> ByteString) -> Field -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
removeBtagValue (ByteString -> ByteString)
-> (Field -> ByteString) -> Field -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> ByteString
hCanon
    targets :: [Field]
targets = [ByteString] -> [Field] -> [Field]
fieldsWith (DKIM -> [ByteString]
dkimFields DKIM
dkim) [Field]
fields
    header :: Builder
header = (Field -> ByteString) -> [Field] -> Builder
forall a. (a -> ByteString) -> [a] -> Builder
concatCRLFWith Field -> ByteString
hCanon [Field]
targets Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
+++ Field -> Builder
canon Field
dkimField

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

canonDkimField :: DkimCanonAlgo -> Field -> ByteString
canonDkimField :: DkimCanonAlgo -> Field -> ByteString
canonDkimField DkimCanonAlgo
DKIM_SIMPLE Field
fld = Field -> ByteString
fieldKey Field
fld ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
+++ ByteString
": " ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
+++ Field -> ByteString
fieldValueFolded Field
fld
canonDkimField DkimCanonAlgo
DKIM_RELAXED Field
fld = Field -> ByteString
fieldSearchKey Field
fld ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
+++ ByteString
":" ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
+++ Field -> ByteString
canon Field
fld
  where
    canon :: Field -> ByteString
canon = (Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile Word8 -> Bool
isSpace (ByteString -> ByteString)
-> (Field -> ByteString) -> Field -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
removeTrailingWSP (ByteString -> ByteString)
-> (Field -> ByteString) -> Field -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
reduceWSP (ByteString -> ByteString)
-> (Field -> ByteString) -> Field -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (Field -> [ByteString]) -> Field -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> [ByteString]
fieldValue

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

canonDkimBody :: DkimCanonAlgo -> Body -> Builder
canonDkimBody :: DkimCanonAlgo -> Body -> Builder
canonDkimBody DkimCanonAlgo
DKIM_SIMPLE = Body -> Builder
fromBody (Body -> Builder) -> (Body -> Body) -> Body -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body -> Body
removeTrailingEmptyLine
canonDkimBody DkimCanonAlgo
DKIM_RELAXED = (ByteString -> ByteString) -> Body -> Builder
fromBodyWith ByteString -> ByteString
relax (Body -> Builder) -> (Body -> Body) -> Body -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body -> Body
removeTrailingEmptyLine
  where
    relax :: ByteString -> ByteString
relax = ByteString -> ByteString
removeTrailingWSP (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
reduceWSP

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

verifyDKIM :: Mail -> DKIM -> PublicKey -> Bool
verifyDKIM :: Mail -> DKIM -> PublicKey -> Bool
verifyDKIM Mail
mail DKIM
dkim PublicKey
pub =
    Mail -> ByteString
bodyHash1 Mail
mail ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== DKIM -> ByteString
bodyHash2 DKIM
dkim
        Bool -> Bool -> Bool
&& DkimSigAlgo -> PublicKey -> ByteString -> ByteString -> Bool
verify' (DKIM -> DkimSigAlgo
dkimSigAlgo DKIM
dkim) PublicKey
pub ByteString
cmail ByteString
sig
  where
    sig :: ByteString
sig = ByteString -> ByteString
B.decode (ByteString -> ByteString)
-> (DKIM -> ByteString) -> DKIM -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DKIM -> ByteString
dkimSignature (DKIM -> ByteString) -> DKIM -> ByteString
forall a b. (a -> b) -> a -> b
$ DKIM
dkim
    cmail :: ByteString
cmail = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ DKIM -> Mail -> Builder
prepareDKIM DKIM
dkim Mail
mail
    bodyHash1 :: Mail -> ByteString
bodyHash1 =
        DkimSigAlgo -> ByteString -> ByteString
forall c. ByteArray c => DkimSigAlgo -> ByteString -> c
hashAlgo2 (DKIM -> DkimSigAlgo
dkimSigAlgo DKIM
dkim)
            (ByteString -> ByteString)
-> (Mail -> ByteString) -> Mail -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict
            (ByteString -> ByteString)
-> (Mail -> ByteString) -> Mail -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString
            (Builder -> ByteString) -> (Mail -> Builder) -> Mail -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DkimCanonAlgo -> Body -> Builder
canonDkimBody (DKIM -> DkimCanonAlgo
dkimBodyCanon DKIM
dkim)
            (Body -> Builder) -> (Mail -> Body) -> Mail -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mail -> Body
mailBody
    bodyHash2 :: DKIM -> ByteString
bodyHash2 = ByteString -> ByteString
B.decode (ByteString -> ByteString)
-> (DKIM -> ByteString) -> DKIM -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DKIM -> ByteString
dkimBodyHash

verify' :: DkimSigAlgo -> PublicKey -> ByteString -> ByteString -> Bool
verify' :: DkimSigAlgo -> PublicKey -> ByteString -> ByteString -> Bool
verify' DkimSigAlgo
RSA_SHA1 = Maybe SHA1 -> PublicKey -> ByteString -> ByteString -> Bool
forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe hashAlg -> PublicKey -> ByteString -> ByteString -> Bool
verify (SHA1 -> Maybe SHA1
forall a. a -> Maybe a
Just SHA1
SHA1)
verify' DkimSigAlgo
RSA_SHA256 = Maybe SHA256 -> PublicKey -> ByteString -> ByteString -> Bool
forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe hashAlg -> PublicKey -> ByteString -> ByteString -> Bool
verify (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
SHA256)

hashAlgo2 :: ByteArray c => DkimSigAlgo -> ByteString -> c
hashAlgo2 :: forall c. ByteArray c => DkimSigAlgo -> ByteString -> c
hashAlgo2 DkimSigAlgo
RSA_SHA1 = Digest SHA1 -> c
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Digest SHA1 -> c)
-> (ByteString -> Digest SHA1) -> ByteString -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Digest SHA1
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash :: ByteString -> Digest SHA1)
hashAlgo2 DkimSigAlgo
RSA_SHA256 = Digest SHA256 -> c
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (Digest SHA256 -> c)
-> (ByteString -> Digest SHA256) -> ByteString -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash :: ByteString -> Digest SHA256)