{-# 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 Maybe (LogAccess UTCTime)
mlog Host
host 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 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 :: forall a. String -> Maybe a -> Either String a
required String
err Maybe a
Nothing  = forall a b. a -> Either a b
Left String
err
required String
_   (Just a
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 Maybe (LogAccess UTCTime)
mlog Host
host Request -> IO Response
handler ByteString
inputStr
    | ByteString -> Bool
L.null ByteString
inputStr = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise
    = (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
      do let parseRequest :: Either
  String
  (Method, SURI, [(String, Cookie)], HttpVersion, Headers,
   ByteString, ByteString)
parseRequest
                 = do
                      (ByteString
topStr, ByteString
restStr) <- forall a. String -> Maybe a -> Either String a
required String
"failed to separate request" forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, ByteString)
splitAtEmptyLine ByteString
inputStr
                      (ByteString
rql, ByteString
headerStr)  <- forall a. String -> Maybe a -> Either String a
required String
"failed to separate headers/body" forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, ByteString)
splitAtCRLF ByteString
topStr
                      let (Method
m,SURI
u,HttpVersion
v) = ByteString -> (Method, SURI, HttpVersion)
requestLine ByteString
rql
                      [Header]
headers' <- case forall (m :: * -> *). MonadFail m => String -> String -> m [Header]
parseHeaders String
"host" (ByteString -> String
L.unpack ByteString
headerStr) of
                        Maybe [Header]
Nothing -> forall a b. a -> Either a b
Left String
"failed to parse host header"
                        Just [Header]
x -> forall a b. b -> Either a b
Right [Header]
x
                      let headers :: Headers
headers = [Header] -> Headers
mkHeaders [Header]
headers'
                      let contentLen :: Int
contentLen = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (ByteString -> Maybe (Int, ByteString)
P.readInt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderUnsafe ByteString
contentlengthC Headers
headers)
                      (ByteString
body, ByteString
nextRequest) <- case () of
                          () | Int
contentLen forall a. Ord a => a -> a -> Bool
< Int
0               -> forall a b. a -> Either a b
Left String
"negative content-length"
                             | forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderBS ByteString
transferEncodingC Headers
headers ->
                                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
consumeChunks ByteString
restStr
                             | Bool
otherwise                       -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (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 <- forall a. a -> Maybe a -> a
fromMaybe [] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). MonadFail m => ByteString -> m [Cookie]
getCookies (forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"Cookie" Headers
headers)), Cookie
c <- [Cookie]
cl ] -- Ugle
                      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 String
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"failed to parse HTTP request: " forall a. [a] -> [a] -> [a]
++ String
err
           Right (Method
m, SURI
u, [(String, Cookie)]
cookies, HttpVersion
v, Headers
headers, ByteString
body, ByteString
nextRequest)
              -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                  do MVar RqBody
bodyRef        <- forall a. a -> IO (MVar a)
newMVar (ByteString -> RqBody
Body ByteString
body)
                     MVar [(String, Input)]
bodyInputRef   <- 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 m b
act = m b
act forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
x -> b
x seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return b
x

                     (Response
res, Bool
handlerKilled) <- ((, Bool
False) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall {m :: * -> *} {b}. Monad m => m b -> m b
ioseq (Request -> IO Response
handler Request
req))
                         forall a. IO a -> [Handler a] -> IO a
`E.catches` [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(EscapeHTTP
e::EscapeHTTP)      -> forall e a. Exception e => e -> IO a
throwIO EscapeHTTP
e -- need to handle this higher up
                                     , forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(SomeException
e::E.SomeException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Response
failResponse (forall a. Show a => a -> String
show SomeException
e), forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just AsyncException
ThreadKilled)
                                     ]

                     case Maybe (LogAccess UTCTime)
mlog of
                       Maybe (LogAccess UTCTime)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                       (Just LogAccess UTCTime
logger) ->
                           do UTCTime
time <- IO UTCTime
getApproximateUTCTime
                              let host' :: String
host'        = forall a b. (a, b) -> a
fst Host
host
                                  user :: String
user         = String
"-"
                                  requestLn :: String
requestLn    = [String] -> String
unwords [forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Request -> Method
rqMethod Request
req, Request -> String
rqUri Request
req, forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
rqVersion Request
req]
                                  responseCode :: Int
responseCode = Response -> Int
rsCode Response
res
                                  size :: Integer
size         = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Integer
1) (forall a. (Num a, Eq a) => String -> a
readDec' forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack) (forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"Content-Length" Response
res) -- -1 indicates unknown size
                                  referer :: String
referer      = ByteString -> String
B.unpack forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (String -> ByteString
B.pack String
"") forall a b. (a -> b) -> a -> b
$ forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"Referer" Request
req
                                  userAgent :: String
userAgent    = ByteString -> String
B.unpack forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (String -> ByteString
B.pack String
"") forall a b. (a -> b) -> a -> b
$ forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"User-Agent" Request
req
                              LogAccess UTCTime
logger String
host' String
user UTCTime
time String
requestLn Int
responseCode Integer
size String
referer String
userAgent

                     -- withNoPush sock $ putAugmentedResult thandle sock req res
                     TimeoutIO -> Request -> Response -> IO ()
putAugmentedResult TimeoutIO
timeoutIO Request
req Response
res
                     -- clean up tmp files
                     Request -> IO ()
cleanupTempFiles Request
req
                     -- do not continue if handler was killed
                     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
handlerKilled Bool -> Bool -> Bool
&& Request -> Response -> Bool
continueHTTP Request
req Response
res) 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) 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 TimeoutIO
tio (EscapeHTTP TimeoutIO -> IO ()
f) = TimeoutIO -> IO ()
f TimeoutIO
tio

-- NOTE: if someone took the inputs and never put them back, then they are responsible for the cleanup
cleanupTempFiles :: Request -> IO ()
cleanupTempFiles :: Request -> IO ()
cleanupTempFiles Request
req =
    do Maybe [(String, Input)]
mInputs <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req)
       case Maybe [(String, Input)]
mInputs of
         Maybe [(String, Input)]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
         (Just [(String, Input)]
inputs) -> 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 (String
_, Input
input) =
          case Input -> Either String ByteString
inputValue Input
input of
            (Left String
fp) -> forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
E.catchJust (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (String -> IO ()
removeFile String
fp)  (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())
            Either String ByteString
_         -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Unserializes the bytestring into a response.  If there is an
-- error it will return @Left msg@.
parseResponse :: L.ByteString -> Either String Response
parseResponse :: ByteString -> Either String Response
parseResponse ByteString
inputStr =
    do (ByteString
topStr,ByteString
restStr) <- forall a. String -> Maybe a -> Either String a
required String
"failed to separate response" forall a b. (a -> b) -> a -> b
$
                           ByteString -> Maybe (ByteString, ByteString)
splitAtEmptyLine ByteString
inputStr
       (ByteString
rsl,ByteString
headerStr) <- forall a. String -> Maybe a -> Either String a
required String
"failed to separate headers/body" forall a b. (a -> b) -> a -> b
$
                          ByteString -> Maybe (ByteString, ByteString)
splitAtCRLF ByteString
topStr
       let (ByteString
_,Int
code) = ByteString -> (ByteString, Int)
responseLine ByteString
rsl
       [Header]
headers' <- case forall (m :: * -> *). MonadFail m => String -> String -> m [Header]
parseHeaders String
"host" (ByteString -> String
L.unpack ByteString
headerStr) of
         Maybe [Header]
Nothing -> forall a b. a -> Either a b
Left String
"failed to parse host header"
         Just [Header]
x -> forall a b. b -> Either a b
Right [Header]
x
       let headers :: Headers
headers = [Header] -> Headers
mkHeaders [Header]
headers'
       let mbCL :: Maybe Int
mbCL = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (ByteString -> Maybe (Int, ByteString)
B.readInt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"content-length" Headers
headers)
       (ByteString
body,ByteString
_) <-
           forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"transfer-encoding" Headers
headers)
                       then  forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
restStr,String -> ByteString
L.pack String
"")
                       else  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
consumeChunks ByteString
restStr)
                 (\Int
cl->forall (m :: * -> *) a. Monad m => a -> m a
return (Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cl) ByteString
restStr))
                 Maybe Int
mbCL
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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=forall a. Maybe a
Nothing}

-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html
-- note this does NOT handle extenions
consumeChunks::L.ByteString->(L.ByteString,L.ByteString)
consumeChunks :: ByteString -> (ByteString, ByteString)
consumeChunks ByteString
str = let ([(Int64, ByteString)]
parts,ByteString
tr,ByteString
rest) = ByteString -> ([(Int64, ByteString)], ByteString, ByteString)
consumeChunksImpl ByteString
str in ([ByteString] -> ByteString
L.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ [ByteString
tr]) forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd 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 ByteString
str
    | ByteString -> Bool
L.null ByteString
str = ([],ByteString
L.empty,ByteString
str)
    | Int64
chunkLen forall a. Eq a => a -> a -> Bool
== Int64
0 = let (ByteString
last,ByteString
rest') = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
lenLine1 ByteString
str
                          (ByteString
tr',ByteString
rest'') = ByteString -> (ByteString, ByteString)
getTrailer ByteString
rest'
                      in ([(Int64
0,ByteString
last)],ByteString
tr',ByteString
rest'')
    | Bool
otherwise = ((Int64
chunkLen,ByteString
part)forall a. a -> [a] -> [a]
:[(Int64, ByteString)]
crest,ByteString
tr,ByteString
rest2)
    where
      line1 :: ByteString
line1 = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
lazylines ByteString
str
      lenLine1 :: Int64
lenLine1 = (ByteString -> Int64
L.length ByteString
line1) forall a. Num a => a -> a -> a
+ Int64
1 -- endchar
      chunkLen :: Int64
chunkLen = (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Num a) => ReadS a
readHex forall a b. (a -> b) -> a -> b
$ ByteString -> String
L.unpack ByteString
line1)
      len :: Int64
len = Int64
chunkLen forall a. Num a => a -> a -> a
+ Int64
lenLine1 forall a. Num a => a -> a -> a
+ Int64
2
      (ByteString
part,ByteString
rest) = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
len ByteString
str
      ([(Int64, ByteString)]
crest,ByteString
tr,ByteString
rest2) = ByteString -> ([(Int64, ByteString)], ByteString, ByteString)
consumeChunksImpl ByteString
rest
      getTrailer :: ByteString -> (ByteString, ByteString)
getTrailer 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 = Int64
2
                      | Bool
otherwise = let iscrlf :: [Bool]
iscrlf = forall a. (Char -> Char -> a) -> ByteString -> ByteString -> [a]
L.zipWith (\Char
a Char
b -> Char
a forall a. Eq a => a -> a -> Bool
== Char
'\r' Bool -> Bool -> Bool
&& Char
b forall a. Eq a => a -> a -> Bool
== Char
'\n') ByteString
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => ByteString -> ByteString
L.tail forall a b. (a -> b) -> a -> b
$ ByteString
s
                                        Just Int
i = forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Bool
True forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
(&&) [Bool]
iscrlf (forall a. [a] -> [a]
tail (forall a. [a] -> [a]
tail [Bool]
iscrlf))
                                    in forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
iforall a. Num a => a -> a -> a
+Int
4

crlfLC :: L.ByteString
crlfLC :: ByteString
crlfLC = String -> ByteString
L.pack String
"\r\n"

-- Properly lazy version of 'lines' for lazy bytestrings
lazylines           :: L.ByteString -> [L.ByteString]
lazylines :: ByteString -> [ByteString]
lazylines ByteString
s
    | ByteString -> Bool
L.null ByteString
s  = []
    | Bool
otherwise =
        let (ByteString
l,ByteString
s') = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
L.break (forall a. Eq a => a -> a -> Bool
(==) Char
'\n') ByteString
s
        in ByteString
l forall a. a -> [a] -> [a]
: if ByteString -> Bool
L.null ByteString
s' then []
                            else ByteString -> [ByteString]
lazylines (HasCallStack => ByteString -> ByteString
L.tail ByteString
s')

requestLine :: L.ByteString -> (Method, SURI, HttpVersion)
requestLine :: ByteString -> (Method, SURI, HttpVersion)
requestLine ByteString
l = case ByteString -> [ByteString]
P.words (([ByteString] -> ByteString
P.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks) ByteString
l) of
                  [ByteString
rq,ByteString
uri,ByteString
ver] -> (ByteString -> Method
method ByteString
rq, URI -> SURI
SURI forall a b. (a -> b) -> a -> b
$ ByteString -> URI
parseURIRef ByteString
uri, ByteString -> HttpVersion
version ByteString
ver)
                  [ByteString
rq,ByteString
uri] -> (ByteString -> Method
method ByteString
rq, URI -> SURI
SURI forall a b. (a -> b) -> a -> b
$ ByteString -> URI
parseURIRef ByteString
uri,Int -> Int -> HttpVersion
HttpVersion Int
0 Int
9)
                  [ByteString]
x -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"requestLine cannot handle input:  " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show [ByteString]
x)

responseLine :: L.ByteString -> (B.ByteString, Int)
responseLine :: ByteString -> (ByteString, Int)
responseLine ByteString
l = case ByteString -> [ByteString]
B.words (([ByteString] -> ByteString
B.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks) ByteString
l) of
                   (ByteString
v:ByteString
c:[ByteString]
_) -> ByteString -> HttpVersion
version ByteString
v seq :: forall a b. a -> b -> b
`seq` (ByteString
v,forall a b. (a, b) -> a
fst (forall a. HasCallStack => Maybe a -> a
fromJust (ByteString -> Maybe (Int, ByteString)
B.readInt ByteString
c)))
                   [ByteString]
x -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"responseLine cannot handle input: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show [ByteString]
x)


method :: B.ByteString -> Method
method :: ByteString -> Method
method ByteString
r = Maybe Method -> Method
fj forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
r [(ByteString, Method)]
mtable
    where fj :: Maybe Method -> Method
fj (Just Method
x) = Method
x
          fj Maybe Method
Nothing  = ByteString -> Method
EXTENSION ByteString
r
          mtable :: [(ByteString, Method)]
mtable = [ (String -> ByteString
P.pack String
"GET",     Method
GET)
                   , (String -> ByteString
P.pack String
"HEAD",    Method
HEAD)
                   , (String -> ByteString
P.pack String
"POST",    Method
POST)
                   , (String -> ByteString
P.pack String
"PUT",     Method
PUT)
                   , (String -> ByteString
P.pack String
"DELETE",  Method
DELETE)
                   , (String -> ByteString
P.pack String
"TRACE",   Method
TRACE)
                   , (String -> ByteString
P.pack String
"OPTIONS", Method
OPTIONS)
                   , (String -> ByteString
P.pack String
"CONNECT", Method
CONNECT)
                   , (String -> ByteString
P.pack String
"PATCH",   Method
PATCH)
                   ]

-- Result side

staticHeaders :: Headers
staticHeaders :: Headers
staticHeaders =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS) ([Header] -> Headers
mkHeaders [])
    [ (ByteString
serverC, ByteString
happstackC) ]

-- FIXME: we should not be controlling the response headers in mysterious ways in this low level code
-- headers should be set by application code and the core http engine should be very lean.
putAugmentedResult :: TimeoutIO -> Request -> Response -> IO ()
putAugmentedResult :: TimeoutIO -> Request -> Response -> IO ()
putAugmentedResult TimeoutIO
timeoutIO Request
req Response
res = do
    case Response
res of
        -- standard bytestring response
        Response {} -> do
            let isChunked :: Bool
isChunked = RsFlags -> Length
rsfLength (Response -> RsFlags
rsFlags Response
res) 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 forall a. Maybe a
Nothing else (forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
L.length (Response -> ByteString
rsBody Response
res))))) Bool
isChunked
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Request -> Method
rqMethod Request
req 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)
        -- zero-copy sendfile response
        -- the handle *should* be closed by the garbage collector

        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 (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 ByteString
k [ByteString]
vs) = forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
v -> [ByteString] -> ByteString
P.concat [ByteString
k, ByteString
fsepC, ByteString
v, ByteString
crlfC]) [ByteString]
vs
          sendTop :: Maybe Integer -> Bool -> IO ()
sendTop Maybe Integer
cl 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 forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                 [ (HttpVersion -> [ByteString]
pversion forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
rqVersion Request
req)          -- Print HTTP version
                 , [forall t. (Num t, Show t, Eq t) => t -> ByteString
responseMessage forall a b. (a -> b) -> a -> b
$ Response -> Int
rsCode Response
res]      -- Print responseCode
                 , forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderPair -> [ByteString]
ph (forall k a. Map k a -> [a]
M.elems Headers
allHeaders)   -- Print all headers
                 , [ByteString
crlfC]
                 ]
              Handle -> IO ()
TM.tickle (TimeoutIO -> Handle
toHandle TimeoutIO
timeoutIO)
          chunk :: L.ByteString -> L.ByteString
          chunk :: ByteString -> ByteString
chunk ByteString
Empty        = String -> ByteString
LC.pack String
"0\r\n\r\n"
          chunk (Chunk ByteString
c ByteString
cs) = ByteString -> ByteString -> ByteString
Chunk (String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> ShowS
showHex (ByteString -> Int
B.length ByteString
c) String
"\r\n") (ByteString -> ByteString -> ByteString
Chunk ByteString
c (ByteString -> ByteString -> ByteString
Chunk (String -> ByteString
B.pack String
"\r\n") (ByteString -> ByteString
chunk ByteString
cs)))

augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers
augmentHeaders :: Request -> Response -> Maybe Integer -> Bool -> IO Headers
augmentHeaders Request
req Response
res Maybe Integer
mcl Bool
isChunked = do
    -- TODO: Hoist static headers to the toplevel.
    ByteString
raw <- IO ByteString
getApproximateTime
    let stdHeaders :: Headers
stdHeaders = Headers
staticHeaders forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union`
          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])
                       ] forall a. [a] -> [a] -> [a]
++ case RsFlags -> Length
rsfLength (Response -> RsFlags
rsFlags Response
res) of
                              Length
NoContentLength -> []
                              Length
ContentLength | Bool -> Bool
not (forall r. HasHeaders r => String -> r -> Bool
hasHeader String
"Content-Length" Response
res) ->
                                                case Maybe Integer
mcl of
                                                  (Just Integer
cl) -> [(ByteString
contentlengthC, ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
contentLengthC [String -> ByteString
P.pack (forall a. Show a => a -> String
show Integer
cl)])]
                                                  Maybe Integer
_ -> []
                                            | Bool
otherwise -> []
                              Length
TransferEncodingChunked
                                  -- we check 'chunked' because we might not use this mode if the client is http 1.0
                                  | Bool
isChunked -> [(ByteString
transferEncodingC, ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
transferEncodingC [ByteString
chunkedC])]
                                  | Bool
otherwise -> []

                     )
    forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Headers
rsHeaders Response
res forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Headers
stdHeaders) -- 'union' prefers 'headers res' when duplicate keys are encountered.

-- | Serializes the request to the given handle
putRequest :: Handle -> Request -> IO ()
putRequest :: Handle -> Request -> IO ()
putRequest Handle
h Request
rq = do
    let put :: ByteString -> IO ()
put = Handle -> ByteString -> IO ()
B.hPut Handle
h
        ph :: HeaderPair -> [ByteString]
ph (HeaderPair ByteString
k [ByteString]
vs) = forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
v -> [ByteString] -> ByteString
B.concat [ByteString
k, ByteString
fsepC, ByteString
v, ByteString
crlfC]) [ByteString]
vs
        sp :: [ByteString]
sp = [String -> ByteString
B.pack String
" "]
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
put forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [[String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Request -> Method
rqMethod Request
rq],[ByteString]
sp
      ,[String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ Request -> String
rqURL Request
rq],[ByteString]
sp
      ,(HttpVersion -> [ByteString]
pversion forall a b. (a -> b) -> a -> b
$ Request -> HttpVersion
rqVersion Request
rq), [ByteString
crlfC]
      ,forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap HeaderPair -> [ByteString]
ph (forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ Request -> Headers
rqHeaders Request
rq)
      ,[ByteString
crlfC]
      ]
    Maybe RqBody
mBody <- forall (m :: * -> *). MonadIO m => Request -> m (Maybe RqBody)
takeRequestBody Request
rq -- tryTakeMVar (rqBody rq)
    Handle -> ByteString -> IO ()
L.hPut Handle
h (forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
L.empty RqBody -> ByteString
unBody Maybe RqBody
mBody) -- FIXME: should this actually be an error if the body is null?
    Handle -> IO ()
hFlush Handle
h

-- HttpVersion

pversion :: HttpVersion -> [B.ByteString]
pversion :: HttpVersion -> [ByteString]
pversion (HttpVersion Int
1 Int
1) = [ByteString
http11]
pversion (HttpVersion Int
1 Int
0) = [ByteString
http10]
pversion (HttpVersion Int
x Int
y) = [String -> ByteString
P.pack String
"HTTP/", String -> ByteString
P.pack (forall a. Show a => a -> String
show Int
x), String -> ByteString
P.pack String
".", String -> ByteString
P.pack (forall a. Show a => a -> String
show Int
y)]

version :: B.ByteString -> HttpVersion
version :: ByteString -> HttpVersion
version ByteString
x | ByteString
x forall a. Eq a => a -> a -> Bool
== ByteString
http09 = Int -> Int -> HttpVersion
HttpVersion Int
0 Int
9
          | ByteString
x forall a. Eq a => a -> a -> Bool
== ByteString
http10 = Int -> Int -> HttpVersion
HttpVersion Int
1 Int
0
          | ByteString
x forall a. Eq a => a -> a -> Bool
== ByteString
http11 = Int -> Int -> HttpVersion
HttpVersion Int
1 Int
1
          | Bool
otherwise   = forall a. HasCallStack => String -> a
error String
"Invalid HTTP version"

http09 :: B.ByteString
http09 :: ByteString
http09 = String -> ByteString
P.pack String
"HTTP/0.9"
http10 :: B.ByteString
http10 :: ByteString
http10 = String -> ByteString
P.pack String
"HTTP/1.0"
http11 :: B.ByteString
http11 :: ByteString
http11 = String -> ByteString
P.pack String
"HTTP/1.1"

-- * ByteString Constants

connectionC :: B.ByteString
connectionC :: ByteString
connectionC      = String -> ByteString
P.pack String
"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 String
"close"
keepAliveC :: B.ByteString
keepAliveC :: ByteString
keepAliveC       = String -> ByteString
P.pack String
"Keep-Alive"
crlfC :: B.ByteString
crlfC :: ByteString
crlfC            = String -> ByteString
P.pack String
"\r\n"
fsepC :: B.ByteString
fsepC :: ByteString
fsepC            = String -> ByteString
P.pack String
": "
-- contentTypeC :: B.ByteString
-- contentTypeC     = P.pack "Content-Type"
contentLengthC :: B.ByteString
contentLengthC :: ByteString
contentLengthC   = String -> ByteString
P.pack String
"Content-Length"
contentlengthC :: B.ByteString
contentlengthC :: ByteString
contentlengthC   = String -> ByteString
P.pack String
"content-length"
dateC :: B.ByteString
dateC :: ByteString
dateC            = String -> ByteString
P.pack String
"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 String
"Server"
happstackC :: B.ByteString
happstackC :: ByteString
happstackC           = String -> ByteString
P.pack forall a b. (a -> b) -> a -> b
$ String
"Happstack/" forall a. [a] -> [a] -> [a]
++ Version -> String
DV.showVersion Version
Paths.version
-- textHtmlC :: B.ByteString
-- textHtmlC        = P.pack "text/html; charset=utf-8"
transferEncodingC :: B.ByteString
transferEncodingC :: ByteString
transferEncodingC = String -> ByteString
P.pack String
"Transfer-Encoding"
chunkedC :: B.ByteString
chunkedC :: ByteString
chunkedC = String -> ByteString
P.pack String
"chunked"

-- Response code names

responseMessage :: (Num t, Show t, Eq t) => t -> B.ByteString
responseMessage :: forall t. (Num t, Show t, Eq t) => t -> ByteString
responseMessage t
100 = String -> ByteString
P.pack String
" 100 Continue\r\n"
responseMessage t
101 = String -> ByteString
P.pack String
" 101 Switching Protocols\r\n"
responseMessage t
200 = String -> ByteString
P.pack String
" 200 OK\r\n"
responseMessage t
201 = String -> ByteString
P.pack String
" 201 Created\r\n"
responseMessage t
202 = String -> ByteString
P.pack String
" 202 Accepted\r\n"
responseMessage t
203 = String -> ByteString
P.pack String
" 203 Non-Authoritative Information\r\n"
responseMessage t
204 = String -> ByteString
P.pack String
" 204 No Content\r\n"
responseMessage t
205 = String -> ByteString
P.pack String
" 205 Reset Content\r\n"
responseMessage t
206 = String -> ByteString
P.pack String
" 206 Partial Content\r\n"
responseMessage t
300 = String -> ByteString
P.pack String
" 300 Multiple Choices\r\n"
responseMessage t
301 = String -> ByteString
P.pack String
" 301 Moved Permanently\r\n"
responseMessage t
302 = String -> ByteString
P.pack String
" 302 Found\r\n"
responseMessage t
303 = String -> ByteString
P.pack String
" 303 See Other\r\n"
responseMessage t
304 = String -> ByteString
P.pack String
" 304 Not Modified\r\n"
responseMessage t
305 = String -> ByteString
P.pack String
" 305 Use Proxy\r\n"
responseMessage t
307 = String -> ByteString
P.pack String
" 307 Temporary Redirect\r\n"
responseMessage t
400 = String -> ByteString
P.pack String
" 400 Bad Request\r\n"
responseMessage t
401 = String -> ByteString
P.pack String
" 401 Unauthorized\r\n"
responseMessage t
402 = String -> ByteString
P.pack String
" 402 Payment Required\r\n"
responseMessage t
403 = String -> ByteString
P.pack String
" 403 Forbidden\r\n"
responseMessage t
404 = String -> ByteString
P.pack String
" 404 Not Found\r\n"
responseMessage t
405 = String -> ByteString
P.pack String
" 405 Method Not Allowed\r\n"
responseMessage t
406 = String -> ByteString
P.pack String
" 406 Not Acceptable\r\n"
responseMessage t
407 = String -> ByteString
P.pack String
" 407 Proxy Authentication Required\r\n"
responseMessage t
408 = String -> ByteString
P.pack String
" 408 Request Time-out\r\n"
responseMessage t
409 = String -> ByteString
P.pack String
" 409 Conflict\r\n"
responseMessage t
410 = String -> ByteString
P.pack String
" 410 Gone\r\n"
responseMessage t
411 = String -> ByteString
P.pack String
" 411 Length Required\r\n"
responseMessage t
412 = String -> ByteString
P.pack String
" 412 Precondition Failed\r\n"
responseMessage t
413 = String -> ByteString
P.pack String
" 413 Request Entity Too Large\r\n"
responseMessage t
414 = String -> ByteString
P.pack String
" 414 Request-URI Too Large\r\n"
responseMessage t
415 = String -> ByteString
P.pack String
" 415 Unsupported Media Type\r\n"
responseMessage t
416 = String -> ByteString
P.pack String
" 416 Requested range not satisfiable\r\n"
responseMessage t
417 = String -> ByteString
P.pack String
" 417 Expectation Failed\r\n"
responseMessage t
500 = String -> ByteString
P.pack String
" 500 Internal Server Error\r\n"
responseMessage t
501 = String -> ByteString
P.pack String
" 501 Not Implemented\r\n"
responseMessage t
502 = String -> ByteString
P.pack String
" 502 Bad Gateway\r\n"
responseMessage t
503 = String -> ByteString
P.pack String
" 503 Service Unavailable\r\n"
responseMessage t
504 = String -> ByteString
P.pack String
" 504 Gateway Time-out\r\n"
responseMessage t
505 = String -> ByteString
P.pack String
" 505 HTTP Version not supported\r\n"
responseMessage t
x   = String -> ByteString
P.pack (String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
x forall a. [a] -> [a] -> [a]
++ String
" \r\n")