{-# LANGUAGE OverloadedStrings, CPP #-}

module Network.Wai.Application.Classic.Conduit (
    byteStringToBuilder
  , toResponseSource
  , parseHeader
  ) where

import Control.Applicative
import Data.Attoparsec.ByteString
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB (byteString)
import Data.CaseInsensitive (CI(..), mk)
import Data.Conduit
import Data.Conduit.Attoparsec
import qualified Data.Conduit.List as CL
import Data.Word
import Network.HTTP.Types

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

byteStringToBuilder :: ByteString -> Builder
byteStringToBuilder :: ByteString -> Builder
byteStringToBuilder = ByteString -> Builder
BB.byteString

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

#if MIN_VERSION_conduit(1,3,0)
toResponseSource :: SealedConduitT () ByteString IO ()
                 -> IO (ConduitT () (Flush Builder) IO ())
toResponseSource :: SealedConduitT () ByteString IO ()
-> IO (ConduitT () (Flush Builder) IO ())
toResponseSource SealedConduitT () ByteString IO ()
rsrc = do
    let src :: ConduitT () ByteString IO ()
src = SealedConduitT () ByteString IO () -> ConduitT () ByteString IO ()
forall (m :: * -> *) i o r.
Monad m =>
SealedConduitT i o m r -> ConduitT i o m r
unsealConduitT SealedConduitT () ByteString IO ()
rsrc
    ConduitT () (Flush Builder) IO ()
-> IO (ConduitT () (Flush Builder) IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConduitT () (Flush Builder) IO ()
 -> IO (ConduitT () (Flush Builder) IO ()))
-> ConduitT () (Flush Builder) IO ()
-> IO (ConduitT () (Flush Builder) IO ())
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString IO ()
src ConduitT () ByteString IO ()
-> ConduitT ByteString (Flush Builder) IO ()
-> ConduitT () (Flush Builder) IO ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (ByteString -> Flush Builder)
-> ConduitT ByteString (Flush Builder) IO ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (Builder -> Flush Builder
forall a. a -> Flush a
Chunk (Builder -> Flush Builder)
-> (ByteString -> Builder) -> ByteString -> Flush Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteStringToBuilder)
#else
toResponseSource :: ResumableSource IO ByteString
                 -> IO (Source IO (Flush Builder))
toResponseSource rsrc = do
    (src,_) <- unwrapResumable rsrc
    return $ src $= CL.map (Chunk . byteStringToBuilder)
#endif

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

parseHeader :: ConduitM ByteString o IO RequestHeaders
parseHeader :: forall o. ConduitM ByteString o IO RequestHeaders
parseHeader = Parser ByteString RequestHeaders
-> ConduitT ByteString o IO RequestHeaders
forall a (m :: * -> *) b o.
(AttoparsecInput a, MonadThrow m) =>
Parser a b -> ConduitT a o m b
sinkParser Parser ByteString RequestHeaders
parseHeader'

parseHeader' :: Parser RequestHeaders
parseHeader' :: Parser ByteString RequestHeaders
parseHeader' = Parser ByteString RequestHeaders
forall {a}. Parser ByteString [a]
stop Parser ByteString RequestHeaders
-> Parser ByteString RequestHeaders
-> Parser ByteString RequestHeaders
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString RequestHeaders
loop
  where
    stop :: Parser ByteString [a]
stop = [] [a] -> Parser ByteString () -> Parser ByteString [a]
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Parser ByteString ()
crlf Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput)
    loop :: Parser ByteString RequestHeaders
loop = (:) (RequestHeader -> RequestHeaders -> RequestHeaders)
-> Parser ByteString RequestHeader
-> Parser ByteString (RequestHeaders -> RequestHeaders)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString RequestHeader
keyVal Parser ByteString (RequestHeaders -> RequestHeaders)
-> Parser ByteString RequestHeaders
-> Parser ByteString RequestHeaders
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString RequestHeaders
parseHeader'

type RequestHeader = (CI ByteString, ByteString)

keyVal :: Parser RequestHeader
keyVal :: Parser ByteString RequestHeader
keyVal = do
    ByteString
key <- (Word8 -> Bool) -> Parser ByteString
takeTill (Word8
wcollonWord8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==)
    Word8
_ <- Word8 -> Parser Word8
word8 Word8
wcollon
    (Word8 -> Bool) -> Parser ByteString ()
skipWhile (Word8
wspace Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==)
    ByteString
val <- (Word8 -> Bool) -> Parser ByteString
takeTill (Word8 -> [Word8] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word8
wlf,Word8
wcr])
    Parser ByteString ()
crlf
    RequestHeader -> Parser ByteString RequestHeader
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
mk ByteString
key, ByteString
val)

crlf :: Parser ()
crlf :: Parser ByteString ()
crlf = (Parser ByteString ()
cr Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parser ByteString ()
lf Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> () -> Parser ByteString ()
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return ())) Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ()
lf

cr :: Parser ()
cr :: Parser ByteString ()
cr = () () -> Parser Word8 -> Parser ByteString ()
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Word8 -> Parser Word8
word8 Word8
wcr

lf :: Parser ()
lf :: Parser ByteString ()
lf = () () -> Parser Word8 -> Parser ByteString ()
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Word8 -> Parser Word8
word8 Word8
wlf

wcollon :: Word8
wcollon :: Word8
wcollon = Word8
58

wcr :: Word8
wcr :: Word8
wcr = Word8
13

wlf :: Word8
wlf :: Word8
wlf = Word8
10

wspace :: Word8
wspace :: Word8
wspace = Word8
32