{-# 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
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
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
(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
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
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