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

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)
import Control.Monad.Error (Error(strMsg))
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]
(Int -> ReadS HttpVersion)
-> ReadS [HttpVersion]
-> ReadPrec HttpVersion
-> ReadPrec [HttpVersion]
-> Read 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
(HttpVersion -> HttpVersion -> Bool)
-> (HttpVersion -> HttpVersion -> Bool) -> Eq HttpVersion
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) = (Int -> String
forall a. Show a => a -> String
show Int
x) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> String
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
&& ByteString -> ByteString -> Request -> 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) Length -> Length -> Bool
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 (ByteString -> ByteString -> Request -> Bool
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) Length -> Length -> Bool
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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
100 Bool -> Bool -> Bool
&& a
code a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
199) Bool -> Bool -> Bool
|| a
code a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
204 Bool -> Bool -> Bool
|| a
code a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
304
    isNoMessageBodyResponse :: Response -> Bool
isNoMessageBodyResponse Response
rs' = Int -> Bool
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 :: Int
-> Maybe (Response -> IO Response)
-> (forall t. FormatTime t => Maybe (LogAccess t))
-> Int
-> Maybe ThreadGroup
-> Conf
Conf { port :: Int
port        = Int
8000
         , validator :: Maybe (Response -> IO Response)
validator   = Maybe (Response -> IO Response)
forall a. Maybe a
Nothing
         , logAccess :: forall t. FormatTime t => Maybe (LogAccess t)
logAccess   = LogAccess t -> Maybe (LogAccess t)
forall a. a -> Maybe a
Just LogAccess t
forall t. FormatTime t => LogAccess t
logMAccess
         , timeout :: Int
timeout     = Int
30
         , threadGroup :: Maybe ThreadGroup
threadGroup = Maybe 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 :: 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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
-> String -> t -> String -> Int -> Integer -> String -> ShowS
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
(Int -> Method -> ShowS)
-> (Method -> String) -> ([Method] -> ShowS) -> Show Method
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]
(Int -> ReadS Method)
-> ReadS [Method]
-> ReadPrec Method
-> ReadPrec [Method]
-> Read 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
(Method -> Method -> Bool)
-> (Method -> Method -> Bool) -> Eq Method
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
Eq Method
-> (Method -> Method -> Ordering)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Bool)
-> (Method -> Method -> Method)
-> (Method -> Method -> Method)
-> Ord 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
$cp1Ord :: Eq Method
Ord,Typeable,Typeable Method
DataType
Constr
Typeable Method
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Method -> c Method)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Method)
-> (Method -> Constr)
-> (Method -> DataType)
-> (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))
-> ((forall b. Data b => b -> b) -> Method -> Method)
-> (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 u. (forall d. Data d => d -> u) -> Method -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Method -> u)
-> (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 (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Method -> m Method)
-> Data Method
Method -> DataType
Method -> Constr
(forall b. Data b => b -> b) -> Method -> Method
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Method -> c Method
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cEXTENSION :: Constr
$cPATCH :: Constr
$cCONNECT :: Constr
$cOPTIONS :: Constr
$cTRACE :: Constr
$cDELETE :: Constr
$cPUT :: Constr
$cPOST :: Constr
$cHEAD :: Constr
$cGET :: Constr
$tMethod :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> Method -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Method -> u
gmapQ :: (forall d. Data d => d -> u) -> Method -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Method -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable 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]
(Int -> ReadS HeaderPair)
-> ReadS [HeaderPair]
-> ReadPrec HeaderPair
-> ReadPrec [HeaderPair]
-> Read 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
(Int -> HeaderPair -> ShowS)
-> (HeaderPair -> String)
-> ([HeaderPair] -> ShowS)
-> Show HeaderPair
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
(Length -> Length -> Bool)
-> (Length -> Length -> Bool) -> Eq Length
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
Eq Length
-> (Length -> Length -> Ordering)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Bool)
-> (Length -> Length -> Length)
-> (Length -> Length -> Length)
-> Ord 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
$cp1Ord :: Eq Length
Ord, ReadPrec [Length]
ReadPrec Length
Int -> ReadS Length
ReadS [Length]
(Int -> ReadS Length)
-> ReadS [Length]
-> ReadPrec Length
-> ReadPrec [Length]
-> Read 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
(Int -> Length -> ShowS)
-> (Length -> String) -> ([Length] -> ShowS) -> Show Length
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]
(Length -> Length)
-> (Length -> Length)
-> (Int -> Length)
-> (Length -> Int)
-> (Length -> [Length])
-> (Length -> Length -> [Length])
-> (Length -> Length -> [Length])
-> (Length -> Length -> Length -> [Length])
-> Enum 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
(Int -> RsFlags -> ShowS)
-> (RsFlags -> String) -> ([RsFlags] -> ShowS) -> Show RsFlags
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]
(Int -> ReadS RsFlags)
-> ReadS [RsFlags]
-> ReadPrec RsFlags
-> ReadPrec [RsFlags]
-> Read 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 :: Length -> RsFlags
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
(Int -> Input -> ShowS)
-> (Input -> String) -> ([Input] -> ShowS) -> Show Input
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]
(Int -> ReadS Input)
-> ReadS [Input]
-> ReadPrec Input
-> ReadPrec [Input]
-> Read 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 ================"                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsCode      = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows      (Response -> Int
rsCode Response
res)                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsHeaders   = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> ShowS
forall a. Show a => a -> ShowS
shows      (Response -> Headers
rsHeaders Response
res)                     ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsFlags     = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RsFlags -> ShowS
forall a. Show a => a -> ShowS
shows      (Response -> RsFlags
rsFlags Response
res)                       ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsBody      = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShowS
forall a. Show a => a -> ShowS
shows      (Response -> ByteString
rsBody Response
res)                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsValidator = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
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 ================"                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsCode      = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows      (Response -> Int
rsCode Response
res)                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsHeaders   = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> ShowS
forall a. Show a => a -> ShowS
shows      (Response -> Headers
rsHeaders Response
res)                     ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsFlags     = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RsFlags -> ShowS
forall a. Show a => a -> ShowS
shows      (Response -> RsFlags
rsFlags Response
res)                       ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrsValidator = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows      (Maybe (Response -> IO Response) -> String
showRsValidator (Response -> Maybe (Response -> IO Response)
rsValidator Response
res)) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nsfFilePath  = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows      (Response -> String
sfFilePath Response
res)                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nsfOffset    = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> ShowS
forall a. Show a => a -> ShowS
shows      (Response -> Integer
sfOffset Response
res)                      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nsfCount     = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> ShowS
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 = String
-> ((Response -> IO Response) -> String)
-> Maybe (Response -> IO Response)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Nothing" (String -> (Response -> IO Response) -> String
forall a b. a -> b -> a
const String
"Just <function>")

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

-- | 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 =================" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqSecure      = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS
forall a. Show a => a -> ShowS
shows      (Request -> Bool
rqSecure Request
rq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqMethod      = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> ShowS
forall a. Show a => a -> ShowS
shows      (Request -> Method
rqMethod Request
rq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqPaths       = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ShowS
forall a. Show a => a -> ShowS
shows      (Request -> [String]
rqPaths Request
rq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqUri         = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Request -> String
rqUri Request
rq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqQuery       = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Request -> String
rqQuery Request
rq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqInputsQuery = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Input)] -> ShowS
forall a. Show a => a -> ShowS
shows      (Request -> [(String, Input)]
rqInputsQuery Request
rq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqInputsBody  = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"<<mvar>>" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqCookies     = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Cookie)] -> ShowS
forall a. Show a => a -> ShowS
shows      (Request -> [(String, Cookie)]
rqCookies Request
rq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqVersion     = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpVersion -> ShowS
forall a. Show a => a -> ShowS
shows      (Request -> HttpVersion
rqVersion Request
rq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqHeaders     = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> ShowS
forall a. Show a => a -> ShowS
shows      (Request -> Headers
rqHeaders Request
rq) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqBody        = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"<<mvar>>" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> ShowS
showString String
"\nrqPeer        = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> ShowS
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 :: Request -> m (Maybe RqBody)
takeRequestBody Request
rq = IO (Maybe RqBody) -> m (Maybe RqBody)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe RqBody) -> m (Maybe RqBody))
-> IO (Maybe RqBody) -> m (Maybe RqBody)
forall a b. (a -> b) -> a -> b
$ MVar RqBody -> IO (Maybe RqBody)
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 <- MVar [(String, Input)] -> IO (Maybe [(String, Input)])
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req)
       case Maybe [(String, Input)]
mbi of
         (Just [(String, Input)]
bi) ->
                do MVar [(String, Input)] -> [(String, Input)] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (Request -> MVar [(String, Input)]
rqInputsBody Request
req) [(String, Input)]
bi
                   Maybe [(String, Input)] -> IO (Maybe [(String, Input)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, Input)] -> Maybe [(String, Input)]
forall a. a -> Maybe a
Just [(String, Input)]
bi)
         Maybe [(String, Input)]
Nothing -> Maybe [(String, Input)] -> IO (Maybe [(String, Input)])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(String, Input)]
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
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" (Request -> [String]
rqPaths Request
rq) String -> ShowS
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 (Headers -> Headers) -> Headers -> Headers
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 (Headers -> Headers) -> Headers -> Headers
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         = 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]
(Int -> ReadS RqBody)
-> ReadS [RqBody]
-> ReadPrec RqBody
-> ReadPrec [RqBody]
-> Read 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
(Int -> RqBody -> ShowS)
-> (RqBody -> String) -> ([RqBody] -> ShowS) -> Show RqBody
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 :: Int -> Response -> m Response
setRsCode Int
code Response
rs = Response -> m Response
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
    = (HeaderPair -> HeaderPair -> HeaderPair)
-> [(ByteString, HeaderPair)] -> Headers
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith HeaderPair -> HeaderPair -> HeaderPair
join [ (String -> ByteString
P.pack ((Char -> Char) -> ShowS
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]
vs2[ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++[ByteString]
vs1)

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

-- | Lookup header value. Key is case-insensitive.
getHeader :: HasHeaders r => String -> r -> Maybe ByteString
getHeader :: String -> r -> Maybe ByteString
getHeader = ByteString -> r -> Maybe ByteString
forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderBS (ByteString -> r -> Maybe ByteString)
-> (String -> ByteString) -> String -> r -> Maybe ByteString
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 :: ByteString -> r -> Maybe ByteString
getHeaderBS = ByteString -> r -> Maybe ByteString
forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderUnsafe (ByteString -> r -> Maybe ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> r
-> Maybe ByteString
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 :: ByteString -> r -> Maybe ByteString
getHeaderUnsafe ByteString
key r
var = [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe ([ByteString] -> Maybe ByteString)
-> Maybe [ByteString] -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (HeaderPair -> [ByteString])
-> Maybe HeaderPair -> Maybe [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HeaderPair -> [ByteString]
hValue (ByteString -> r -> Maybe HeaderPair
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' :: ByteString -> r -> Maybe HeaderPair
getHeaderUnsafe' ByteString
key = ByteString -> Headers -> Maybe HeaderPair
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ByteString
key (Headers -> Maybe HeaderPair)
-> (r -> Headers) -> r -> Maybe HeaderPair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Headers
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 :: String -> r -> Bool
hasHeader String
key r
r = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (String -> r -> Maybe ByteString
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 :: ByteString -> r -> Bool
hasHeaderBS ByteString
key r
r = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (ByteString -> r -> Maybe ByteString
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 :: ByteString -> r -> Bool
hasHeaderUnsafe ByteString
key r
r = Maybe HeaderPair -> Bool
forall a. Maybe a -> Bool
isJust (ByteString -> r -> Maybe HeaderPair
forall r. HasHeaders r => ByteString -> r -> Maybe HeaderPair
getHeaderUnsafe' ByteString
key r
r)

checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderBS :: ByteString -> ByteString -> r -> Bool
checkHeaderBS ByteString
key ByteString
val = ByteString -> ByteString -> r -> Bool
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 :: ByteString -> ByteString -> r -> Bool
checkHeaderUnsafe ByteString
key ByteString
val r
r
    = case ByteString -> r -> Maybe ByteString
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' ByteString -> ByteString -> Bool
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 :: String -> String -> r -> r
setHeader String
key String
val = ByteString -> ByteString -> r -> r
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 :: ByteString -> ByteString -> r -> r
setHeaderBS ByteString
key ByteString
val = ByteString -> HeaderPair -> r -> r
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 :: ByteString -> HeaderPair -> r -> r
setHeaderUnsafe ByteString
key HeaderPair
val = (Headers -> Headers) -> r -> r
forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders (ByteString -> HeaderPair -> Headers -> Headers
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 :: String -> String -> r -> r
addHeader String
key String
val = ByteString -> ByteString -> r -> r
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 :: ByteString -> ByteString -> r -> r
addHeaderBS ByteString
key ByteString
val = ByteString -> HeaderPair -> r -> r
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 :: ByteString -> HeaderPair -> r -> r
addHeaderUnsafe ByteString
key HeaderPair
val = (Headers -> Headers) -> r -> r
forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders ((HeaderPair -> HeaderPair -> HeaderPair)
-> ByteString -> HeaderPair -> Headers -> Headers
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]
vs2[ByteString] -> [ByteString] -> [ByteString]
forall 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 (ByteString -> Response)
-> (String -> ByteString) -> String -> Response
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 Headers
forall k a. Map k a
M.empty RsFlags
nullRsFlags ByteString
s Maybe (Response -> IO Response)
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 :: Int -> s -> Response -> Response
redirect Int
c s
s Response
resp = ByteString -> ByteString -> Response -> Response
forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS ByteString
locationC (String -> ByteString
pack (SURI -> String
forall a. ToSURI a => a -> String
render (s -> SURI
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' :: String -> a
readDec' String
s =
  case ReadS a
forall a. (Eq a, Num a) => ReadS a
readDec String
s of
    [(a
n,[])] -> a
n
    [(a, String)]
_    -> String -> a
forall a. HasCallStack => String -> a
error String
"readDec' failed."

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