{-# LANGUAGE OverloadedStrings #-}

-- | A library for DomainKeys (<http://www.ietf.org/rfc/rfc4870.txt>).
--   Currently, only receiver side is implemented.
module Network.DomainAuth.DK (
    -- * Documentation

    -- ** Authentication with DK
    runDK,
    runDK',

    -- ** Parsing DomainKey-Signature:
    parseDK,
    DK,
    dkDomain,
    dkSelector,

    -- ** Field key for DomainKey-Signature:
    dkFieldKey,
) where

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

-- | Verifying 'Mail' with DomainKeys.
runDK :: Resolver -> Mail -> IO DAResult
runDK :: Resolver -> Mail -> IO DAResult
runDK Resolver
resolver Mail
mail = IO DAResult
dk1
  where
    dk1 :: IO DAResult
dk1 = 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
dk2 (Maybe Field -> IO DAResult) -> Maybe Field -> IO DAResult
forall a b. (a -> b) -> a -> b
$ FieldKey -> Header -> Maybe Field
lookupField FieldKey
dkFieldKey (Mail -> Header
mailHeader Mail
mail)
    dk2 :: Field -> IO DAResult
dk2 Field
dkv = IO DAResult -> (DK -> IO DAResult) -> Maybe DK -> 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) DK -> IO DAResult
dk3 (Maybe DK -> IO DAResult) -> Maybe DK -> IO DAResult
forall a b. (a -> b) -> a -> b
$ FieldKey -> Maybe DK
parseDK (Field -> FieldKey
fieldValueUnfolded Field
dkv)
    dk3 :: DK -> IO DAResult
dk3 = Resolver -> Mail -> DK -> IO DAResult
runDK' Resolver
resolver Mail
mail

-- | Verifying 'Mail' with DomainKeys. The value of DomainKey-Signature:
--   should be parsed beforehand.
runDK' :: Resolver -> Mail -> DK -> IO DAResult
runDK' :: Resolver -> Mail -> DK -> IO DAResult
runDK' Resolver
resolver Mail
mail DK
dk = DAResult -> (PublicKey -> DAResult) -> Maybe PublicKey -> DAResult
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DAResult
DATempError (Mail -> DK -> PublicKey -> DAResult
verify Mail
mail DK
dk) (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 = DK -> FieldKey
dkSelector DK
dk FieldKey -> FieldKey -> FieldKey
+++ FieldKey
"._domainkey." FieldKey -> FieldKey -> FieldKey
+++ DK -> FieldKey
dkDomain DK
dk
    verify :: Mail -> DK -> PublicKey -> DAResult
verify Mail
m DK
d PublicKey
p = if Mail -> DK -> PublicKey -> Bool
verifyDK Mail
m DK
d PublicKey
p then DAResult
DAPass else DAResult
DAFail
    +++ :: FieldKey -> FieldKey -> FieldKey
(+++) = FieldKey -> FieldKey -> FieldKey
BS.append