{-# LANGUAGE OverloadedStrings #-}

module Network.DomainAuth.DK.Parser (
    parseDK
  ) where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Network.DomainAuth.DK.Types
import Network.DomainAuth.Mail

-- $setup
-- >>> import Text.Pretty.Simple
-- >>> import Data.ByteString.Char8 as BS8


-- | Parsing DomainKey-Signature:.
--
-- >>> :{
-- let dk = BS8.concat [
--                 "a=rsa-sha1; s=brisbane; d=football.example.com;\n"
--               , "  c=simple; q=dns;\n"
--               , "  b=dzdVyOfAKCdLXdJOc9G2q8LoXSlEniSbav+yuU4zGeeruD00lszZ\n"
--               , "    VoG4ZHRNiYzR;"
--               ]
-- in pPrintNoColor $ parseDK dk
-- :}
-- Just 
--     ( DK 
--         { dkAlgorithm = DK_RSA_SHA1
--         , dkSignature = "dzdVyOfAKCdLXdJOc9G2q8LoXSlEniSbav+yuU4zGeeruD00lszZVoG4ZHRNiYzR"
--         , dkCanonAlgo = DK_SIMPLE
--         , dkDomain0 = "football.example.com"
--         , dkFields = Nothing
--         , dkSelector0 = "brisbane"
--         } 
--     )
parseDK :: RawFieldValue -> Maybe DK
parseDK :: ByteString -> Maybe DK
parseDK ByteString
val = MDK -> Maybe DK
toDK MDK
domkey
  where
    ([ByteString]
ts,[ByteString]
vs) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)]
parseTaggedValue ByteString
val
    fs :: [ByteString -> MDK -> MDK]
fs = forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString -> MDK -> MDK
tagToSetter [ByteString]
ts
    tagToSetter :: ByteString -> ByteString -> MDK -> MDK
tagToSetter ByteString
tag = forall a. a -> Maybe a -> a
fromMaybe (\ByteString
_ MDK
mdk -> MDK
mdk) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> Char
BS.head ByteString
tag) [(Char, ByteString -> MDK -> MDK)]
dkTagDB
    pfs :: [MDK -> MDK]
pfs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a b. (a -> b) -> a -> b
($) [ByteString -> MDK -> MDK]
fs [ByteString]
vs
    domkey :: MDK
domkey = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) MDK
initialMDK [MDK -> MDK]
pfs
    toDK :: MDK -> Maybe DK
toDK MDK
mdk = do
        DkAlgorithm
alg <- MDK -> Maybe DkAlgorithm
mdkAlgorithm MDK
mdk
        ByteString
sig <- MDK -> Maybe ByteString
mdkSignature MDK
mdk
        DkCanonAlgo
cal <- MDK -> Maybe DkCanonAlgo
mdkCanonAlgo MDK
mdk
        ByteString
dom <- MDK -> Maybe ByteString
mdkDomain    MDK
mdk
        ByteString
sel <- MDK -> Maybe ByteString
mdkSelector  MDK
mdk
        forall (m :: * -> *) a. Monad m => a -> m a
return DK {
            dkAlgorithm :: DkAlgorithm
dkAlgorithm = DkAlgorithm
alg
          , dkSignature :: ByteString
dkSignature = ByteString
sig
          , dkCanonAlgo :: DkCanonAlgo
dkCanonAlgo = DkCanonAlgo
cal
          , dkDomain0 :: ByteString
dkDomain0   = ByteString
dom
          , dkFields :: Maybe DkFields
dkFields    = MDK -> Maybe DkFields
mdkFields MDK
mdk
          , dkSelector0 :: ByteString
dkSelector0 = ByteString
sel
          }

data MDK = MDK {
    MDK -> Maybe DkAlgorithm
mdkAlgorithm :: Maybe DkAlgorithm
  , MDK -> Maybe ByteString
mdkSignature :: Maybe ByteString
  , MDK -> Maybe DkCanonAlgo
mdkCanonAlgo :: Maybe DkCanonAlgo
  , MDK -> Maybe ByteString
mdkDomain    :: Maybe ByteString
  , MDK -> Maybe DkFields
mdkFields    :: Maybe DkFields
  , MDK -> Maybe ByteString
mdkSelector  :: Maybe ByteString
  } deriving (MDK -> MDK -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MDK -> MDK -> Bool
$c/= :: MDK -> MDK -> Bool
== :: MDK -> MDK -> Bool
$c== :: MDK -> MDK -> Bool
Eq,Int -> MDK -> ShowS
[MDK] -> ShowS
MDK -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MDK] -> ShowS
$cshowList :: [MDK] -> ShowS
show :: MDK -> String
$cshow :: MDK -> String
showsPrec :: Int -> MDK -> ShowS
$cshowsPrec :: Int -> MDK -> ShowS
Show)

initialMDK :: MDK
initialMDK :: MDK
initialMDK = MDK {
    mdkAlgorithm :: Maybe DkAlgorithm
mdkAlgorithm = forall a. a -> Maybe a
Just DkAlgorithm
DK_RSA_SHA1
  , mdkSignature :: Maybe ByteString
mdkSignature = forall a. Maybe a
Nothing
  , mdkCanonAlgo :: Maybe DkCanonAlgo
mdkCanonAlgo = forall a. Maybe a
Nothing
  , mdkDomain :: Maybe ByteString
mdkDomain    = forall a. Maybe a
Nothing
  , mdkFields :: Maybe DkFields
mdkFields    = forall a. Maybe a
Nothing
  , mdkSelector :: Maybe ByteString
mdkSelector  = forall a. Maybe a
Nothing
  }

type DKSetter = ByteString -> MDK -> MDK

dkTagDB :: [(Char,DKSetter)]
dkTagDB :: [(Char, ByteString -> MDK -> MDK)]
dkTagDB = [
    (Char
'a',ByteString -> MDK -> MDK
setDkAlgorithm)
  , (Char
'b',ByteString -> MDK -> MDK
setDkSignature)
  , (Char
'c',ByteString -> MDK -> MDK
setDkCanonAlgo)
  , (Char
'd',ByteString -> MDK -> MDK
setDkDomain)
  , (Char
'h',ByteString -> MDK -> MDK
setDkFields)
--  , ('q',setDkQuery)
  , (Char
's',ByteString -> MDK -> MDK
setDkSelector)
  ]

setDkAlgorithm :: DKSetter
setDkAlgorithm :: ByteString -> MDK -> MDK
setDkAlgorithm ByteString
"rsa-sha1" MDK
dk = MDK
dk { mdkAlgorithm :: Maybe DkAlgorithm
mdkAlgorithm = forall a. a -> Maybe a
Just DkAlgorithm
DK_RSA_SHA1 }
setDkAlgorithm ByteString
_ MDK
_           = forall a. HasCallStack => String -> a
error String
"setDkAlgorithm"

setDkSignature :: DKSetter
setDkSignature :: ByteString -> MDK -> MDK
setDkSignature ByteString
sig MDK
dk = MDK
dk { mdkSignature :: Maybe ByteString
mdkSignature = forall a. a -> Maybe a
Just ByteString
sig }

setDkCanonAlgo :: DKSetter
setDkCanonAlgo :: ByteString -> MDK -> MDK
setDkCanonAlgo ByteString
"simple" MDK
dk = MDK
dk { mdkCanonAlgo :: Maybe DkCanonAlgo
mdkCanonAlgo = forall a. a -> Maybe a
Just DkCanonAlgo
DK_SIMPLE }
setDkCanonAlgo ByteString
"nofws"  MDK
dk = MDK
dk { mdkCanonAlgo :: Maybe DkCanonAlgo
mdkCanonAlgo = forall a. a -> Maybe a
Just DkCanonAlgo
DK_NOFWS }
setDkCanonAlgo  ByteString
_ MDK
_        = forall a. HasCallStack => String -> a
error String
"setDkCanonAlgo"

setDkDomain :: DKSetter
setDkDomain :: ByteString -> MDK -> MDK
setDkDomain ByteString
dom MDK
dk = MDK
dk { mdkDomain :: Maybe ByteString
mdkDomain = forall a. a -> Maybe a
Just ByteString
dom }

setDkFields :: DKSetter
setDkFields :: ByteString -> MDK -> MDK
setDkFields ByteString
keys MDK
dk = MDK
dk { mdkFields :: Maybe DkFields
mdkFields = forall a. a -> Maybe a
Just DkFields
mx }
  where
    flds :: [ByteString]
flds = Char -> ByteString -> [ByteString]
BS.split Char
':' ByteString
keys
    mx :: DkFields
mx = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {k}. Ord k => Map k Bool -> k -> Map k Bool
func forall k a. Map k a
M.empty [ByteString]
flds
    func :: Map k Bool -> k -> Map k Bool
func Map k Bool
m k
fld = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
fld Bool
True Map k Bool
m

{-
setDkQuery :: DKSetter
setDkQuery "dns" dk = dk { mdkQuery = Just DK_DNS }
setDkQuery _ _      = error "setDkQuery"
-}

setDkSelector :: DKSetter
setDkSelector :: ByteString -> MDK -> MDK
setDkSelector ByteString
sel MDK
dk = MDK
dk { mdkSelector :: Maybe ByteString
mdkSelector = forall a. a -> Maybe a
Just ByteString
sel }