module Network.Mail.Postie.Pipes
  ( dataChunks,
    attoParser,
    UnexpectedEndOfInputException,
    TooMuchDataException,
  )
where

import Control.Applicative
import Control.Exception (Exception, throw)
import Control.Monad (unless)
import qualified Data.Attoparsec.ByteString as AT
import qualified Data.ByteString.Char8 as BS
import Data.Maybe (fromMaybe)
import Data.Typeable (Typeable)
import Pipes
import Pipes.Parse
import Prelude hiding (lines)

data UnexpectedEndOfInputException = UnexpectedEndOfInputException
  deriving (Int -> UnexpectedEndOfInputException -> ShowS
[UnexpectedEndOfInputException] -> ShowS
UnexpectedEndOfInputException -> String
(Int -> UnexpectedEndOfInputException -> ShowS)
-> (UnexpectedEndOfInputException -> String)
-> ([UnexpectedEndOfInputException] -> ShowS)
-> Show UnexpectedEndOfInputException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnexpectedEndOfInputException] -> ShowS
$cshowList :: [UnexpectedEndOfInputException] -> ShowS
show :: UnexpectedEndOfInputException -> String
$cshow :: UnexpectedEndOfInputException -> String
showsPrec :: Int -> UnexpectedEndOfInputException -> ShowS
$cshowsPrec :: Int -> UnexpectedEndOfInputException -> ShowS
Show, Typeable)

data TooMuchDataException = TooMuchDataException
  deriving (Int -> TooMuchDataException -> ShowS
[TooMuchDataException] -> ShowS
TooMuchDataException -> String
(Int -> TooMuchDataException -> ShowS)
-> (TooMuchDataException -> String)
-> ([TooMuchDataException] -> ShowS)
-> Show TooMuchDataException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TooMuchDataException] -> ShowS
$cshowList :: [TooMuchDataException] -> ShowS
show :: TooMuchDataException -> String
$cshow :: TooMuchDataException -> String
showsPrec :: Int -> TooMuchDataException -> ShowS
$cshowsPrec :: Int -> TooMuchDataException -> ShowS
Show, Typeable)

instance Exception UnexpectedEndOfInputException

instance Exception TooMuchDataException

attoParser :: AT.Parser r -> Parser BS.ByteString IO (Maybe r)
attoParser :: Parser r -> Parser ByteString IO (Maybe r)
attoParser p :: Parser r
p = do
  Result r
result <- StateT (Producer ByteString IO x) IO ByteString
-> Parser r
-> ByteString
-> StateT (Producer ByteString IO x) IO (Result r)
forall (m :: * -> *) a.
Monad m =>
m ByteString -> Parser a -> ByteString -> m (Result a)
AT.parseWith StateT (Producer ByteString IO x) IO ByteString
forall x. StateT (Producer ByteString IO x) IO ByteString
draw' Parser r
p ""
  case Result r
result of
    AT.Done t :: ByteString
t r :: r
r -> do
      Bool
-> StateT (Producer ByteString IO x) IO ()
-> StateT (Producer ByteString IO x) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
t) (ByteString -> Parser ByteString IO ()
forall (m :: * -> *) a. Monad m => a -> Parser a m ()
unDraw ByteString
t)
      Maybe r -> StateT (Producer ByteString IO x) IO (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Maybe r
forall a. a -> Maybe a
Just r
r)
    _ -> Maybe r -> StateT (Producer ByteString IO x) IO (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
forall a. Maybe a
Nothing
  where
    draw' :: StateT (Producer ByteString IO x) IO ByteString
draw' = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe ByteString -> ByteString)
-> StateT (Producer ByteString IO x) IO (Maybe ByteString)
-> StateT (Producer ByteString IO x) IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Producer ByteString IO x) IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => Parser a m (Maybe a)
draw

dataChunks :: Int -> Producer BS.ByteString IO () -> Producer BS.ByteString IO ()
dataChunks :: Int -> Producer ByteString IO () -> Producer ByteString IO ()
dataChunks n :: Int
n p :: Producer ByteString IO ()
p = Producer ByteString IO () -> Producer ByteString IO ()
lines Producer ByteString IO ()
p Producer ByteString IO ()
-> Proxy () ByteString () ByteString IO ()
-> Producer ByteString IO ()
forall (m :: * -> *) a' a b r c' c.
Functor m =>
Proxy a' a () b m r -> Proxy () b c' c m r -> Proxy a' a c' c m r
>-> Int -> Proxy () ByteString () ByteString IO ()
forall (m :: * -> *).
Functor m =>
Int -> Proxy () ByteString () ByteString m ()
go Int
n
  where
    go :: Int -> Proxy () ByteString () ByteString m ()
go remaining :: Int
remaining | Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = TooMuchDataException -> Proxy () ByteString () ByteString m ()
forall a e. Exception e => e -> a
throw TooMuchDataException
TooMuchDataException
    go remaining :: Int
remaining = do
      ByteString
bs <- Proxy () ByteString () ByteString m ByteString
forall (m :: * -> *) a. Functor m => Consumer' a m a
await
      Bool
-> Proxy () ByteString () ByteString m ()
-> Proxy () ByteString () ByteString m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ".") (Proxy () ByteString () ByteString m ()
 -> Proxy () ByteString () ByteString m ())
-> Proxy () ByteString () ByteString m ()
-> Proxy () ByteString () ByteString m ()
forall a b. (a -> b) -> a -> b
$ do
        ByteString -> Producer' ByteString m ()
forall (m :: * -> *) a. Functor m => a -> Producer' a m ()
yield (ByteString -> ByteString
unescape ByteString
bs)
        ByteString -> Producer' ByteString m ()
forall (m :: * -> *) a. Functor m => a -> Producer' a m ()
yield "\r\n"
        Int -> Proxy () ByteString () ByteString m ()
go (Int
remaining Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2)
    unescape :: ByteString -> ByteString
unescape bs :: ByteString
bs
      | ByteString -> Bool
BS.null ByteString
bs = ByteString
bs
      | ByteString -> Char
BS.head ByteString
bs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.' Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 = ByteString -> ByteString
BS.tail ByteString
bs
      | Bool
otherwise = ByteString
bs

lines :: Producer BS.ByteString IO () -> Producer BS.ByteString IO ()
lines :: Producer ByteString IO () -> Producer ByteString IO ()
lines = Producer ByteString IO () -> Producer ByteString IO ()
forall x x' x b.
Producer ByteString IO x -> Proxy x' x () ByteString IO b
go
  where
    go :: Producer ByteString IO x -> Proxy x' x () ByteString IO b
go p :: Producer ByteString IO x
p = do
      (line :: ByteString
line, leftover :: Producer ByteString IO x
leftover) <- IO (ByteString, Producer ByteString IO x)
-> Proxy
     x' x () ByteString IO (ByteString, Producer ByteString IO x)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (ByteString, Producer ByteString IO x)
 -> Proxy
      x' x () ByteString IO (ByteString, Producer ByteString IO x))
-> IO (ByteString, Producer ByteString IO x)
-> Proxy
     x' x () ByteString IO (ByteString, Producer ByteString IO x)
forall a b. (a -> b) -> a -> b
$ StateT (Producer ByteString IO x) IO ByteString
-> Producer ByteString IO x
-> IO (ByteString, Producer ByteString IO x)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (Producer ByteString IO x) IO ByteString
forall x. StateT (Producer ByteString IO x) IO ByteString
lineParser Producer ByteString IO x
p
      ByteString -> Producer' ByteString IO ()
forall (m :: * -> *) a. Functor m => a -> Producer' a m ()
yield ByteString
line
      Producer ByteString IO x -> Proxy x' x () ByteString IO b
go Producer ByteString IO x
leftover

lineParser :: Parser BS.ByteString IO BS.ByteString
lineParser :: StateT (Producer ByteString IO x) IO ByteString
lineParser = (ByteString -> ByteString)
-> StateT (Producer ByteString IO x) IO ByteString
forall (m :: * -> *) x.
Monad m =>
(ByteString -> ByteString)
-> StateT (Producer ByteString m x) m ByteString
go ByteString -> ByteString
forall a. a -> a
id
  where
    go :: (ByteString -> ByteString)
-> StateT (Producer ByteString m x) m ByteString
go f :: ByteString -> ByteString
f = do
      ByteString
bs <- StateT (Producer ByteString m x) m ByteString
-> (ByteString -> StateT (Producer ByteString m x) m ByteString)
-> Maybe ByteString
-> StateT (Producer ByteString m x) m ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UnexpectedEndOfInputException
-> StateT (Producer ByteString m x) m ByteString
forall a e. Exception e => e -> a
throw UnexpectedEndOfInputException
UnexpectedEndOfInputException) (ByteString -> StateT (Producer ByteString m x) m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> StateT (Producer ByteString m x) m ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> StateT (Producer ByteString m x) m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
f) (Maybe ByteString -> StateT (Producer ByteString m x) m ByteString)
-> StateT (Producer ByteString m x) m (Maybe ByteString)
-> StateT (Producer ByteString m x) m ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Producer ByteString m x) m (Maybe ByteString)
forall (m :: * -> *) a. Monad m => Parser a m (Maybe a)
draw
      case Char -> ByteString -> Maybe Int
BS.elemIndex '\r' ByteString
bs of
        Nothing -> (ByteString -> ByteString)
-> StateT (Producer ByteString m x) m ByteString
go (ByteString -> ByteString -> ByteString
BS.append ByteString
bs)
        Just n :: Int
n -> do
          let here :: ByteString
here = ByteString -> ByteString
killCR (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
n ByteString
bs
              rest :: ByteString
rest = Int -> ByteString -> ByteString
BS.drop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ByteString
bs
          ByteString -> Parser ByteString m ()
forall (m :: * -> *) a. Monad m => a -> Parser a m ()
unDraw ByteString
rest
          ByteString -> StateT (Producer ByteString m x) m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
here
    killCR :: ByteString -> ByteString
killCR bs :: ByteString
bs
      | ByteString -> Bool
BS.null ByteString
bs = ByteString
bs
      | ByteString -> Char
BS.head ByteString
bs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' Bool -> Bool -> Bool
|| ByteString -> Char
BS.head ByteString
bs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\r' = ByteString -> ByteString
killCR (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.tail ByteString
bs
      | ByteString -> Char
BS.last ByteString
bs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' Bool -> Bool -> Bool
|| ByteString -> Char
BS.last ByteString
bs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\r' = ByteString -> ByteString
killCR (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.init ByteString
bs
      | Bool
otherwise = ByteString
bs