{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables, TupleSections #-}
module Happstack.Server.Internal.Handler
( request
, parseResponse
, putRequest
) where
import qualified Paths_happstack_server as Paths
import qualified Data.Version as DV
import Control.Applicative (pure)
import Control.Concurrent (newMVar, newEmptyMVar, tryTakeMVar)
import Control.Exception.Extensible as E
import Control.Monad
import Data.List(elemIndex)
import Data.Char(toLower)
import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )
import Data.Time (UTCTime)
import Prelude hiding (last)
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Lazy.Internal (ByteString(Chunk, Empty))
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.Map as M
import Data.Int (Int64)
import Happstack.Server.Internal.Cookie
import Happstack.Server.Internal.Clock
import Happstack.Server.Internal.Types
import Happstack.Server.Internal.Multipart
import Happstack.Server.Internal.RFC822Headers
import Happstack.Server.Internal.MessageWrap
import Happstack.Server.SURI(SURI(..),path,query)
import Happstack.Server.SURI.ParseURI
import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..))
import Happstack.Server.Internal.Monads (failResponse)
import qualified Happstack.Server.Internal.TimeoutManager as TM
import Numeric
import System.Directory (removeFile)
import System.IO
import System.IO.Error (isDoesNotExistError)
request :: TimeoutIO -> Maybe (LogAccess UTCTime) -> Host -> (Request -> IO Response) -> IO ()
request :: TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> IO ()
request timeoutIO :: TimeoutIO
timeoutIO mlog :: Maybe (LogAccess UTCTime)
mlog host :: Host
host handler :: Request -> IO Response
handler =
TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> ByteString
-> IO ()
rloop TimeoutIO
timeoutIO Maybe (LogAccess UTCTime)
mlog Host
host Request -> IO Response
handler (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TimeoutIO -> IO ByteString
toGetContents TimeoutIO
timeoutIO
required :: String -> Maybe a -> Either String a
required :: String -> Maybe a -> Either String a
required err :: String
err Nothing = String -> Either String a
forall a b. a -> Either a b
Left String
err
required _ (Just a :: a
a) = a -> Either String a
forall a b. b -> Either a b
Right a
a
rloop :: TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> L.ByteString
-> IO ()
rloop :: TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> ByteString
-> IO ()
rloop timeoutIO :: TimeoutIO
timeoutIO mlog :: Maybe (LogAccess UTCTime)
mlog host :: Host
host handler :: Request -> IO Response
handler inputStr :: ByteString
inputStr
| ByteString -> Bool
L.null ByteString
inputStr = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= (IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
do let parseRequest :: Either
String
(Method, SURI, [(String, Cookie)], HttpVersion, Headers,
ByteString, ByteString)
parseRequest
= do
(topStr :: ByteString
topStr, restStr :: ByteString
restStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required "failed to separate request" (Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, ByteString)
splitAtEmptyLine ByteString
inputStr
(rql :: ByteString
rql, headerStr :: ByteString
headerStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required "failed to separate headers/body" (Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, ByteString)
splitAtCRLF ByteString
topStr
let (m :: Method
m,u :: SURI
u,v :: HttpVersion
v) = ByteString -> (Method, SURI, HttpVersion)
requestLine ByteString
rql
[Header]
headers' <- case String -> String -> Maybe [Header]
forall (m :: * -> *). MonadFail m => String -> String -> m [Header]
parseHeaders "host" (ByteString -> String
L.unpack ByteString
headerStr) of
Nothing -> String -> Either String [Header]
forall a b. a -> Either a b
Left "failed to parse host header"
Just x :: [Header]
x -> [Header] -> Either String [Header]
forall a b. b -> Either a b
Right [Header]
x
let headers :: Headers
headers = [Header] -> Headers
mkHeaders [Header]
headers'
let contentLen :: Int
contentLen = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst (ByteString -> Maybe (Int, ByteString)
P.readInt (ByteString -> Maybe (Int, ByteString))
-> Maybe ByteString -> Maybe (Int, ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> Headers -> Maybe ByteString
forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderUnsafe ByteString
contentlengthC Headers
headers)
(body :: ByteString
body, nextRequest :: ByteString
nextRequest) <- case () of
() | Int
contentLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 -> String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left "negative content-length"
| Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Headers -> Maybe ByteString
forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderBS ByteString
transferEncodingC Headers
headers ->
(ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString)
-> Either String (ByteString, ByteString))
-> (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
consumeChunks ByteString
restStr
| Bool
otherwise -> (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
contentLen) ByteString
restStr)
let cookies :: [(String, Cookie)]
cookies = [ (Cookie -> String
cookieName Cookie
c, Cookie
c) | [Cookie]
cl <- [[Cookie]] -> Maybe [[Cookie]] -> [[Cookie]]
forall a. a -> Maybe a -> a
fromMaybe [] ((ByteString -> [[Cookie]]) -> Maybe ByteString -> Maybe [[Cookie]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> [[Cookie]]
forall (m :: * -> *). MonadFail m => ByteString -> m [Cookie]
getCookies (String -> Headers -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader "Cookie" Headers
headers)), Cookie
c <- [Cookie]
cl ]
(Method, SURI, [(String, Cookie)], HttpVersion, Headers,
ByteString, ByteString)
-> Either
String
(Method, SURI, [(String, Cookie)], HttpVersion, Headers,
ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Method
m, SURI
u, [(String, Cookie)]
cookies, HttpVersion
v, Headers
headers, ByteString
body, ByteString
nextRequest)
case Either
String
(Method, SURI, [(String, Cookie)], HttpVersion, Headers,
ByteString, ByteString)
parseRequest of
Left err :: String
err -> String -> IO (IO ())
forall a. HasCallStack => String -> a
error (String -> IO (IO ())) -> String -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ "failed to parse HTTP request: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
Right (m :: Method
m, u :: SURI
u, cookies :: [(String, Cookie)]
cookies, v :: HttpVersion
v, headers :: Headers
headers, body :: ByteString
body, nextRequest :: ByteString
nextRequest)
-> IO () -> IO (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$
do MVar RqBody
bodyRef <- RqBody -> IO (MVar RqBody)
forall a. a -> IO (MVar a)
newMVar (ByteString -> RqBody
Body ByteString
body)
MVar [(String, Input)]
bodyInputRef <- IO (MVar [(String, Input)])
forall a. IO (MVar a)
newEmptyMVar
let req :: Request
req = Bool
-> Method
-> [String]
-> String
-> String
-> [(String, Input)]
-> MVar [(String, Input)]
-> [(String, Cookie)]
-> HttpVersion
-> Headers
-> MVar RqBody
-> Host
-> Request
Request (TimeoutIO -> Bool
toSecure TimeoutIO
timeoutIO) Method
m (String -> [String]
pathEls (SURI -> String
path SURI
u)) (SURI -> String
path SURI
u) (SURI -> String
query SURI
u)
(SURI -> [(String, Input)]
queryInput SURI
u) MVar [(String, Input)]
bodyInputRef [(String, Cookie)]
cookies HttpVersion
v Headers
headers MVar RqBody
bodyRef Host
host
let ioseq :: m b -> m b
ioseq act :: m b
act = m b
act m b -> (b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: b
x -> b
x b -> m b -> m b
forall a b. a -> b -> b
`seq` b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
(res :: Response
res, handlerKilled :: Bool
handlerKilled) <- ((, Bool
False) (Response -> (Response, Bool))
-> IO Response -> IO (Response, Bool)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` IO Response -> IO Response
forall (m :: * -> *) b. Monad m => m b -> m b
ioseq (Request -> IO Response
handler Request
req))
IO (Response, Bool)
-> [Handler (Response, Bool)] -> IO (Response, Bool)
forall a. IO a -> [Handler a] -> IO a
`E.catches` [ (EscapeHTTP -> IO (Response, Bool)) -> Handler (Response, Bool)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((EscapeHTTP -> IO (Response, Bool)) -> Handler (Response, Bool))
-> (EscapeHTTP -> IO (Response, Bool)) -> Handler (Response, Bool)
forall a b. (a -> b) -> a -> b
$ \(EscapeHTTP
e::EscapeHTTP) -> EscapeHTTP -> IO (Response, Bool)
forall e a. Exception e => e -> IO a
throwIO EscapeHTTP
e
, (SomeException -> IO (Response, Bool)) -> Handler (Response, Bool)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO (Response, Bool))
-> Handler (Response, Bool))
-> (SomeException -> IO (Response, Bool))
-> Handler (Response, Bool)
forall a b. (a -> b) -> a -> b
$ \(SomeException
e::E.SomeException) -> (Response, Bool) -> IO (Response, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Response
failResponse (SomeException -> String
forall a. Show a => a -> String
show SomeException
e), SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e Maybe AsyncException -> Maybe AsyncException -> Bool
forall a. Eq a => a -> a -> Bool
== AsyncException -> Maybe AsyncException
forall a. a -> Maybe a
Just AsyncException
ThreadKilled)
]
case Maybe (LogAccess UTCTime)
mlog of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Just logger :: LogAccess UTCTime
logger) ->
do UTCTime
time <- IO UTCTime
getApproximateUTCTime
let host' :: String
host' = Host -> String
forall a b. (a, b) -> a
fst Host
host
user :: String
user = "-"
requestLn :: String
requestLn = [String] -> String
unwords [Method -> String
forall a. Show a => a -> String
show (Method -> String) -> Method -> String
forall a b. (a -> b) -> a -> b
$ Request -> Method
rqMethod Request
req, Request -> String
rqUri Request
req, HttpVersion -> String
forall a. Show a => a -> String
show (HttpVersion -> String) -> HttpVersion -> String
forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
rqVersion Request
req]
responseCode :: Int
responseCode = Response -> Int
rsCode Response
res
size :: Integer
size = Integer -> (ByteString -> Integer) -> Maybe ByteString -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-1) (String -> Integer
forall a. (Num a, Eq a) => String -> a
readDec' (String -> Integer)
-> (ByteString -> String) -> ByteString -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack) (String -> Response -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader "Content-Length" Response
res)
referer :: String
referer = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe (String -> ByteString
B.pack "") (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader "Referer" Request
req
userAgent :: String
userAgent = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe (String -> ByteString
B.pack "") (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader "User-Agent" Request
req
LogAccess UTCTime
logger String
host' String
user UTCTime
time String
requestLn Int
responseCode Integer
size String
referer String
userAgent
TimeoutIO -> Request -> Response -> IO ()
putAugmentedResult TimeoutIO
timeoutIO Request
req Response
res
Request -> IO ()
cleanupTempFiles Request
req
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
handlerKilled Bool -> Bool -> Bool
&& Request -> Response -> Bool
continueHTTP Request
req Response
res) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
TimeoutIO
-> Maybe (LogAccess UTCTime)
-> Host
-> (Request -> IO Response)
-> ByteString
-> IO ()
rloop TimeoutIO
timeoutIO Maybe (LogAccess UTCTime)
mlog Host
host Request -> IO Response
handler ByteString
nextRequest) IO () -> (EscapeHTTP -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (TimeoutIO -> EscapeHTTP -> IO ()
escapeHttpHandler TimeoutIO
timeoutIO)
escapeHttpHandler :: TimeoutIO
-> EscapeHTTP
-> IO ()
escapeHttpHandler :: TimeoutIO -> EscapeHTTP -> IO ()
escapeHttpHandler tio :: TimeoutIO
tio (EscapeHTTP f :: TimeoutIO -> IO ()
f) = TimeoutIO -> IO ()
f TimeoutIO
tio
cleanupTempFiles :: Request -> IO ()
cleanupTempFiles :: Request -> IO ()
cleanupTempFiles req :: Request
req =
do Maybe [(String, Input)]
mInputs <- MVar [(String, Input)] -> IO (Maybe [(String, Input)])
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req)
case Maybe [(String, Input)]
mInputs of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Just inputs :: [(String, Input)]
inputs) -> ((String, Input) -> IO ()) -> [(String, Input)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, Input) -> IO ()
deleteTmpFile [(String, Input)]
inputs
where
deleteTmpFile :: (String, Input) -> IO ()
deleteTmpFile :: (String, Input) -> IO ()
deleteTmpFile (_, input :: Input
input) =
case Input -> Either String ByteString
inputValue Input
input of
(Left fp :: String
fp) -> (IOError -> Maybe ()) -> IO () -> (() -> IO ()) -> IO ()
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
E.catchJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (String -> IO ()
removeFile String
fp) (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
parseResponse :: L.ByteString -> Either String Response
parseResponse :: ByteString -> Either String Response
parseResponse inputStr :: ByteString
inputStr =
do (topStr :: ByteString
topStr,restStr :: ByteString
restStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required "failed to separate response" (Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
ByteString -> Maybe (ByteString, ByteString)
splitAtEmptyLine ByteString
inputStr
(rsl :: ByteString
rsl,headerStr :: ByteString
headerStr) <- String
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a. String -> Maybe a -> Either String a
required "failed to separate headers/body" (Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$
ByteString -> Maybe (ByteString, ByteString)
splitAtCRLF ByteString
topStr
let (_,code :: Int
code) = ByteString -> (ByteString, Int)
responseLine ByteString
rsl
[Header]
headers' <- case String -> String -> Maybe [Header]
forall (m :: * -> *). MonadFail m => String -> String -> m [Header]
parseHeaders "host" (ByteString -> String
L.unpack ByteString
headerStr) of
Nothing -> String -> Either String [Header]
forall a b. a -> Either a b
Left "failed to parse host header"
Just x :: [Header]
x -> [Header] -> Either String [Header]
forall a b. b -> Either a b
Right [Header]
x
let headers :: Headers
headers = [Header] -> Headers
mkHeaders [Header]
headers'
let mbCL :: Maybe Int
mbCL = ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst (ByteString -> Maybe (Int, ByteString)
B.readInt (ByteString -> Maybe (Int, ByteString))
-> Maybe ByteString -> Maybe (Int, ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Headers -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader "content-length" Headers
headers)
(body :: ByteString
body,_) <-
Either String (ByteString, ByteString)
-> (Int -> Either String (ByteString, ByteString))
-> Maybe Int
-> Either String (ByteString, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Headers -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader "transfer-encoding" Headers
headers)
then (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
restStr,String -> ByteString
L.pack "")
else (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString, ByteString)
-> Either String (ByteString, ByteString))
-> (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
consumeChunks ByteString
restStr)
(\cl :: Int
cl->(ByteString, ByteString) -> Either String (ByteString, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cl) ByteString
restStr))
Maybe Int
mbCL
Response -> Either String Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Either String Response)
-> Response -> Either String Response
forall a b. (a -> b) -> a -> b
$ Response :: Int
-> Headers
-> RsFlags
-> ByteString
-> Maybe (Response -> IO Response)
-> Response
Response {rsCode :: Int
rsCode=Int
code,rsHeaders :: Headers
rsHeaders=Headers
headers,rsBody :: ByteString
rsBody=ByteString
body,rsFlags :: RsFlags
rsFlags=Length -> RsFlags
RsFlags Length
ContentLength,rsValidator :: Maybe (Response -> IO Response)
rsValidator=Maybe (Response -> IO Response)
forall a. Maybe a
Nothing}
consumeChunks::L.ByteString->(L.ByteString,L.ByteString)
consumeChunks :: ByteString -> (ByteString, ByteString)
consumeChunks str :: ByteString
str = let (parts :: [(Int64, ByteString)]
parts,tr :: ByteString
tr,rest :: ByteString
rest) = ByteString -> ([(Int64, ByteString)], ByteString, ByteString)
consumeChunksImpl ByteString
str in ([ByteString] -> ByteString
L.concat ([ByteString] -> ByteString)
-> ([(Int64, ByteString)] -> [ByteString])
-> [(Int64, ByteString)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString
tr]) ([ByteString] -> [ByteString])
-> ([(Int64, ByteString)] -> [ByteString])
-> [(Int64, ByteString)]
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Int64, ByteString) -> ByteString)
-> [(Int64, ByteString)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (Int64, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ([(Int64, ByteString)] -> ByteString)
-> [(Int64, ByteString)] -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Int64, ByteString)]
parts,ByteString
rest)
consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)
consumeChunksImpl :: ByteString -> ([(Int64, ByteString)], ByteString, ByteString)
consumeChunksImpl str :: ByteString
str
| ByteString -> Bool
L.null ByteString
str = ([],ByteString
L.empty,ByteString
str)
| Int64
chunkLen Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = let (last :: ByteString
last,rest' :: ByteString
rest') = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
lenLine1 ByteString
str
(tr' :: ByteString
tr',rest'' :: ByteString
rest'') = ByteString -> (ByteString, ByteString)
getTrailer ByteString
rest'
in ([(0,ByteString
last)],ByteString
tr',ByteString
rest'')
| Bool
otherwise = ((Int64
chunkLen,ByteString
part)(Int64, ByteString)
-> [(Int64, ByteString)] -> [(Int64, ByteString)]
forall a. a -> [a] -> [a]
:[(Int64, ByteString)]
crest,ByteString
tr,ByteString
rest2)
where
line1 :: ByteString
line1 = [ByteString] -> ByteString
forall a. [a] -> a
head ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
lazylines ByteString
str
lenLine1 :: Int64
lenLine1 = (ByteString -> Int64
L.length ByteString
line1) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ 1
chunkLen :: Int64
chunkLen = ((Int64, String) -> Int64
forall a b. (a, b) -> a
fst ((Int64, String) -> Int64) -> (Int64, String) -> Int64
forall a b. (a -> b) -> a -> b
$ [(Int64, String)] -> (Int64, String)
forall a. [a] -> a
head ([(Int64, String)] -> (Int64, String))
-> [(Int64, String)] -> (Int64, String)
forall a b. (a -> b) -> a -> b
$ ReadS Int64
forall a. (Eq a, Num a) => ReadS a
readHex ReadS Int64 -> ReadS Int64
forall a b. (a -> b) -> a -> b
$ ByteString -> String
L.unpack ByteString
line1)
len :: Int64
len = Int64
chunkLen Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
lenLine1 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ 2
(part :: ByteString
part,rest :: ByteString
rest) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
len ByteString
str
(crest :: [(Int64, ByteString)]
crest,tr :: ByteString
tr,rest2 :: ByteString
rest2) = ByteString -> ([(Int64, ByteString)], ByteString, ByteString)
consumeChunksImpl ByteString
rest
getTrailer :: ByteString -> (ByteString, ByteString)
getTrailer s :: ByteString
s = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
index ByteString
s
where index :: Int64
index | ByteString
crlfLC ByteString -> ByteString -> Bool
`L.isPrefixOf` ByteString
s = 2
| Bool
otherwise = let iscrlf :: [Bool]
iscrlf = (Char -> Char -> Bool) -> ByteString -> ByteString -> [Bool]
forall a. (Char -> Char -> a) -> ByteString -> ByteString -> [a]
L.zipWith (\a :: Char
a b :: Char
b -> Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\r' Bool -> Bool -> Bool
&& Char
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n') ByteString
s (ByteString -> [Bool])
-> (ByteString -> ByteString) -> ByteString -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.tail (ByteString -> [Bool]) -> ByteString -> [Bool]
forall a b. (a -> b) -> a -> b
$ ByteString
s
Just i :: Int
i = Bool -> [Bool] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Bool
True ([Bool] -> Maybe Int) -> [Bool] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool -> Bool) -> [Bool] -> [Bool] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&) [Bool]
iscrlf ([Bool] -> [Bool]
forall a. [a] -> [a]
tail ([Bool] -> [Bool]
forall a. [a] -> [a]
tail [Bool]
iscrlf))
in Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+4
crlfLC :: L.ByteString
crlfLC :: ByteString
crlfLC = String -> ByteString
L.pack "\r\n"
lazylines :: L.ByteString -> [L.ByteString]
lazylines :: ByteString -> [ByteString]
lazylines s :: ByteString
s
| ByteString -> Bool
L.null ByteString
s = []
| Bool
otherwise =
let (l :: ByteString
l,s' :: ByteString
s') = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
L.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) '\n') ByteString
s
in ByteString
l ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: if ByteString -> Bool
L.null ByteString
s' then []
else ByteString -> [ByteString]
lazylines (ByteString -> ByteString
L.tail ByteString
s')
requestLine :: L.ByteString -> (Method, SURI, HttpVersion)
requestLine :: ByteString -> (Method, SURI, HttpVersion)
requestLine l :: ByteString
l = case ByteString -> [ByteString]
P.words (([ByteString] -> ByteString
P.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks) ByteString
l) of
[rq :: ByteString
rq,uri :: ByteString
uri,ver :: ByteString
ver] -> (ByteString -> Method
method ByteString
rq, URI -> SURI
SURI (URI -> SURI) -> URI -> SURI
forall a b. (a -> b) -> a -> b
$ ByteString -> URI
parseURIRef ByteString
uri, ByteString -> HttpVersion
version ByteString
ver)
[rq :: ByteString
rq,uri :: ByteString
uri] -> (ByteString -> Method
method ByteString
rq, URI -> SURI
SURI (URI -> SURI) -> URI -> SURI
forall a b. (a -> b) -> a -> b
$ ByteString -> URI
parseURIRef ByteString
uri,Int -> Int -> HttpVersion
HttpVersion 0 9)
x :: [ByteString]
x -> String -> (Method, SURI, HttpVersion)
forall a. HasCallStack => String -> a
error (String -> (Method, SURI, HttpVersion))
-> String -> (Method, SURI, HttpVersion)
forall a b. (a -> b) -> a -> b
$ "requestLine cannot handle input: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([ByteString] -> String
forall a. Show a => a -> String
show [ByteString]
x)
responseLine :: L.ByteString -> (B.ByteString, Int)
responseLine :: ByteString -> (ByteString, Int)
responseLine l :: ByteString
l = case ByteString -> [ByteString]
B.words (([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks) ByteString
l) of
(v :: ByteString
v:c :: ByteString
c:_) -> ByteString -> HttpVersion
version ByteString
v HttpVersion -> (ByteString, Int) -> (ByteString, Int)
forall a b. a -> b -> b
`seq` (ByteString
v,(Int, ByteString) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, ByteString) -> (Int, ByteString)
forall a. HasCallStack => Maybe a -> a
fromJust (ByteString -> Maybe (Int, ByteString)
B.readInt ByteString
c)))
x :: [ByteString]
x -> String -> (ByteString, Int)
forall a. HasCallStack => String -> a
error (String -> (ByteString, Int)) -> String -> (ByteString, Int)
forall a b. (a -> b) -> a -> b
$ "responseLine cannot handle input: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([ByteString] -> String
forall a. Show a => a -> String
show [ByteString]
x)
method :: B.ByteString -> Method
method :: ByteString -> Method
method r :: ByteString
r = Maybe Method -> Method
fj (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
r [(ByteString, Method)]
mtable
where fj :: Maybe Method -> Method
fj (Just x :: Method
x) = Method
x
fj Nothing = ByteString -> Method
EXTENSION ByteString
r
mtable :: [(ByteString, Method)]
mtable = [ (String -> ByteString
P.pack "GET", Method
GET)
, (String -> ByteString
P.pack "HEAD", Method
HEAD)
, (String -> ByteString
P.pack "POST", Method
POST)
, (String -> ByteString
P.pack "PUT", Method
PUT)
, (String -> ByteString
P.pack "DELETE", Method
DELETE)
, (String -> ByteString
P.pack "TRACE", Method
TRACE)
, (String -> ByteString
P.pack "OPTIONS", Method
OPTIONS)
, (String -> ByteString
P.pack "CONNECT", Method
CONNECT)
, (String -> ByteString
P.pack "PATCH", Method
PATCH)
]
staticHeaders :: Headers
=
((ByteString, ByteString) -> Headers -> Headers)
-> Headers -> [(ByteString, ByteString)] -> Headers
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ByteString -> ByteString -> Headers -> Headers)
-> (ByteString, ByteString) -> Headers -> Headers
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Headers -> Headers
forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS) ([Header] -> Headers
mkHeaders [])
[ (ByteString
serverC, ByteString
happstackC) ]
putAugmentedResult :: TimeoutIO -> Request -> Response -> IO ()
putAugmentedResult :: TimeoutIO -> Request -> Response -> IO ()
putAugmentedResult timeoutIO :: TimeoutIO
timeoutIO req :: Request
req res :: Response
res = do
case Response
res of
Response {} -> do
let isChunked :: Bool
isChunked = RsFlags -> Length
rsfLength (Response -> RsFlags
rsFlags Response
res) Length -> Length -> Bool
forall a. Eq a => a -> a -> Bool
== Length
TransferEncodingChunked Bool -> Bool -> Bool
&& Request -> Bool
isHTTP1_1 Request
req
Maybe Integer -> Bool -> IO ()
sendTop (if Bool
isChunked then Maybe Integer
forall a. Maybe a
Nothing else (Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
L.length (Response -> ByteString
rsBody Response
res))))) Bool
isChunked
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Request -> Method
rqMethod Request
req Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
/= Method
HEAD)
(let body :: ByteString
body = if Bool
isChunked
then ByteString -> ByteString
chunk (Response -> ByteString
rsBody Response
res)
else Response -> ByteString
rsBody Response
res
in TimeoutIO -> ByteString -> IO ()
toPutLazy TimeoutIO
timeoutIO ByteString
body)
SendFile {} -> do
let infp :: String
infp = Response -> String
sfFilePath Response
res
off :: Integer
off = Response -> Integer
sfOffset Response
res
count :: Integer
count = Response -> Integer
sfCount Response
res
Maybe Integer -> Bool -> IO ()
sendTop (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
count) Bool
False
Handle -> IO ()
TM.tickle (TimeoutIO -> Handle
toHandle TimeoutIO
timeoutIO)
TimeoutIO -> String -> Integer -> Integer -> IO ()
toSendFile TimeoutIO
timeoutIO String
infp Integer
off Integer
count
where ph :: HeaderPair -> [ByteString]
ph (HeaderPair k :: ByteString
k vs :: [ByteString]
vs) = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\v :: ByteString
v -> [ByteString] -> ByteString
P.concat [ByteString
k, ByteString
fsepC, ByteString
v, ByteString
crlfC]) [ByteString]
vs
sendTop :: Maybe Integer -> Bool -> IO ()
sendTop cl :: Maybe Integer
cl isChunked :: Bool
isChunked = do
Headers
allHeaders <- Request -> Response -> Maybe Integer -> Bool -> IO Headers
augmentHeaders Request
req Response
res Maybe Integer
cl Bool
isChunked
TimeoutIO -> ByteString -> IO ()
toPut TimeoutIO
timeoutIO (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ (HttpVersion -> [ByteString]
pversion (HttpVersion -> [ByteString]) -> HttpVersion -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
rqVersion Request
req)
, [Int -> ByteString
forall t. (Num t, Show t, Eq t) => t -> ByteString
responseMessage (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Response -> Int
rsCode Response
res]
, (HeaderPair -> [ByteString]) -> [HeaderPair] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderPair -> [ByteString]
ph (Headers -> [HeaderPair]
forall k a. Map k a -> [a]
M.elems Headers
allHeaders)
, [ByteString
crlfC]
]
Handle -> IO ()
TM.tickle (TimeoutIO -> Handle
toHandle TimeoutIO
timeoutIO)
chunk :: L.ByteString -> L.ByteString
chunk :: ByteString -> ByteString
chunk Empty = String -> ByteString
LC.pack "0\r\n\r\n"
chunk (Chunk c :: ByteString
c cs :: ByteString
cs) = ByteString -> ByteString -> ByteString
Chunk (String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex (ByteString -> Int
B.length ByteString
c) "\r\n") (ByteString -> ByteString -> ByteString
Chunk ByteString
c (ByteString -> ByteString -> ByteString
Chunk (String -> ByteString
B.pack "\r\n") (ByteString -> ByteString
chunk ByteString
cs)))
augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers
req :: Request
req res :: Response
res mcl :: Maybe Integer
mcl isChunked :: Bool
isChunked = do
ByteString
raw <- IO ByteString
getApproximateTime
let stdHeaders :: Headers
stdHeaders = Headers
staticHeaders Headers -> Headers -> Headers
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union`
[(ByteString, HeaderPair)] -> Headers
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ( [ (ByteString
dateCLower, ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
dateC [ByteString
raw])
, (ByteString
connectionCLower, ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
connectionC [if Request -> Response -> Bool
continueHTTP Request
req Response
res then ByteString
keepAliveC else ByteString
closeC])
] [(ByteString, HeaderPair)]
-> [(ByteString, HeaderPair)] -> [(ByteString, HeaderPair)]
forall a. [a] -> [a] -> [a]
++ case RsFlags -> Length
rsfLength (Response -> RsFlags
rsFlags Response
res) of
NoContentLength -> []
ContentLength | Bool -> Bool
not (String -> Response -> Bool
forall r. HasHeaders r => String -> r -> Bool
hasHeader "Content-Length" Response
res) ->
case Maybe Integer
mcl of
(Just cl :: Integer
cl) -> [(ByteString
contentlengthC, ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
contentLengthC [String -> ByteString
P.pack (Integer -> String
forall a. Show a => a -> String
show Integer
cl)])]
_ -> []
| Bool
otherwise -> []
TransferEncodingChunked
| Bool
isChunked -> [(ByteString
transferEncodingC, ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
transferEncodingC [ByteString
chunkedC])]
| Bool
otherwise -> []
)
Headers -> IO Headers
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Headers
rsHeaders Response
res Headers -> Headers -> Headers
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Headers
stdHeaders)
putRequest :: Handle -> Request -> IO ()
putRequest :: Handle -> Request -> IO ()
putRequest h :: Handle
h rq :: Request
rq = do
let put :: ByteString -> IO ()
put = Handle -> ByteString -> IO ()
B.hPut Handle
h
ph :: HeaderPair -> [ByteString]
ph (HeaderPair k :: ByteString
k vs :: [ByteString]
vs) = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\v :: ByteString
v -> [ByteString] -> ByteString
B.concat [ByteString
k, ByteString
fsepC, ByteString
v, ByteString
crlfC]) [ByteString]
vs
sp :: [ByteString]
sp = [String -> ByteString
B.pack " "]
(ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
put ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[[String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Method -> String
forall a. Show a => a -> String
show (Method -> String) -> Method -> String
forall a b. (a -> b) -> a -> b
$ Request -> Method
rqMethod Request
rq],[ByteString]
sp
,[String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Request -> String
rqURL Request
rq],[ByteString]
sp
,(HttpVersion -> [ByteString]
pversion (HttpVersion -> [ByteString]) -> HttpVersion -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
rqVersion Request
rq), [ByteString
crlfC]
,(HeaderPair -> [ByteString]) -> [HeaderPair] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderPair -> [ByteString]
ph (Headers -> [HeaderPair]
forall k a. Map k a -> [a]
M.elems (Headers -> [HeaderPair]) -> Headers -> [HeaderPair]
forall a b. (a -> b) -> a -> b
$ Request -> Headers
rqHeaders Request
rq)
,[ByteString
crlfC]
]
Maybe RqBody
mBody <- Request -> IO (Maybe RqBody)
forall (m :: * -> *). MonadIO m => Request -> m (Maybe RqBody)
takeRequestBody Request
rq
Handle -> ByteString -> IO ()
L.hPut Handle
h (ByteString -> (RqBody -> ByteString) -> Maybe RqBody -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
L.empty RqBody -> ByteString
unBody Maybe RqBody
mBody)
Handle -> IO ()
hFlush Handle
h
pversion :: HttpVersion -> [B.ByteString]
pversion :: HttpVersion -> [ByteString]
pversion (HttpVersion 1 1) = [ByteString
http11]
pversion (HttpVersion 1 0) = [ByteString
http10]
pversion (HttpVersion x :: Int
x y :: Int
y) = [String -> ByteString
P.pack "HTTP/", String -> ByteString
P.pack (Int -> String
forall a. Show a => a -> String
show Int
x), String -> ByteString
P.pack ".", String -> ByteString
P.pack (Int -> String
forall a. Show a => a -> String
show Int
y)]
version :: B.ByteString -> HttpVersion
version :: ByteString -> HttpVersion
version x :: ByteString
x | ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
http09 = Int -> Int -> HttpVersion
HttpVersion 0 9
| ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
http10 = Int -> Int -> HttpVersion
HttpVersion 1 0
| ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
http11 = Int -> Int -> HttpVersion
HttpVersion 1 1
| Bool
otherwise = String -> HttpVersion
forall a. HasCallStack => String -> a
error "Invalid HTTP version"
http09 :: B.ByteString
http09 :: ByteString
http09 = String -> ByteString
P.pack "HTTP/0.9"
http10 :: B.ByteString
http10 :: ByteString
http10 = String -> ByteString
P.pack "HTTP/1.0"
http11 :: B.ByteString
http11 :: ByteString
http11 = String -> ByteString
P.pack "HTTP/1.1"
connectionC :: B.ByteString
connectionC :: ByteString
connectionC = String -> ByteString
P.pack "Connection"
connectionCLower :: B.ByteString
connectionCLower :: ByteString
connectionCLower = (Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower ByteString
connectionC
closeC :: B.ByteString
closeC :: ByteString
closeC = String -> ByteString
P.pack "close"
keepAliveC :: B.ByteString
keepAliveC :: ByteString
keepAliveC = String -> ByteString
P.pack "Keep-Alive"
crlfC :: B.ByteString
crlfC :: ByteString
crlfC = String -> ByteString
P.pack "\r\n"
fsepC :: B.ByteString
fsepC :: ByteString
fsepC = String -> ByteString
P.pack ": "
contentLengthC :: B.ByteString
contentLengthC :: ByteString
contentLengthC = String -> ByteString
P.pack "Content-Length"
contentlengthC :: B.ByteString
contentlengthC :: ByteString
contentlengthC = String -> ByteString
P.pack "content-length"
dateC :: B.ByteString
dateC :: ByteString
dateC = String -> ByteString
P.pack "Date"
dateCLower :: B.ByteString
dateCLower :: ByteString
dateCLower = (Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower ByteString
dateC
serverC :: B.ByteString
serverC :: ByteString
serverC = String -> ByteString
P.pack "Server"
happstackC :: B.ByteString
happstackC :: ByteString
happstackC = String -> ByteString
P.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ "Happstack/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
DV.showVersion Version
Paths.version
transferEncodingC :: B.ByteString
transferEncodingC :: ByteString
transferEncodingC = String -> ByteString
P.pack "Transfer-Encoding"
chunkedC :: B.ByteString
chunkedC :: ByteString
chunkedC = String -> ByteString
P.pack "chunked"
responseMessage :: (Num t, Show t, Eq t) => t -> B.ByteString
responseMessage :: t -> ByteString
responseMessage 100 = String -> ByteString
P.pack " 100 Continue\r\n"
responseMessage 101 = String -> ByteString
P.pack " 101 Switching Protocols\r\n"
responseMessage 200 = String -> ByteString
P.pack " 200 OK\r\n"
responseMessage 201 = String -> ByteString
P.pack " 201 Created\r\n"
responseMessage 202 = String -> ByteString
P.pack " 202 Accepted\r\n"
responseMessage 203 = String -> ByteString
P.pack " 203 Non-Authoritative Information\r\n"
responseMessage 204 = String -> ByteString
P.pack " 204 No Content\r\n"
responseMessage 205 = String -> ByteString
P.pack " 205 Reset Content\r\n"
responseMessage 206 = String -> ByteString
P.pack " 206 Partial Content\r\n"
responseMessage 300 = String -> ByteString
P.pack " 300 Multiple Choices\r\n"
responseMessage 301 = String -> ByteString
P.pack " 301 Moved Permanently\r\n"
responseMessage 302 = String -> ByteString
P.pack " 302 Found\r\n"
responseMessage 303 = String -> ByteString
P.pack " 303 See Other\r\n"
responseMessage 304 = String -> ByteString
P.pack " 304 Not Modified\r\n"
responseMessage 305 = String -> ByteString
P.pack " 305 Use Proxy\r\n"
responseMessage 307 = String -> ByteString
P.pack " 307 Temporary Redirect\r\n"
responseMessage 400 = String -> ByteString
P.pack " 400 Bad Request\r\n"
responseMessage 401 = String -> ByteString
P.pack " 401 Unauthorized\r\n"
responseMessage 402 = String -> ByteString
P.pack " 402 Payment Required\r\n"
responseMessage 403 = String -> ByteString
P.pack " 403 Forbidden\r\n"
responseMessage 404 = String -> ByteString
P.pack " 404 Not Found\r\n"
responseMessage 405 = String -> ByteString
P.pack " 405 Method Not Allowed\r\n"
responseMessage 406 = String -> ByteString
P.pack " 406 Not Acceptable\r\n"
responseMessage 407 = String -> ByteString
P.pack " 407 Proxy Authentication Required\r\n"
responseMessage 408 = String -> ByteString
P.pack " 408 Request Time-out\r\n"
responseMessage 409 = String -> ByteString
P.pack " 409 Conflict\r\n"
responseMessage 410 = String -> ByteString
P.pack " 410 Gone\r\n"
responseMessage 411 = String -> ByteString
P.pack " 411 Length Required\r\n"
responseMessage 412 = String -> ByteString
P.pack " 412 Precondition Failed\r\n"
responseMessage 413 = String -> ByteString
P.pack " 413 Request Entity Too Large\r\n"
responseMessage 414 = String -> ByteString
P.pack " 414 Request-URI Too Large\r\n"
responseMessage 415 = String -> ByteString
P.pack " 415 Unsupported Media Type\r\n"
responseMessage 416 = String -> ByteString
P.pack " 416 Requested range not satisfiable\r\n"
responseMessage 417 = String -> ByteString
P.pack " 417 Expectation Failed\r\n"
responseMessage 500 = String -> ByteString
P.pack " 500 Internal Server Error\r\n"
responseMessage 501 = String -> ByteString
P.pack " 501 Not Implemented\r\n"
responseMessage 502 = String -> ByteString
P.pack " 502 Bad Gateway\r\n"
responseMessage 503 = String -> ByteString
P.pack " 503 Service Unavailable\r\n"
responseMessage 504 = String -> ByteString
P.pack " 504 Gateway Time-out\r\n"
responseMessage 505 = String -> ByteString
P.pack " 505 HTTP Version not supported\r\n"
responseMessage x :: t
x = String -> ByteString
P.pack (" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ " \r\n")