{-# LANGUAGE OverloadedStrings #-}

-- | 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

import qualified Data.ByteString as BS
import Network.DNS as DNS (Resolver)
import Network.DomainAuth.DKIM.Parser
import Network.DomainAuth.DKIM.Types
import Network.DomainAuth.DKIM.Verify
import Network.DomainAuth.Mail
import Network.DomainAuth.Pubkey.RSAPub
import Network.DomainAuth.Types

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Network.DNS
-- >>> import Data.ByteString.Char8 as BS8

-- | Verifying 'Mail' with DKIM.
--
-- >>> rs <- makeResolvSeed defaultResolvConf
-- >>> :{
-- let lst = ["DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;"
--           ,"        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=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: <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\""
--           ,""
--           ,"test"
--           ]
--     mail = getMail $ BS8.intercalate "\r\n" lst
-- in withResolver rs $ \rslv -> runDKIM rslv mail
-- :}
-- pass
runDKIM :: Resolver -> Mail -> IO DAResult
runDKIM :: Resolver -> Mail -> IO DAResult
runDKIM Resolver
resolver Mail
mail = IO DAResult
dkim1
  where
    dkim1 :: IO DAResult
dkim1 =
        IO DAResult -> (Field -> IO DAResult) -> Maybe Field -> IO DAResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DAResult -> IO DAResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DAResult
DANone) Field -> IO DAResult
dkim2 (Maybe Field -> IO DAResult) -> Maybe Field -> IO DAResult
forall a b. (a -> b) -> a -> b
$ FieldKey -> Header -> Maybe Field
lookupField FieldKey
dkimFieldKey (Mail -> Header
mailHeader Mail
mail)
    dkim2 :: Field -> IO DAResult
dkim2 Field
dkimv = IO DAResult -> (DKIM -> IO DAResult) -> Maybe DKIM -> IO DAResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DAResult -> IO DAResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DAResult
DAPermError) DKIM -> IO DAResult
dkim3 (Maybe DKIM -> IO DAResult) -> Maybe DKIM -> IO DAResult
forall a b. (a -> b) -> a -> b
$ FieldKey -> Maybe DKIM
parseDKIM (Field -> FieldKey
fieldValueUnfolded Field
dkimv)
    dkim3 :: DKIM -> IO DAResult
dkim3 = Resolver -> Mail -> DKIM -> IO DAResult
runDKIM' Resolver
resolver Mail
mail

-- | Verifying 'Mail' with DKIM. The value of DKIM-Signature:
--   should be parsed beforehand.
runDKIM' :: Resolver -> Mail -> DKIM -> IO DAResult
runDKIM' :: Resolver -> Mail -> DKIM -> IO DAResult
runDKIM' Resolver
resolver Mail
mail DKIM
dkim = DAResult -> (PublicKey -> DAResult) -> Maybe PublicKey -> DAResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DAResult
DATempError (Mail -> DKIM -> PublicKey -> DAResult
verify Mail
mail DKIM
dkim) (Maybe PublicKey -> DAResult)
-> IO (Maybe PublicKey) -> IO DAResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe PublicKey)
pub
  where
    pub :: IO (Maybe PublicKey)
pub = Resolver -> FieldKey -> IO (Maybe PublicKey)
lookupPublicKey Resolver
resolver FieldKey
dom
    dom :: FieldKey
dom = DKIM -> FieldKey
dkimSelector DKIM
dkim FieldKey -> FieldKey -> FieldKey
+++ FieldKey
"._domainkey." FieldKey -> FieldKey -> FieldKey
+++ DKIM -> FieldKey
dkimDomain DKIM
dkim
    verify :: Mail -> DKIM -> PublicKey -> DAResult
verify Mail
m DKIM
d PublicKey
p = if Mail -> DKIM -> PublicKey -> Bool
verifyDKIM Mail
m DKIM
d PublicKey
p then DAResult
DAPass else DAResult
DAFail
    +++ :: FieldKey -> FieldKey -> FieldKey
(+++) = FieldKey -> FieldKey -> FieldKey
BS.append