{-# LANGUAGE OverloadedStrings #-}

module Network.DomainAuth.Mail.Parser (
    readMail,
    getMail,
    parseTaggedValue,
) where

import qualified Data.ByteString as BS
import Data.Word
import Network.DomainAuth.Mail.Types
import Network.DomainAuth.Mail.XMail
import Network.DomainAuth.Utils

-- $setup
-- >>> :set -XOverloadedStrings

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

-- | Obtain 'Mail' from a file.
readMail :: FilePath -> IO Mail
readMail :: FilePath -> IO Mail
readMail FilePath
file = RawMail -> Mail
getMail (RawMail -> Mail) -> IO RawMail -> IO Mail
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO RawMail
BS.readFile FilePath
file

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

-- | Obtain 'Mail' from 'RawMail'.
--
-- >>> let out1 = finalizeMail $ pushBody "body" $ pushField "to" "val" $ pushField "from" "val" initialXMail
-- >>> getMail "from: val\nto: val\n\nbody" == out1
-- True
-- >>> let out2 = finalizeMail $ pushBody "body" $ pushField "to" "val" $ pushField "from" "val\tval" initialXMail
-- >>> getMail "from: val\tval\nto: val\n\nbody" == out2
-- True
-- >>> let out3 = finalizeMail $ pushBody "" $ pushField "to" "val" $ pushField "from" "val" initialXMail
-- >>> getMail "from: val\nto: val\n" == out3
-- True
getMail :: RawMail -> Mail
getMail :: RawMail -> Mail
getMail RawMail
bs = XMail -> Mail
finalizeMail (XMail -> Mail) -> XMail -> Mail
forall a b. (a -> b) -> a -> b
$ RawMail -> XMail -> XMail
pushBody RawMail
rbdy XMail
xmail
  where
    (RawMail
rhdr, RawMail
rbdy) = RawMail -> (RawMail, RawMail)
splitHeaderBody RawMail
bs
    rflds :: [RawMail]
rflds = RawMail -> [RawMail]
splitFields RawMail
rhdr
    xmail :: XMail
xmail = (XMail -> RawMail -> XMail) -> XMail -> [RawMail] -> XMail
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl XMail -> RawMail -> XMail
push XMail
initialXMail [RawMail]
rflds
    push :: XMail -> RawMail -> XMail
push XMail
m RawMail
fld =
        let (RawMail
k, RawMail
v) = RawMail -> (RawMail, RawMail)
parseField RawMail
fld
         in RawMail -> RawMail -> XMail -> XMail
pushField RawMail
k RawMail
v XMail
m

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

splitHeaderBody :: RawMail -> (RawHeader, RawBody)
splitHeaderBody :: RawMail -> (RawMail, RawMail)
splitHeaderBody RawMail
bs = case Maybe Int
mcnt of
    Maybe Int
Nothing -> (RawMail
bs, RawMail
"")
    Just Int
cnt -> (RawMail, RawMail) -> (RawMail, RawMail)
forall {a}. (a, RawMail) -> (a, RawMail)
check (Int -> RawMail -> (RawMail, RawMail)
BS.splitAt Int
cnt RawMail
bs)
  where
    mcnt :: Maybe Int
mcnt = RawMail -> Int -> Maybe Int
findEOH RawMail
bs Int
0
    check :: (a, RawMail) -> (a, RawMail)
check (a
hdr, RawMail
bdy) = (a
hdr, RawMail -> RawMail
dropSep RawMail
bdy)
    dropSep :: RawMail -> RawMail
dropSep RawMail
bdy
        | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = RawMail
""
        | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = RawMail
""
        | Bool
otherwise = if Word8
b1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cCR then RawMail
bdy3 else RawMail
bdy2
      where
        len :: Int
len = RawMail -> Int
BS.length RawMail
bdy
        b1 :: Word8
b1 = HasCallStack => RawMail -> Word8
RawMail -> Word8
BS.head RawMail
bdy
        bdy2 :: RawMail
bdy2 = HasCallStack => RawMail -> RawMail
RawMail -> RawMail
BS.tail RawMail
bdy
        bdy3 :: RawMail
bdy3 = HasCallStack => RawMail -> RawMail
RawMail -> RawMail
BS.tail RawMail
bdy2

findEOH :: RawMail -> Int -> Maybe Int
findEOH :: RawMail -> Int -> Maybe Int
findEOH RawMail
"" Int
_ = Maybe Int
forall a. Maybe a
Nothing
findEOH RawMail
bs Int
cnt
    | Word8
b0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cLF Bool -> Bool -> Bool
&& RawMail
bs1 RawMail -> RawMail -> Bool
forall a. Eq a => a -> a -> Bool
/= RawMail
"" Bool -> Bool -> Bool
&& Word8
b1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cLF = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    | Word8
b0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cLF
        Bool -> Bool -> Bool
&& RawMail
bs1 RawMail -> RawMail -> Bool
forall a. Eq a => a -> a -> Bool
/= RawMail
""
        Bool -> Bool -> Bool
&& Word8
b1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cCR
        Bool -> Bool -> Bool
&& RawMail
bs2 RawMail -> RawMail -> Bool
forall a. Eq a => a -> a -> Bool
/= RawMail
""
        Bool -> Bool -> Bool
&& Word8
b2 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cLF =
        Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    | Bool
otherwise = RawMail -> Int -> Maybe Int
findEOH RawMail
bs1 (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  where
    b0 :: Word8
b0 = HasCallStack => RawMail -> Word8
RawMail -> Word8
BS.head RawMail
bs
    bs1 :: RawMail
bs1 = HasCallStack => RawMail -> RawMail
RawMail -> RawMail
BS.tail RawMail
bs
    b1 :: Word8
b1 = HasCallStack => RawMail -> Word8
RawMail -> Word8
BS.head RawMail
bs1
    bs2 :: RawMail
bs2 = HasCallStack => RawMail -> RawMail
RawMail -> RawMail
BS.tail RawMail
bs1
    b2 :: Word8
b2 = HasCallStack => RawMail -> Word8
RawMail -> Word8
BS.head RawMail
bs2

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

splitFields :: RawHeader -> [RawField]
splitFields :: RawMail -> [RawMail]
splitFields RawMail
"" = []
splitFields RawMail
bs = RawMail
fld RawMail -> [RawMail] -> [RawMail]
forall a. a -> [a] -> [a]
: RawMail -> [RawMail]
splitFields RawMail
bs''
  where
    -- split before cLF for efficiency
    (RawMail
fld, RawMail
bs') = Int -> RawMail -> (RawMail, RawMail)
BS.splitAt (RawMail -> Int -> Int
findFieldEnd RawMail
bs Int
0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) RawMail
bs
    bs'' :: RawMail
bs'' = HasCallStack => RawMail -> RawMail
RawMail -> RawMail
BS.tail RawMail
bs'

findFieldEnd :: RawMail -> Int -> Int
findFieldEnd :: RawMail -> Int -> Int
findFieldEnd RawMail
bs Int
cnt
    | RawMail
bs RawMail -> RawMail -> Bool
forall a. Eq a => a -> a -> Bool
== RawMail
"" = Int
cnt
    | Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cLF = RawMail -> Int -> Int
begOfLine RawMail
bs' (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    | Bool
otherwise = RawMail -> Int -> Int
findFieldEnd RawMail
bs' (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  where
    b :: Word8
b = HasCallStack => RawMail -> Word8
RawMail -> Word8
BS.head RawMail
bs
    bs' :: RawMail
bs' = HasCallStack => RawMail -> RawMail
RawMail -> RawMail
BS.tail RawMail
bs

begOfLine :: RawMail -> Int -> Int
begOfLine :: RawMail -> Int -> Int
begOfLine RawMail
bs Int
cnt
    | RawMail
bs RawMail -> RawMail -> Bool
forall a. Eq a => a -> a -> Bool
== RawMail
"" = Int
cnt
    | Word8 -> Bool
isContinued Word8
b = RawMail -> Int -> Int
findFieldEnd RawMail
bs' (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    | Bool
otherwise = Int
cnt
  where
    b :: Word8
b = HasCallStack => RawMail -> Word8
RawMail -> Word8
BS.head RawMail
bs
    bs' :: RawMail
bs' = HasCallStack => RawMail -> RawMail
RawMail -> RawMail
BS.tail RawMail
bs

isContinued :: Word8 -> Bool
isContinued :: Word8 -> Bool
isContinued = Word8 -> Bool
isSpace

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

parseField :: RawField -> (RawFieldKey, RawFieldValue)
parseField :: RawMail -> (RawMail, RawMail)
parseField RawMail
bs = (RawMail
k, RawMail
v')
  where
    (RawMail
k, RawMail
v) = Word8 -> RawMail -> (RawMail, RawMail)
break' Word8
cColon RawMail
bs
    -- Sendmail drops ' ' after ':'.
    v' :: RawMail
v' =
        if RawMail
v RawMail -> RawMail -> Bool
forall a. Eq a => a -> a -> Bool
/= RawMail
"" Bool -> Bool -> Bool
&& HasCallStack => RawMail -> Word8
RawMail -> Word8
BS.head RawMail
v Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cSP
            then HasCallStack => RawMail -> RawMail
RawMail -> RawMail
BS.tail RawMail
v
            else RawMail
v

----------------------------------------------------------------
-- This breaks spaces in the note tag.

-- | Parsing field value of tag=value.
--
-- >>> parseTaggedValue " k = rsa ; p= MIGfMA0G; n=A 1024 bit key;"
-- [("k","rsa"),("p","MIGfMA0G"),("n","A1024bitkey")]
-- >>> parseTaggedValue " k = \nrsa ;\n p= MIGfMA0G;\n n=A 1024 bit key"
-- [("k","rsa"),("p","MIGfMA0G"),("n","A1024bitkey")]
parseTaggedValue :: RawFieldValue -> [(BS.ByteString, BS.ByteString)]
parseTaggedValue :: RawMail -> [(RawMail, RawMail)]
parseTaggedValue RawMail
xs = [(RawMail, RawMail)]
vss
  where
    v :: RawMail
v = (Word8 -> Bool) -> RawMail -> RawMail
BS.filter (Bool -> Bool
not (Bool -> Bool) -> (Word8 -> Bool) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Bool
isSpace) RawMail
xs
    vs :: [RawMail]
vs = (RawMail -> Bool) -> [RawMail] -> [RawMail]
forall a. (a -> Bool) -> [a] -> [a]
filter (RawMail -> RawMail -> Bool
forall a. Eq a => a -> a -> Bool
/= RawMail
"") ([RawMail] -> [RawMail]) -> [RawMail] -> [RawMail]
forall a b. (a -> b) -> a -> b
$ Word8 -> RawMail -> [RawMail]
BS.split Word8
cSemiColon RawMail
v
    vss :: [(RawMail, RawMail)]
vss = (RawMail -> (RawMail, RawMail))
-> [RawMail] -> [(RawMail, RawMail)]
forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> RawMail -> (RawMail, RawMail)
break' Word8
cEqual) [RawMail]
vs