{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, RankNTypes, CPP #-}

module Happstack.Server.Internal.Types
    (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),
     takeRequestBody, readInputsBody,
     rqURL, mkHeaders,
     getHeader, getHeaderBS, getHeaderUnsafe,
     hasHeader, hasHeaderBS, hasHeaderUnsafe,
     setHeader, setHeaderBS, setHeaderUnsafe,
     addHeader, addHeaderBS, addHeaderUnsafe,
     setRsCode, -- setCookie, setCookies,
     LogAccess, logMAccess, Conf(..), nullConf, result, resultBS,
     redirect, -- redirect_, redirect', redirect'_,
     isHTTP1_0, isHTTP1_1,
     RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,
     HttpVersion(..), Length(..), Method(..), canHaveBody, Headers, continueHTTP,
     Host, ContentType(..),
     readDec', fromReadS, readM, FromReqURI(..),
     showRsValidator, EscapeHTTP(..)
    ) where


import Control.Exception (Exception, SomeException)
#if !MIN_VERSION_mtl(2,3,0)
import Control.Monad.Error (Error(strMsg))
#endif
import Control.Monad.Fail (MonadFail)
import Control.Monad.Trans (MonadIO(liftIO))
import qualified Control.Concurrent.Thread.Group as TG
import Control.Concurrent.MVar
import qualified Data.Map as M
import Data.Data (Data)
import Data.String (fromString)
import Data.Time.Format (FormatTime(..))
import Data.Typeable(Typeable)
import qualified Data.ByteString.Char8 as P
import Data.ByteString.Char8 (ByteString,pack)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8  as LU (fromString)
import Data.Int   (Int8, Int16, Int32, Int64)
import Data.Maybe
import Data.List
import Data.Word  (Word, Word8, Word16, Word32, Word64)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Lazy
import Happstack.Server.SURI
import Data.Char (toLower)
import Happstack.Server.Internal.RFC822Headers ( ContentType(..) )
import Happstack.Server.Internal.Cookie
import Happstack.Server.Internal.LogFormat (formatRequestCombined)
import Happstack.Server.Internal.TimeoutIO (TimeoutIO)
import Numeric (readDec, readSigned)
import System.Log.Logger (Priority(..), logM)

-- | HTTP version
data HttpVersion = HttpVersion Int Int
             deriving(ReadPrec [HttpVersion]
ReadPrec HttpVersion
Int -> ReadS HttpVersion
ReadS [HttpVersion]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HttpVersion]
$creadListPrec :: ReadPrec [HttpVersion]
readPrec :: ReadPrec HttpVersion
$creadPrec :: ReadPrec HttpVersion
readList :: ReadS [HttpVersion]
$creadList :: ReadS [HttpVersion]
readsPrec :: Int -> ReadS HttpVersion
$creadsPrec :: Int -> ReadS HttpVersion
Read,HttpVersion -> HttpVersion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HttpVersion -> HttpVersion -> Bool
$c/= :: HttpVersion -> HttpVersion -> Bool
== :: HttpVersion -> HttpVersion -> Bool
$c== :: HttpVersion -> HttpVersion -> Bool
Eq)

instance Show HttpVersion where
  show :: HttpVersion -> String
show (HttpVersion Int
x Int
y) = (forall a. Show a => a -> String
show Int
x) forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show Int
y)

-- | 'True' if 'Request' is HTTP version @1.1@
isHTTP1_1 :: Request -> Bool
isHTTP1_1 :: Request -> Bool
isHTTP1_1 Request
rq =
    case Request -> HttpVersion
rqVersion Request
rq of
      HttpVersion Int
1 Int
1 -> Bool
True
      HttpVersion
_               -> Bool
False

-- | 'True' if 'Request' is HTTP version @1.0@
isHTTP1_0 :: Request -> Bool
isHTTP1_0 :: Request -> Bool
isHTTP1_0 Request
rq =
    case Request -> HttpVersion
rqVersion Request
rq of
      HttpVersion Int
1 Int
0 -> Bool
True
      HttpVersion
_               -> Bool
False

-- | Should the connection be used for further messages after this.
-- isHTTP1_0 && hasKeepAlive || isHTTP1_1 && hasNotConnectionClose
--
-- In addition to this rule All 1xx (informational), 204 (no content),
-- and 304 (not modified) responses MUST NOT include a message-body
-- and therefore are eligible for connection keep-alive.
continueHTTP :: Request -> Response -> Bool
continueHTTP :: Request -> Response -> Bool
continueHTTP Request
rq Response
rs =
    (Request -> Bool
isHTTP1_0 Request
rq Bool -> Bool -> Bool
&& forall r. HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderBS ByteString
connectionC ByteString
keepaliveC Request
rq   Bool -> Bool -> Bool
&&
       (RsFlags -> Length
rsfLength (Response -> RsFlags
rsFlags Response
rs) forall a. Eq a => a -> a -> Bool
== Length
ContentLength Bool -> Bool -> Bool
|| Response -> Bool
isNoMessageBodyResponse Response
rs)) Bool -> Bool -> Bool
||
    (Request -> Bool
isHTTP1_1 Request
rq Bool -> Bool -> Bool
&& Bool -> Bool
not (forall r. HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderBS ByteString
connectionC ByteString
closeC Request
rq) Bool -> Bool -> Bool
&&
       (RsFlags -> Length
rsfLength (Response -> RsFlags
rsFlags Response
rs) forall a. Eq a => a -> a -> Bool
/= Length
NoContentLength Bool -> Bool -> Bool
|| Response -> Bool
isNoMessageBodyResponse Response
rs))
  where
    isNoMessageBodyCode :: a -> Bool
isNoMessageBodyCode a
code = (a
code forall a. Ord a => a -> a -> Bool
>= a
100 Bool -> Bool -> Bool
&& a
code forall a. Ord a => a -> a -> Bool
<= a
199) Bool -> Bool -> Bool
|| a
code forall a. Eq a => a -> a -> Bool
== a
204 Bool -> Bool -> Bool
|| a
code forall a. Eq a => a -> a -> Bool
== a
304
    isNoMessageBodyResponse :: Response -> Bool
isNoMessageBodyResponse Response
rs' = forall {a}. (Ord a, Num a) => a -> Bool
isNoMessageBodyCode (Response -> Int
rsCode Response
rs') Bool -> Bool -> Bool
&& ByteString -> Bool
L.null (Response -> ByteString
rsBody Response
rs')

-- | function to log access requests (see also: 'logMAccess')
-- type LogAccess time =
--    (   String  -- ^ host
--     -> String  -- ^ user
--     -> time    -- ^ time
--     -> String  -- ^ requestLine
--     -> Int     -- ^ responseCode
--     -> Integer -- ^ size
--     -> String  -- ^ referer
--     -> String  -- ^ userAgent
--     -> IO ())
type LogAccess time =
    (   String
     -> String
     -> time
     -> String
     -> Int
     -> Integer
     -> String
     -> String
     -> IO ())

-- | HTTP configuration
data Conf = Conf
    { Conf -> Int
port        :: Int             -- ^ Port for the server to listen on.
    , Conf -> Maybe (Response -> IO Response)
validator   :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly
    , Conf -> forall t. FormatTime t => Maybe (LogAccess t)
logAccess   :: forall t. FormatTime t => Maybe (LogAccess t) -- ^ function to log access requests (see also: 'logMAccess')
    , Conf -> Int
timeout     :: Int             -- ^ number of seconds to wait before killing an inactive thread
    , Conf -> Maybe ThreadGroup
threadGroup :: Maybe TG.ThreadGroup -- ^ ThreadGroup for registering spawned threads for handling requests
    }

-- | Default configuration contains no validator and the port is set to 8000
nullConf :: Conf
nullConf :: Conf
nullConf =
    Conf { port :: Int
port        = Int
8000
         , validator :: Maybe (Response -> IO Response)
validator   = forall a. Maybe a
Nothing
         , logAccess :: forall t. FormatTime t => Maybe (LogAccess t)
logAccess   = forall a. a -> Maybe a
Just forall t. FormatTime t => LogAccess t
logMAccess
         , timeout :: Int
timeout     = Int
30
         , threadGroup :: Maybe ThreadGroup
threadGroup = forall a. Maybe a
Nothing
         }

-- | log access requests using hslogger and apache-style log formatting
--
-- see also: 'Conf'
logMAccess :: forall t. FormatTime t => LogAccess t
logMAccess :: forall t. FormatTime t => LogAccess t
logMAccess String
host String
user t
time String
requestLine Int
responseCode Integer
size String
referer String
userAgent =
    String -> Priority -> String -> IO ()
logM String
"Happstack.Server.AccessLog.Combined" Priority
INFO forall a b. (a -> b) -> a -> b
$ forall t.
FormatTime t =>
String
-> String -> t -> String -> Int -> Integer -> String -> ShowS
formatRequestCombined String
host String
user t
time String
requestLine Int
responseCode Integer
size String
referer String
userAgent

-- | HTTP request method
data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT | PATCH | EXTENSION ByteString
    deriving (Int -> Method -> ShowS
[Method] -> ShowS
Method -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Method] -> ShowS
$cshowList :: [Method] -> ShowS
show :: Method -> String
$cshow :: Method -> String
showsPrec :: Int -> Method -> ShowS
$cshowsPrec :: Int -> Method -> ShowS
Show,ReadPrec [Method]
ReadPrec Method
Int -> ReadS Method
ReadS [Method]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Method]
$creadListPrec :: ReadPrec [Method]
readPrec :: ReadPrec Method
$creadPrec :: ReadPrec Method
readList :: ReadS [Method]
$creadList :: ReadS [Method]
readsPrec :: Int -> ReadS Method
$creadsPrec :: Int -> ReadS Method
Read,Method -> Method -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Method -> Method -> Bool
$c/= :: Method -> Method -> Bool
== :: Method -> Method -> Bool
$c== :: Method -> Method -> Bool
Eq,Eq Method
Method -> Method -> Bool
Method -> Method -> Ordering
Method -> Method -> Method
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Method -> Method -> Method
$cmin :: Method -> Method -> Method
max :: Method -> Method -> Method
$cmax :: Method -> Method -> Method
>= :: Method -> Method -> Bool
$c>= :: Method -> Method -> Bool
> :: Method -> Method -> Bool
$c> :: Method -> Method -> Bool
<= :: Method -> Method -> Bool
$c<= :: Method -> Method -> Bool
< :: Method -> Method -> Bool
$c< :: Method -> Method -> Bool
compare :: Method -> Method -> Ordering
$ccompare :: Method -> Method -> Ordering
Ord,Typeable,Typeable Method
Method -> DataType
Method -> Constr
(forall b. Data b => b -> b) -> Method -> Method
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Method -> u
forall u. (forall d. Data d => d -> u) -> Method -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Method -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Method -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Method -> m Method
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Method -> m Method
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Method
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Method -> c Method
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Method)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Method)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Method -> m Method
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Method -> m Method
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Method -> m Method
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Method -> m Method
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Method -> m Method
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Method -> m Method
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Method -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Method -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Method -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Method -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Method -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Method -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Method -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Method -> r
gmapT :: (forall b. Data b => b -> b) -> Method -> Method
$cgmapT :: (forall b. Data b => b -> b) -> Method -> Method
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Method)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Method)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Method)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Method)
dataTypeOf :: Method -> DataType
$cdataTypeOf :: Method -> DataType
toConstr :: Method -> Constr
$ctoConstr :: Method -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Method
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Method
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Method -> c Method
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Method -> c Method
Data)

-- | Does the method support a message body?
--
-- For extension methods, we assume yes.
canHaveBody :: Method
            -> Bool
canHaveBody :: Method -> Bool
canHaveBody Method
POST          = Bool
True
canHaveBody Method
PUT           = Bool
True
canHaveBody Method
PATCH         = Bool
True
canHaveBody Method
DELETE        = Bool
True
canHaveBody (EXTENSION ByteString
_) = Bool
True
canHaveBody Method
_             = Bool
False

-- | an HTTP header
data HeaderPair = HeaderPair
    { HeaderPair -> ByteString
hName :: ByteString     -- ^ header name
    , HeaderPair -> [ByteString]
hValue :: [ByteString]  -- ^ header value (or values if multiple occurances of the header are present)
    }
    deriving (ReadPrec [HeaderPair]
ReadPrec HeaderPair
Int -> ReadS HeaderPair
ReadS [HeaderPair]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HeaderPair]
$creadListPrec :: ReadPrec [HeaderPair]
readPrec :: ReadPrec HeaderPair
$creadPrec :: ReadPrec HeaderPair
readList :: ReadS [HeaderPair]
$creadList :: ReadS [HeaderPair]
readsPrec :: Int -> ReadS HeaderPair
$creadsPrec :: Int -> ReadS HeaderPair
Read,Int -> HeaderPair -> ShowS
[HeaderPair] -> ShowS
HeaderPair -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HeaderPair] -> ShowS
$cshowList :: [HeaderPair] -> ShowS
show :: HeaderPair -> String
$cshow :: HeaderPair -> String
showsPrec :: Int -> HeaderPair -> ShowS
$cshowsPrec :: Int -> HeaderPair -> ShowS
Show)

-- | a Map of HTTP headers
--
-- the Map key is the header converted to lowercase
type Headers = M.Map ByteString HeaderPair -- ^ lowercased name -> (realname, value)

-- | A flag value set in the 'Response' which controls how the
-- @Content-Length@ header is set, and whether *chunked* output
-- encoding is used.
--
-- see also: 'nullRsFlags', 'notContentLength', and 'chunked'
data Length
    = ContentLength             -- ^ automatically add a @Content-Length@ header to the 'Response'
    | TransferEncodingChunked   -- ^ do not add a @Content-Length@ header. Do use @chunked@ output encoding
    | NoContentLength           -- ^ do not set @Content-Length@ or @chunked@ output encoding.
      deriving (Length -> Length -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Length -> Length -> Bool
$c/= :: Length -> Length -> Bool
== :: Length -> Length -> Bool
$c== :: Length -> Length -> Bool
Eq, Eq Length
Length -> Length -> Bool
Length -> Length -> Ordering
Length -> Length -> Length
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Length -> Length -> Length
$cmin :: Length -> Length -> Length
max :: Length -> Length -> Length
$cmax :: Length -> Length -> Length
>= :: Length -> Length -> Bool
$c>= :: Length -> Length -> Bool
> :: Length -> Length -> Bool
$c> :: Length -> Length -> Bool
<= :: Length -> Length -> Bool
$c<= :: Length -> Length -> Bool
< :: Length -> Length -> Bool
$c< :: Length -> Length -> Bool
compare :: Length -> Length -> Ordering
$ccompare :: Length -> Length -> Ordering
Ord, ReadPrec [Length]
ReadPrec Length
Int -> ReadS Length
ReadS [Length]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Length]
$creadListPrec :: ReadPrec [Length]
readPrec :: ReadPrec Length
$creadPrec :: ReadPrec Length
readList :: ReadS [Length]
$creadList :: ReadS [Length]
readsPrec :: Int -> ReadS Length
$creadsPrec :: Int -> ReadS Length
Read, Int -> Length -> ShowS
[Length] -> ShowS
Length -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Length] -> ShowS
$cshowList :: [Length] -> ShowS
show :: Length -> String
$cshow :: Length -> String
showsPrec :: Int -> Length -> ShowS
$cshowsPrec :: Int -> Length -> ShowS
Show, Int -> Length
Length -> Int
Length -> [Length]
Length -> Length
Length -> Length -> [Length]
Length -> Length -> Length -> [Length]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Length -> Length -> Length -> [Length]
$cenumFromThenTo :: Length -> Length -> Length -> [Length]
enumFromTo :: Length -> Length -> [Length]
$cenumFromTo :: Length -> Length -> [Length]
enumFromThen :: Length -> Length -> [Length]
$cenumFromThen :: Length -> Length -> [Length]
enumFrom :: Length -> [Length]
$cenumFrom :: Length -> [Length]
fromEnum :: Length -> Int
$cfromEnum :: Length -> Int
toEnum :: Int -> Length
$ctoEnum :: Int -> Length
pred :: Length -> Length
$cpred :: Length -> Length
succ :: Length -> Length
$csucc :: Length -> Length
Enum)

-- | Result flags
data RsFlags = RsFlags
    { RsFlags -> Length
rsfLength :: Length
    } deriving (Int -> RsFlags -> ShowS
[RsFlags] -> ShowS
RsFlags -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RsFlags] -> ShowS
$cshowList :: [RsFlags] -> ShowS
show :: RsFlags -> String
$cshow :: RsFlags -> String
showsPrec :: Int -> RsFlags -> ShowS
$cshowsPrec :: Int -> RsFlags -> ShowS
Show,ReadPrec [RsFlags]
ReadPrec RsFlags
Int -> ReadS RsFlags
ReadS [RsFlags]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RsFlags]
$creadListPrec :: ReadPrec [RsFlags]
readPrec :: ReadPrec RsFlags
$creadPrec :: ReadPrec RsFlags
readList :: ReadS [RsFlags]
$creadList :: ReadS [RsFlags]
readsPrec :: Int -> ReadS RsFlags
$creadsPrec :: Int -> ReadS RsFlags
Read,Typeable)

-- | Default RsFlags: automatically use @Transfer-Encoding: Chunked@.
nullRsFlags :: RsFlags
nullRsFlags :: RsFlags
nullRsFlags = RsFlags { rsfLength :: Length
rsfLength = Length
TransferEncodingChunked }

-- | Do not automatically add a Content-Length field to the 'Response'
noContentLength :: Response -> Response
noContentLength :: Response -> Response
noContentLength Response
res = Response
res { rsFlags :: RsFlags
rsFlags = RsFlags
flags } where flags :: RsFlags
flags = (Response -> RsFlags
rsFlags Response
res) { rsfLength :: Length
rsfLength = Length
NoContentLength }

-- | Do not automatically add a Content-Length header. Do automatically use Transfer-Encoding: Chunked
chunked :: Response -> Response
chunked :: Response -> Response
chunked Response
res         = Response
res { rsFlags :: RsFlags
rsFlags = RsFlags
flags } where flags :: RsFlags
flags = (Response -> RsFlags
rsFlags Response
res) { rsfLength :: Length
rsfLength = Length
TransferEncodingChunked }

-- | Automatically add a Content-Length header. Do not use Transfer-Encoding: Chunked
contentLength :: Response -> Response
contentLength :: Response -> Response
contentLength Response
res   = Response
res { rsFlags :: RsFlags
rsFlags = RsFlags
flags } where flags :: RsFlags
flags = (Response -> RsFlags
rsFlags Response
res) { rsfLength :: Length
rsfLength = Length
ContentLength }

-- | a value extract from the @QUERY_STRING@ or 'Request' body
--
-- If the input value was a file, then it will be saved to a temporary file on disk and 'inputValue' will contain @Left pathToTempFile@.
data Input = Input
    { Input -> Either String ByteString
inputValue       :: Either FilePath L.ByteString
    , Input -> Maybe String
inputFilename    :: Maybe FilePath
    , Input -> ContentType
inputContentType :: ContentType
    } deriving (Int -> Input -> ShowS
[Input] -> ShowS
Input -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Input] -> ShowS
$cshowList :: [Input] -> ShowS
show :: Input -> String
$cshow :: Input -> String
showsPrec :: Int -> Input -> ShowS
$cshowsPrec :: Int -> Input -> ShowS
Show, ReadPrec [Input]
ReadPrec Input
Int -> ReadS Input
ReadS [Input]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Input]
$creadListPrec :: ReadPrec [Input]
readPrec :: ReadPrec Input
$creadPrec :: ReadPrec Input
readList :: ReadS [Input]
$creadList :: ReadS [Input]
readsPrec :: Int -> ReadS Input
$creadsPrec :: Int -> ReadS Input
Read, Typeable)

-- | hostname & port
type Host = (String, Int) -- ^ (hostname, port)

-- | an HTTP Response
data Response
    = Response  { Response -> Int
rsCode      :: Int
                , Response -> Headers
rsHeaders   :: Headers
                , Response -> RsFlags
rsFlags     :: RsFlags
                , Response -> ByteString
rsBody      :: L.ByteString
                , Response -> Maybe (Response -> IO Response)
rsValidator :: Maybe (Response -> IO Response)
                }
    | SendFile  { rsCode      :: Int
                , rsHeaders   :: Headers
                , rsFlags     :: RsFlags
                , rsValidator :: Maybe (Response -> IO Response)
                , Response -> String
sfFilePath  :: FilePath  -- ^ file handle to send from
                , Response -> Integer
sfOffset    :: Integer   -- ^ offset to start at
                , Response -> Integer
sfCount     :: Integer    -- ^ number of bytes to send
                }
      deriving (Typeable)

instance Show Response where
    showsPrec :: Int -> Response -> ShowS
showsPrec Int
_ res :: Response
res@Response{}  =
        String -> ShowS
showString   String
"================== Response ================"                    forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsCode      = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> Int
rsCode Response
res)                        forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsHeaders   = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> Headers
rsHeaders Response
res)                     forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsFlags     = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> RsFlags
rsFlags Response
res)                       forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsBody      = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> ByteString
rsBody Response
res)                        forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsValidator = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Maybe (Response -> IO Response) -> String
showRsValidator (Response -> Maybe (Response -> IO Response)
rsValidator Response
res))
    showsPrec Int
_ res :: Response
res@SendFile{}  =
        String -> ShowS
showString   String
"================== Response ================"                    forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsCode      = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> Int
rsCode Response
res)                        forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsHeaders   = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> Headers
rsHeaders Response
res)                     forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsFlags     = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> RsFlags
rsFlags Response
res)                       forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsValidator = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Maybe (Response -> IO Response) -> String
showRsValidator (Response -> Maybe (Response -> IO Response)
rsValidator Response
res)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nsfFilePath  = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> String
sfFilePath Response
res)                    forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nsfOffset    = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> Integer
sfOffset Response
res)                      forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nsfCount     = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Response -> Integer
sfCount Response
res)

showRsValidator :: Maybe (Response -> IO Response) -> String
showRsValidator :: Maybe (Response -> IO Response) -> String
showRsValidator = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Nothing" (forall a b. a -> b -> a
const String
"Just <function>")

#if !MIN_VERSION_mtl(2,3,0)
-- what should the status code be ?
instance Error Response where
  strMsg :: String -> Response
strMsg String
str =
      forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Content-Type" String
"text/plain; charset=UTF-8" forall a b. (a -> b) -> a -> b
$
       Int -> String -> Response
result Int
500 String
str
#endif

-- | an HTTP request
data Request = Request
    { Request -> Bool
rqSecure      :: Bool                  -- ^ request uses https:\/\/
    , Request -> Method
rqMethod      :: Method                -- ^ request method
    , Request -> [String]
rqPaths       :: [String]              -- ^ the uri, split on /, and then decoded
    , Request -> String
rqUri         :: String                -- ^ the raw rqUri
    , Request -> String
rqQuery       :: String                -- ^ the QUERY_STRING
    , Request -> [(String, Input)]
rqInputsQuery :: [(String,Input)]      -- ^ the QUERY_STRING decoded as key/value pairs
    , Request -> MVar [(String, Input)]
rqInputsBody  :: MVar [(String,Input)] -- ^ the request body decoded as key/value pairs (when appropriate)
    , Request -> [(String, Cookie)]
rqCookies     :: [(String,Cookie)]     -- ^ cookies
    , Request -> HttpVersion
rqVersion     :: HttpVersion           -- ^ HTTP version
    , Request -> Headers
rqHeaders     :: Headers               -- ^ the HTTP request headers
    , Request -> MVar RqBody
rqBody        :: MVar RqBody           -- ^ the raw, undecoded request body
    , Request -> Host
rqPeer        :: Host                  -- ^ (hostname, port) of the client making the request
    } deriving (Typeable)

instance Show Request where
    showsPrec :: Int -> Request -> ShowS
showsPrec Int
_ Request
rq =
        String -> ShowS
showString   String
"================== Request =================" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqSecure      = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Request -> Bool
rqSecure Request
rq) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqMethod      = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Request -> Method
rqMethod Request
rq) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqPaths       = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Request -> [String]
rqPaths Request
rq) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqUri         = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Request -> String
rqUri Request
rq) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqQuery       = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Request -> String
rqQuery Request
rq) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqInputsQuery = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Request -> [(String, Input)]
rqInputsQuery Request
rq) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqInputsBody  = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"<<mvar>>" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqCookies     = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Request -> [(String, Cookie)]
rqCookies Request
rq) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqVersion     = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Request -> HttpVersion
rqVersion Request
rq) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqHeaders     = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Request -> Headers
rqHeaders Request
rq) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqBody        = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"<<mvar>>" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqPeer        = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows      (Request -> Host
rqPeer Request
rq)

-- | get the request body from the Request and replace it with Nothing
--
-- IMPORTANT: You can really only call this function once. Subsequent
-- calls will return 'Nothing'.
takeRequestBody :: (MonadIO m) => Request -> m (Maybe RqBody)
takeRequestBody :: forall (m :: * -> *). MonadIO m => Request -> m (Maybe RqBody)
takeRequestBody Request
rq = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO (Maybe a)
tryTakeMVar (Request -> MVar RqBody
rqBody Request
rq)

-- | read the request body inputs
--
-- This will only work if the body inputs have already been decoded. Otherwise it will return Nothing.
readInputsBody :: Request -> IO (Maybe [(String, Input)])
readInputsBody :: Request -> IO (Maybe [(String, Input)])
readInputsBody Request
req =
    do Maybe [(String, Input)]
mbi <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req)
       case Maybe [(String, Input)]
mbi of
         (Just [(String, Input)]
bi) ->
                do forall a. MVar a -> a -> IO ()
putMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req) [(String, Input)]
bi
                   forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [(String, Input)]
bi)
         Maybe [(String, Input)]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Converts a Request into a String representing the corresponding URL
rqURL :: Request -> String
rqURL :: Request -> String
rqURL Request
rq = Char
'/'forall a. a -> [a] -> [a]
:forall a. [a] -> [[a]] -> [a]
intercalate String
"/" (Request -> [String]
rqPaths Request
rq) forall a. [a] -> [a] -> [a]
++ (Request -> String
rqQuery Request
rq)

-- | a class for working with types that contain HTTP headers
class HasHeaders a where
    updateHeaders :: (Headers->Headers) -> a -> a -- ^ modify the headers
    headers       :: a -> Headers                 -- ^ extract the headers

instance HasHeaders Response where
    updateHeaders :: (Headers -> Headers) -> Response -> Response
updateHeaders Headers -> Headers
f Response
rs = Response
rs {rsHeaders :: Headers
rsHeaders=Headers -> Headers
f forall a b. (a -> b) -> a -> b
$ Response -> Headers
rsHeaders Response
rs }
    headers :: Response -> Headers
headers            = Response -> Headers
rsHeaders

instance HasHeaders Request where
    updateHeaders :: (Headers -> Headers) -> Request -> Request
updateHeaders Headers -> Headers
f Request
rq = Request
rq {rqHeaders :: Headers
rqHeaders = Headers -> Headers
f forall a b. (a -> b) -> a -> b
$ Request -> Headers
rqHeaders Request
rq }
    headers :: Request -> Headers
headers            = Request -> Headers
rqHeaders

instance HasHeaders Headers where
    updateHeaders :: (Headers -> Headers) -> Headers -> Headers
updateHeaders Headers -> Headers
f = Headers -> Headers
f
    headers :: Headers -> Headers
headers         = forall a. a -> a
id

-- | The body of an HTTP 'Request'
newtype RqBody = Body { RqBody -> ByteString
unBody :: L.ByteString } deriving (ReadPrec [RqBody]
ReadPrec RqBody
Int -> ReadS RqBody
ReadS [RqBody]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RqBody]
$creadListPrec :: ReadPrec [RqBody]
readPrec :: ReadPrec RqBody
$creadPrec :: ReadPrec RqBody
readList :: ReadS [RqBody]
$creadList :: ReadS [RqBody]
readsPrec :: Int -> ReadS RqBody
$creadsPrec :: Int -> ReadS RqBody
Read,Int -> RqBody -> ShowS
[RqBody] -> ShowS
RqBody -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RqBody] -> ShowS
$cshowList :: [RqBody] -> ShowS
show :: RqBody -> String
$cshow :: RqBody -> String
showsPrec :: Int -> RqBody -> ShowS
$cshowsPrec :: Int -> RqBody -> ShowS
Show,Typeable)

-- | Sets the Response status code to the provided Int and lifts the computation
-- into a Monad.
setRsCode :: (Monad m) => Int -> Response -> m Response
setRsCode :: forall (m :: * -> *). Monad m => Int -> Response -> m Response
setRsCode Int
code Response
rs = forall (m :: * -> *) a. Monad m => a -> m a
return Response
rs { rsCode :: Int
rsCode = Int
code }

-- | Takes a list of (key,val) pairs and converts it into Headers.  The
-- keys will be converted to lowercase
mkHeaders :: [(String,String)] -> Headers
mkHeaders :: [(String, String)] -> Headers
mkHeaders [(String, String)]
hdrs
    = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith HeaderPair -> HeaderPair -> HeaderPair
join [ (String -> ByteString
P.pack (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
key), ByteString -> [ByteString] -> HeaderPair
HeaderPair (String -> ByteString
P.pack String
key) [String -> ByteString
P.pack String
value]) | (String
key,String
value) <- [(String, String)]
hdrs ]
    where join :: HeaderPair -> HeaderPair -> HeaderPair
join (HeaderPair ByteString
key [ByteString]
vs1) (HeaderPair ByteString
_ [ByteString]
vs2) = ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
key ([ByteString]
vs2forall a. [a] -> [a] -> [a]
++[ByteString]
vs1)

--------------------------------------------------------------
-- Retrieving header information
--------------------------------------------------------------

-- | Lookup header value. Key is case-insensitive.
getHeader :: HasHeaders r => String -> r -> Maybe ByteString
getHeader :: forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader = forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack

-- | Lookup header value. Key is a case-insensitive bytestring.
getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderBS :: forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderBS = forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderUnsafe forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower

-- | Lookup header value with a case-sensitive key. The key must be lowercase.
getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderUnsafe :: forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderUnsafe ByteString
key r
var = forall a. [a] -> Maybe a
listToMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HeaderPair -> [ByteString]
hValue (forall r. HasHeaders r => ByteString -> r -> Maybe HeaderPair
getHeaderUnsafe' ByteString
key r
var)

-- | Lookup header with a case-sensitive key. The key must be lowercase.
getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair
getHeaderUnsafe' :: forall r. HasHeaders r => ByteString -> r -> Maybe HeaderPair
getHeaderUnsafe' ByteString
key = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasHeaders a => a -> Headers
headers

--------------------------------------------------------------
-- Querying header status
--------------------------------------------------------------

-- | Returns True if the associated key is found in the Headers.  The lookup
-- is case insensitive.
hasHeader :: HasHeaders r => String -> r -> Bool
hasHeader :: forall r. HasHeaders r => String -> r -> Bool
hasHeader String
key r
r = forall a. Maybe a -> Bool
isJust (forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
key r
r)

-- | Acts as 'hasHeader' with ByteStrings
hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool
hasHeaderBS :: forall r. HasHeaders r => ByteString -> r -> Bool
hasHeaderBS ByteString
key r
r = forall a. Maybe a -> Bool
isJust (forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderBS ByteString
key r
r)

-- | Acts as 'hasHeaderBS' but the key is case sensitive.  It should be
-- in lowercase.
hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool
hasHeaderUnsafe :: forall r. HasHeaders r => ByteString -> r -> Bool
hasHeaderUnsafe ByteString
key r
r = forall a. Maybe a -> Bool
isJust (forall r. HasHeaders r => ByteString -> r -> Maybe HeaderPair
getHeaderUnsafe' ByteString
key r
r)

checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderBS :: forall r. HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderBS ByteString
key ByteString
val = forall r. HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderUnsafe ((Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower ByteString
key) ((Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower ByteString
val)

checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderUnsafe :: forall r. HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderUnsafe ByteString
key ByteString
val r
r
    = case forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderUnsafe ByteString
key r
r of
        Just ByteString
val' | (Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower ByteString
val' forall a. Eq a => a -> a -> Bool
== ByteString
val -> Bool
True
        Maybe ByteString
_ -> Bool
False


--------------------------------------------------------------
-- Setting header status
--------------------------------------------------------------

-- | Associates the key/value pair in the headers.  Forces the key to be
-- lowercase.
setHeader :: HasHeaders r => String -> String -> r -> r
setHeader :: forall r. HasHeaders r => String -> String -> r -> r
setHeader String
key String
val = forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS (String -> ByteString
pack String
key) (String -> ByteString
pack String
val)

-- | Acts as 'setHeader' but with ByteStrings.
setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS :: forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS ByteString
key ByteString
val = forall r. HasHeaders r => ByteString -> HeaderPair -> r -> r
setHeaderUnsafe ((Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower ByteString
key) (ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
key [ByteString
val])

-- | Sets the key to the HeaderPair.  This is the only way to associate a key
-- with multiple values via the setHeader* functions.  Does not force the key
-- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match.
setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r
setHeaderUnsafe :: forall r. HasHeaders r => ByteString -> HeaderPair -> r -> r
setHeaderUnsafe ByteString
key HeaderPair
val = forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ByteString
key HeaderPair
val)

--------------------------------------------------------------
-- Adding headers
--------------------------------------------------------------

-- | Add a key/value pair to the header.  If the key already has a value
-- associated with it, then the value will be appended.
-- Forces the key to be lowercase.
addHeader :: HasHeaders r => String -> String -> r -> r
addHeader :: forall r. HasHeaders r => String -> String -> r -> r
addHeader String
key String
val = forall r. HasHeaders r => ByteString -> ByteString -> r -> r
addHeaderBS (String -> ByteString
pack String
key) (String -> ByteString
pack String
val)

-- | Acts as addHeader except for ByteStrings
addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r
addHeaderBS :: forall r. HasHeaders r => ByteString -> ByteString -> r -> r
addHeaderBS ByteString
key ByteString
val = forall r. HasHeaders r => ByteString -> HeaderPair -> r -> r
addHeaderUnsafe ((Char -> Char) -> ByteString -> ByteString
P.map Char -> Char
toLower ByteString
key) (ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
key [ByteString
val])

-- | Add a key/value pair to the header using the underlying HeaderPair data
-- type.  Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match.
addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r
addHeaderUnsafe :: forall r. HasHeaders r => ByteString -> HeaderPair -> r -> r
addHeaderUnsafe ByteString
key HeaderPair
val = forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith HeaderPair -> HeaderPair -> HeaderPair
join ByteString
key HeaderPair
val)
    where join :: HeaderPair -> HeaderPair -> HeaderPair
join (HeaderPair ByteString
k [ByteString]
vs1) (HeaderPair ByteString
_ [ByteString]
vs2) = ByteString -> [ByteString] -> HeaderPair
HeaderPair ByteString
k ([ByteString]
vs2forall a. [a] -> [a] -> [a]
++[ByteString]
vs1)

-- | Creates a Response with the given Int as the status code and the provided
-- String as the body of the Response
result :: Int -> String -> Response
result :: Int -> String -> Response
result Int
code = Int -> ByteString -> Response
resultBS Int
code forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
LU.fromString

-- | Acts as 'result' but works with ByteStrings directly.
--
-- By default, Transfer-Encoding: chunked will be used
resultBS :: Int -> L.ByteString -> Response
resultBS :: Int -> ByteString -> Response
resultBS Int
code ByteString
s = Int
-> Headers
-> RsFlags
-> ByteString
-> Maybe (Response -> IO Response)
-> Response
Response Int
code forall k a. Map k a
M.empty RsFlags
nullRsFlags ByteString
s forall a. Maybe a
Nothing

-- | Sets the Response's status code to the given Int and redirects to the given URI
redirect :: (ToSURI s) => Int -> s -> Response -> Response
redirect :: forall s. ToSURI s => Int -> s -> Response -> Response
redirect Int
c s
s Response
resp = forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS ByteString
locationC (String -> ByteString
pack (forall a. ToSURI a => a -> String
render (forall x. ToSURI x => x -> SURI
toSURI s
s))) Response
resp{rsCode :: Int
rsCode = Int
c}

-- constants here

-- | @Location@
locationC :: ByteString
locationC :: ByteString
locationC   = String -> ByteString
P.pack String
"Location"

-- | @close@
closeC :: ByteString
closeC :: ByteString
closeC      = String -> ByteString
P.pack String
"close"

-- | @Connection@
connectionC :: ByteString
connectionC :: ByteString
connectionC = String -> ByteString
P.pack String
"Connection"

-- | @Keep-Alive@
keepaliveC :: ByteString
keepaliveC :: ByteString
keepaliveC  = String -> ByteString
P.pack String
"Keep-Alive"

readDec' :: (Num a, Eq a) => String -> a
readDec' :: forall a. (Num a, Eq a) => String -> a
readDec' String
s =
  case forall a. (Eq a, Num a) => ReadS a
readDec String
s of
    [(a
n,[])] -> a
n
    [(a, String)]
_    -> forall a. HasCallStack => String -> a
error String
"readDec' failed."

-- | Read in any monad.
readM :: (MonadFail m, Read t) => String -> m t
readM :: forall (m :: * -> *) t. (MonadFail m, Read t) => String -> m t
readM String
s = case forall a. Read a => ReadS a
reads String
s of
            [(t
v,String
"")] -> forall (m :: * -> *) a. Monad m => a -> m a
return t
v
            [(t, String)]
_        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"readM: parse error"

-- |convert a 'ReadS a' result to 'Maybe a'
fromReadS :: [(a, String)] -> Maybe a
fromReadS :: forall a. [(a, String)] -> Maybe a
fromReadS [(a
n,[])] = forall a. a -> Maybe a
Just a
n
fromReadS [(a, String)]
_        = forall a. Maybe a
Nothing

-- | This class is used by 'path' to parse a path component into a
-- value.
--
-- The instances for number types ('Int', 'Float', etc) use 'readM' to
-- parse the path component.
--
-- The instance for 'String', on the other hand, returns the
-- unmodified path component.
--
-- See the following section of the Happstack Crash Course for
-- detailed instructions using and extending 'FromReqURI':
--
--  <http://www.happstack.com/docs/crashcourse/RouteFilters.html#FromReqURI>

class FromReqURI a where
    fromReqURI :: String -> Maybe a

instance FromReqURI String  where fromReqURI :: String -> Maybe String
fromReqURI = forall a. a -> Maybe a
Just
instance FromReqURI Text.Text where fromReqURI :: String -> Maybe Text
fromReqURI = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromReqURI a => String -> Maybe a
fromReqURI
instance FromReqURI Lazy.Text where fromReqURI :: String -> Maybe Text
fromReqURI = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromReqURI a => String -> Maybe a
fromReqURI
instance FromReqURI Char    where fromReqURI :: String -> Maybe Char
fromReqURI String
s = case String
s of [Char
c] -> forall a. a -> Maybe a
Just Char
c ; String
_ -> forall a. Maybe a
Nothing
instance FromReqURI Int     where fromReqURI :: String -> Maybe Int
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => ReadS a -> ReadS a
readSigned forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Int8    where fromReqURI :: String -> Maybe Int8
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => ReadS a -> ReadS a
readSigned forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Int16   where fromReqURI :: String -> Maybe Int16
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => ReadS a -> ReadS a
readSigned forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Int32   where fromReqURI :: String -> Maybe Int32
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => ReadS a -> ReadS a
readSigned forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Int64   where fromReqURI :: String -> Maybe Int64
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => ReadS a -> ReadS a
readSigned forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Integer where fromReqURI :: String -> Maybe Integer
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => ReadS a -> ReadS a
readSigned forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Word    where fromReqURI :: String -> Maybe Word
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Word8   where fromReqURI :: String -> Maybe Word8
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Word16  where fromReqURI :: String -> Maybe Word16
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Word32  where fromReqURI :: String -> Maybe Word32
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Word64  where fromReqURI :: String -> Maybe Word64
fromReqURI = forall a. [(a, String)] -> Maybe a
fromReadS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Num a) => ReadS a
readDec
instance FromReqURI Float   where fromReqURI :: String -> Maybe Float
fromReqURI = forall (m :: * -> *) t. (MonadFail m, Read t) => String -> m t
readM
instance FromReqURI Double  where fromReqURI :: String -> Maybe Double
fromReqURI = forall (m :: * -> *) t. (MonadFail m, Read t) => String -> m t
readM
instance FromReqURI Bool    where
  fromReqURI :: String -> Maybe Bool
fromReqURI String
s =
    let s' :: String
s' = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s in
    case String
s' of
      String
"0"     -> forall a. a -> Maybe a
Just Bool
False
      String
"false" -> forall a. a -> Maybe a
Just Bool
False
      String
"1"     -> forall a. a -> Maybe a
Just Bool
True
      String
"true"  -> forall a. a -> Maybe a
Just Bool
True
      String
_       -> forall a. Maybe a
Nothing

------------------------------------------------------------------------------
-- EscapeHTTP - escape hatched use by websockets
------------------------------------------------------------------------------

-- | Escape from the HTTP world and get direct access to the underlying 'TimeoutIO' functions
data EscapeHTTP
  = EscapeHTTP (TimeoutIO -> IO ())
    deriving (Typeable)

instance Exception EscapeHTTP

instance Show EscapeHTTP where
  show :: EscapeHTTP -> String
show (EscapeHTTP {})         = String
"<EscapeHTTP _>"