{-# 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 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 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 = 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 -> 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 forall a. Eq a => a -> a -> Bool
== Int
0 = RawMail
""
      | Int
len forall a. Eq a => a -> a -> Bool
== Int
1 = RawMail
""
      | Bool
otherwise = if Word8
b1 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
BS.head RawMail
bdy
        bdy2 :: RawMail
bdy2 = HasCallStack => RawMail -> RawMail
BS.tail RawMail
bdy
        bdy3 :: RawMail
bdy3 = HasCallStack => RawMail -> RawMail
BS.tail RawMail
bdy2

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

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

splitFields :: RawHeader -> [RawField]
splitFields :: RawMail -> [RawMail]
splitFields RawMail
"" = []
splitFields RawMail
bs = RawMail
fld 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 forall a. Num a => a -> a -> a
- Int
1) RawMail
bs
    bs'' :: RawMail
bs'' = HasCallStack => RawMail -> RawMail
BS.tail RawMail
bs'

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

begOfLine :: RawMail -> Int -> Int
begOfLine :: RawMail -> Int -> Int
begOfLine RawMail
bs Int
cnt
    | RawMail
bs forall a. Eq a => a -> a -> Bool
== RawMail
""      = Int
cnt
    | Word8 -> Bool
isContinued Word8
b = RawMail -> Int -> Int
findFieldEnd RawMail
bs' (Int
cnt forall a. Num a => a -> a -> a
+ Int
1)
    | Bool
otherwise     = Int
cnt
  where
    b :: Word8
b   = HasCallStack => RawMail -> Word8
BS.head RawMail
bs
    bs' :: RawMail
bs' = HasCallStack => 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 forall a. Eq a => a -> a -> Bool
/= RawMail
"" Bool -> Bool -> Bool
&& HasCallStack => RawMail -> Word8
BS.head RawMail
v forall a. Eq a => a -> a -> Bool
== Word8
cSP
         then HasCallStack => 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
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> Bool
isSpace) RawMail
xs
    vs :: [RawMail]
vs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= RawMail
"") forall a b. (a -> b) -> a -> b
$ Word8 -> RawMail -> [RawMail]
BS.split Word8
cSemiColon RawMail
v
    vss :: [(RawMail, RawMail)]
vss = forall a b. (a -> b) -> [a] -> [b]
map (Word8 -> RawMail -> (RawMail, RawMail)
break' Word8
cEqual) [RawMail]
vs