{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE EmptyDataDecls            #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE ForeignFunctionInterface  #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE Rank2Types                #-}
{-# LANGUAGE TypeSynonymInstances      #-}

------------------------------------------------------------------------------
-- | An internal Snap module containing HTTP types.
--
-- /N.B./ this is an internal interface, please don't write user code that
-- depends on it. Most of these declarations (except for the
-- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Core".
--
module Snap.Internal.Http.Types where

------------------------------------------------------------------------------
import           Control.Monad              (unless)
import           Data.ByteString            (ByteString)
import           Data.ByteString.Builder    (Builder, byteString, toLazyByteString)
import qualified Data.ByteString.Char8      as S
import qualified Data.ByteString.Lazy.Char8 as L
import           Data.CaseInsensitive       (CI)
import qualified Data.CaseInsensitive       as CI
import qualified Data.IntMap                as IM
import           Data.List                  hiding (take)
import           Data.Map                   (Map)
import qualified Data.Map                   as Map
import           Data.Maybe                 (Maybe (..), fromMaybe, maybe)
import           Data.Monoid                (mconcat)
import           Data.Time.Clock            (UTCTime)
import           Data.Time.Clock.POSIX      (utcTimeToPOSIXSeconds)
import           Data.Word                  (Word64)
import           Foreign.C.Types            (CTime (..))
import           Prelude                    (Bool (..), Eq (..), FilePath, IO, Int, Integral (..), Monad (..), Num ((-)), Ord (..), Ordering (..), Read (..), Show (..), String, fmap, fromInteger, fromIntegral, id, not, otherwise, truncate, ($), (.))
#ifdef PORTABLE
import           Prelude                    (realToFrac, ($!))
#endif
import           System.IO                  (IOMode (ReadMode), SeekMode (AbsoluteSeek), hSeek, withBinaryFile)
import           System.IO.Streams          (InputStream, OutputStream)
import qualified System.IO.Streams          as Streams
import           System.IO.Unsafe           (unsafePerformIO)

------------------------------------------------------------------------------
#ifdef PORTABLE
import           Data.Time.Clock.POSIX
import           Data.Time.Clock.POSIX
import           Data.Time.Format
import           Data.Time.Locale.Compat    (defaultTimeLocale)
import           Data.Time.LocalTime
#else
import qualified Data.ByteString.Unsafe     as S
import           Data.Time.Format           ()
import           Foreign.C.String           (CString)
import           Foreign.Marshal.Alloc      (mallocBytes)
#endif

------------------------------------------------------------------------------
import           Snap.Types.Headers         (Headers)
import qualified Snap.Types.Headers         as H


#ifndef PORTABLE

------------------------------------------------------------------------------
-- foreign imports from cbits
foreign import ccall unsafe "set_c_locale"
        set_c_locale :: IO ()

foreign import ccall unsafe "c_parse_http_time"
        c_parse_http_time :: CString -> IO CTime

foreign import ccall unsafe "c_format_http_time"
        c_format_http_time :: CTime -> CString -> IO ()

foreign import ccall unsafe "c_format_log_time"
        c_format_log_time :: CTime -> CString -> IO ()

#endif


------------------------------------------------------------------------------
-- | A typeclass for datatypes which contain HTTP headers.
class HasHeaders a where
    -- | Modify the datatype's headers.
    updateHeaders :: (Headers -> Headers) -> a -> a

    -- | Retrieve the headers from a datatype that has headers.
    headers       :: a -> Headers


------------------------------------------------------------------------------
-- | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header
-- with the same name already exists, the new value is appended to the headers
-- list.
--
-- Example:
--
-- @
-- ghci> import qualified "Snap.Types.Headers" as H
-- ghci> 'addHeader' \"Host\" "localhost" H.'empty'
-- H {unH = [("host","localhost")]}
-- ghci> 'addHeader' \"Host\" "127.0.0.1" it
-- H {unH = [("host","localhost,127.0.0.1")]}
-- @
addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
addHeader :: CI ByteString -> ByteString -> a -> a
addHeader k :: CI ByteString
k v :: ByteString
v = (Headers -> Headers) -> a -> a
forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders ((Headers -> Headers) -> a -> a) -> (Headers -> Headers) -> a -> a
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString -> Headers -> Headers
H.insert CI ByteString
k ByteString
v


------------------------------------------------------------------------------
-- | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with
-- the same name already exists, it is overwritten with the new value.
--
-- Example:
--
-- @
-- ghci> import qualified "Snap.Types.Headers" as H
-- ghci> 'setHeader' \"Host\" "localhost" H.'empty'
-- H {unH = [(\"host\",\"localhost\")]}
-- ghci> setHeader \"Host\" "127.0.0.1" it
-- H {unH = [("host","127.0.0.1")]}
-- @
setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
setHeader :: CI ByteString -> ByteString -> a -> a
setHeader k :: CI ByteString
k v :: ByteString
v = (Headers -> Headers) -> a -> a
forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders ((Headers -> Headers) -> a -> a) -> (Headers -> Headers) -> a -> a
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString -> Headers -> Headers
H.set CI ByteString
k ByteString
v


------------------------------------------------------------------------------
-- | Gets a header value out of a 'HasHeaders' datatype.
--
-- Example:
--
-- @
-- ghci> import qualified "Snap.Types.Headers" as H
-- ghci> 'getHeader' \"Host\" $ 'setHeader' \"Host\" "localhost" H.'empty'
-- Just "localhost"
-- @
getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString
getHeader :: CI ByteString -> a -> Maybe ByteString
getHeader k :: CI ByteString
k a :: a
a = CI ByteString -> Headers -> Maybe ByteString
H.lookup CI ByteString
k (Headers -> Maybe ByteString) -> Headers -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ a -> Headers
forall a. HasHeaders a => a -> Headers
headers a
a


------------------------------------------------------------------------------
-- | Lists all the headers out of a 'HasHeaders' datatype. If many
-- headers came in with the same name, they will be catenated together.
--
-- Example:
--
-- @
-- ghci> import qualified "Snap.Types.Headers" as H
-- ghci> 'listHeaders' $ 'setHeader' \"Host\" "localhost" H.'empty'
-- [("host","localhost")]
-- @
listHeaders :: (HasHeaders a) => a -> [(CI ByteString, ByteString)]
listHeaders :: a -> [(CI ByteString, ByteString)]
listHeaders = Headers -> [(CI ByteString, ByteString)]
H.toList (Headers -> [(CI ByteString, ByteString)])
-> (a -> Headers) -> a -> [(CI ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Headers
forall a. HasHeaders a => a -> Headers
headers


------------------------------------------------------------------------------
-- | Clears a header value from a 'HasHeaders' datatype.
--
-- Example:
--
-- @
-- ghci> import qualified "Snap.Types.Headers" as H
-- ghci> 'deleteHeader' \"Host\" $ 'setHeader' \"Host\" "localhost" H.'empty'
-- H {unH = []}
-- @
deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a
deleteHeader :: CI ByteString -> a -> a
deleteHeader k :: CI ByteString
k = (Headers -> Headers) -> a -> a
forall a. HasHeaders a => (Headers -> Headers) -> a -> a
updateHeaders ((Headers -> Headers) -> a -> a) -> (Headers -> Headers) -> a -> a
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Headers -> Headers
H.delete CI ByteString
k


------------------------------------------------------------------------------
-- | Enumerates the HTTP method values (see
-- <http://tools.ietf.org/html/rfc2068.html#section-5.1.1>).
data Method  = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT |
               PATCH | Method 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)

instance Eq Method where
    a :: Method
a == :: Method -> Method -> Bool
== b :: Method
b =
        Method -> Method
normalizeMethod Method
a Method -> Method -> Bool
`eq` Method -> Method
normalizeMethod Method
b
      where
        GET       eq :: Method -> Method -> Bool
`eq` GET       = Bool
True
        HEAD      `eq` HEAD      = Bool
True
        POST      `eq` POST      = Bool
True
        PUT       `eq` PUT       = Bool
True
        DELETE    `eq` DELETE    = Bool
True
        TRACE     `eq` TRACE     = Bool
True
        OPTIONS   `eq` OPTIONS   = Bool
True
        CONNECT   `eq` CONNECT   = Bool
True
        PATCH     `eq` PATCH     = Bool
True
        Method x1 :: ByteString
x1 `eq` Method y1 :: ByteString
y1 = ByteString
x1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
y1
        _         `eq` _         = Bool
False

instance Ord Method where
        compare :: Method -> Method -> Ordering
compare a :: Method
a b :: Method
b =
            Method -> Method -> Ordering
check (Method -> Method
normalizeMethod Method
a) (Method -> Method
normalizeMethod Method
b)
          where
            check :: Method -> Method -> Ordering
check   GET          GET           = Ordering
EQ
            check   HEAD         HEAD          = Ordering
EQ
            check   POST         POST          = Ordering
EQ
            check   PUT          PUT           = Ordering
EQ
            check   DELETE       DELETE        = Ordering
EQ
            check   TRACE        TRACE         = Ordering
EQ
            check   OPTIONS      OPTIONS       = Ordering
EQ
            check   CONNECT      CONNECT       = Ordering
EQ
            check   PATCH        PATCH         = Ordering
EQ
            check   (Method  x1 :: ByteString
x1) (Method   y1 :: ByteString
y1) = ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ByteString
x1 ByteString
y1
            check   x :: Method
x            y :: Method
y             = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Method -> Int
tag Method
x) (Method -> Int
tag Method
y)

            tag :: Method -> Int
            tag :: Method -> Int
tag (GET{})     = 0
            tag (HEAD{})    = 1
            tag (POST{})    = 2
            tag (PUT{})     = 3
            tag (DELETE{})  = 4
            tag (TRACE{})   = 5
            tag (OPTIONS{}) = 6
            tag (CONNECT{}) = 7
            tag (PATCH{})   = 8
            tag (Method{})  = 9

-- | Equate the special case constructors with their corresponding
-- @Method name@ variant.
{-# INLINE normalizeMethod #-}
normalizeMethod :: Method -> Method
normalizeMethod :: Method -> Method
normalizeMethod m :: Method
m@(Method name :: ByteString
name) = case ByteString
name of
                                    "GET"     -> Method
GET
                                    "HEAD"    -> Method
HEAD
                                    "POST"    -> Method
POST
                                    "PUT"     -> Method
PUT
                                    "DELETE"  -> Method
DELETE
                                    "TRACE"   -> Method
TRACE
                                    "OPTIONS" -> Method
OPTIONS
                                    "CONNECT" -> Method
CONNECT
                                    "PATCH"   -> Method
PATCH
                                    _         -> Method
m
normalizeMethod m :: Method
m               = Method
m


------------------------------------------------------------------------------
-- | Represents a (major, minor) version of the HTTP protocol.
type HttpVersion = (Int,Int)


------------------------------------------------------------------------------
-- | A datatype representing an HTTP cookie.
data Cookie = Cookie {
      -- | The name of the cookie.
      Cookie -> ByteString
cookieName     :: !ByteString

      -- | The cookie's string value.
    , Cookie -> ByteString
cookieValue    :: !ByteString

      -- | The cookie's expiration value, if it has one.
    , Cookie -> Maybe UTCTime
cookieExpires  :: !(Maybe UTCTime)

      -- | The cookie's \"domain\" value, if it has one.
    , Cookie -> Maybe ByteString
cookieDomain   :: !(Maybe ByteString)

      -- | The cookie path.
    , Cookie -> Maybe ByteString
cookiePath     :: !(Maybe ByteString)

      -- | Tag as secure cookie?
    , Cookie -> Bool
cookieSecure   :: !Bool

      -- | HTTP only?
    , Cookie -> Bool
cookieHttpOnly :: !Bool
} deriving (Cookie -> Cookie -> Bool
(Cookie -> Cookie -> Bool)
-> (Cookie -> Cookie -> Bool) -> Eq Cookie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cookie -> Cookie -> Bool
$c/= :: Cookie -> Cookie -> Bool
== :: Cookie -> Cookie -> Bool
$c== :: Cookie -> Cookie -> Bool
Eq, Int -> Cookie -> ShowS
[Cookie] -> ShowS
Cookie -> String
(Int -> Cookie -> ShowS)
-> (Cookie -> String) -> ([Cookie] -> ShowS) -> Show Cookie
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cookie] -> ShowS
$cshowList :: [Cookie] -> ShowS
show :: Cookie -> String
$cshow :: Cookie -> String
showsPrec :: Int -> Cookie -> ShowS
$cshowsPrec :: Int -> Cookie -> ShowS
Show)


------------------------------------------------------------------------------
-- | A type alias for the HTTP parameters mapping. Each parameter
-- key maps to a list of 'ByteString' values; if a parameter is specified
-- multiple times (e.g.: \"@GET /foo?param=bar1&param=bar2@\"), looking up
-- \"@param@\" in the mapping will give you @[\"bar1\", \"bar2\"]@.
type Params = Map ByteString [ByteString]


------------------------------------------------------------------------------
-- request type
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- | Contains all of the information about an incoming HTTP request.
data Request = Request
    { -- | The server name of the request, as it came in from the request's
      -- @Host:@ header.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> :{
      -- ghci| rq <- T.buildRequest $ do
      -- ghci|         T.get "\/foo\/bar" M.empty
      -- ghci|         T.setHeader "host" "example.com"
      -- ghci| :}
      -- ghci> rqHostName rq
      -- "example.com"
      -- @
      Request -> ByteString
rqHostName      :: ByteString

      -- | The remote IP address.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqClientAddr \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- "127.0.0.1"
      -- @
    , Request -> ByteString
rqClientAddr    :: ByteString

      -- | The remote TCP port number.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqClientPort \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- "60000"
      -- @
    , Request -> Int
rqClientPort    :: {-# UNPACK #-} !Int

      -- | The local IP address for this request.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqServerAddr \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- "127.0.0.1"
      -- @
    , Request -> ByteString
rqServerAddr    :: ByteString

      -- | Returns the port number the HTTP server is listening on. This may be
      -- useless from the perspective of external requests, e.g. if the server
      -- is running behind a proxy.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqServerPort \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- 8080
      -- @
    , Request -> Int
rqServerPort    :: {-# UNPACK #-} !Int

      -- | Returns the HTTP server's idea of its local hostname, including
      -- port. This is as configured with the @Config@ object at startup.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqLocalHostname \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- "localhost"
      -- @
    , Request -> ByteString
rqLocalHostname :: ByteString

      -- | Returns @True@ if this is an HTTPS session.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqIsSecure \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- False
      -- @
    , Request -> Bool
rqIsSecure      :: !Bool

      -- | Contains all HTTP 'Headers' associated with this request.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqHeaders \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- H {unH = [("host","localhost")]}
      -- @
    , Request -> Headers
rqHeaders       :: Headers

      -- | Actual body of the request.
    , Request -> InputStream ByteString
rqBody          :: InputStream ByteString

      -- | Returns the @Content-Length@ of the HTTP request body.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqContentLength \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- Nothing
      -- @
    , Request -> Maybe Word64
rqContentLength :: !(Maybe Word64)

      -- | Returns the HTTP request method.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqMethod \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- GET
      -- @
    , Request -> Method
rqMethod        :: !Method

      -- | Returns the HTTP version used by the client.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqVersion \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- (1,1)
      -- @
    , Request -> HttpVersion
rqVersion       :: {-# UNPACK #-} !HttpVersion

      -- | Returns a list of the cookies that came in from the HTTP request
      -- headers.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqCookies \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- []
      -- @
    , Request -> [Cookie]
rqCookies       :: [Cookie]

      -- | Handlers can be hung on a @URI@ \"entry point\"; this is called the
      -- \"context path\". If a handler is hung on the context path
      -- @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the value of
      -- 'rqPathInfo' will be @\"bar\"@.
      --
      -- The following identity holds:
      --
      -- > rqURI r == S.concat [ rqContextPath r
      -- >                     , rqPathInfo r
      -- >                     , let q = rqQueryString r
      -- >                       in if S.null q
      -- >                            then ""
      -- >                            else S.append "?" q
      -- >                     ]
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqPathInfo \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- "foo/bar"
      -- @
    , Request -> ByteString
rqPathInfo      :: ByteString

      -- | The \"context path\" of the request; catenating 'rqContextPath',
      -- and 'rqPathInfo' should get you back to the original 'rqURI'
      -- (ignoring query strings). The 'rqContextPath' always begins and ends
      -- with a slash (@\"\/\"@) character, and represents the path (relative
      -- to your component\/snaplet) you took to get to your handler.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqContextPath \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- "/"
      -- @
    , Request -> ByteString
rqContextPath   :: ByteString

      -- | Returns the @URI@ requested by the client.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rqURI \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty)
      -- "foo/bar"
      -- @
    , Request -> ByteString
rqURI           :: ByteString

      -- | Returns the HTTP query string for this 'Request'.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> rq <- T.buildRequest (T.get "\/foo\/bar" (M.fromList [("name", ["value"])]))
      -- ghci> rqQueryString rq
      -- "name=value"
      -- @
    , Request -> ByteString
rqQueryString   :: ByteString

      -- | Returns the parameters mapping for this 'Request'. \"Parameters\"
      -- are automatically decoded from the URI's query string and @POST@ body
      -- and entered into this mapping. The 'rqParams' value is thus a union of
      -- 'rqQueryParams' and 'rqPostParams'.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> :{
      -- ghci| rq <- T.buildRequest $ do
      -- ghci|         T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]
      -- ghci|         T.setQueryStringRaw "baz=quux"
      -- ghci| :}
      -- ghci> rqParams rq
      -- fromList [("baz",["qux","quux"])]
      -- @
    , Request -> Params
rqParams        :: Params

      -- | The parameter mapping decoded from the URI's query string.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> :{
      -- ghci| rq <- T.buildRequest $ do
      -- ghci|         T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]
      -- ghci|         T.setQueryStringRaw "baz=quux"
      -- ghci| :}
      -- ghci> rqQueryParams rq
      -- fromList [("baz",["quux"])]
      -- @
    , Request -> Params
rqQueryParams   :: Params

      -- | The parameter mapping decoded from the POST body. Note that Snap
      -- only auto-decodes POST request bodies when the request's
      -- @Content-Type@ is @application\/x-www-form-urlencoded@.
      -- For @multipart\/form-data@ use 'Snap.Util.FileUploads.handleFileUploads'
      -- to decode the POST request and fill this mapping.
      --
      -- Example:
      --
      -- @
      -- ghci> :set -XOverloadedStrings
      -- ghci> import qualified "Snap.Test" as T
      -- ghci> import qualified "Data.Map" as M
      -- ghci> :{
      -- ghci| rq <- T.buildRequest $ do
      -- ghci|         T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]
      -- ghci|         T.setQueryStringRaw "baz=quux"
      -- ghci| :}
      -- ghci> rqPostParams rq
      -- fromList [("baz",["qux"])]
      -- @
    , Request -> Params
rqPostParams    :: Params
    }


------------------------------------------------------------------------------
instance Show Request where
  show :: Request -> String
show r :: Request
r = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
method, " ", String
uri, " HTTP/", String
version, "\n"
                  , String
hdrs, "\n\n"
                  , "sn=\"", String
sname, "\" c=", String
clntAddr, " s=", String
srvAddr
                  , " ctx=", String
contextpath, " clen=", String
contentlength, String
secure
                  , String
params, String
cookies
                  ]
    where
      method :: String
method        = Method -> String
forall a. Show a => a -> String
show (Method -> String) -> Method -> String
forall a b. (a -> b) -> a -> b
$ Request -> Method
rqMethod Request
r
      uri :: String
uri           = ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqURI Request
r
      version :: String
version       = let (mj :: Int
mj, mn :: Int
mn) = Request -> HttpVersion
rqVersion Request
r in Int -> String
forall a. Show a => a -> String
show Int
mj String -> ShowS
forall a. [a] -> [a] -> [a]
++ "." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
mn
      hdrs :: String
hdrs          = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((CI ByteString, ByteString) -> String)
-> [(CI ByteString, ByteString)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> String
showHdr (Headers -> [(CI ByteString, ByteString)]
H.toList (Headers -> [(CI ByteString, ByteString)])
-> Headers -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> Headers
rqHeaders Request
r)
      showHdr :: (CI ByteString, ByteString) -> String
showHdr (a :: CI ByteString
a,b :: ByteString
b) = (ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
S.unpack ByteString
b
      sname :: String
sname         = ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqLocalHostname Request
r
      clntAddr :: String
clntAddr      = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqClientAddr Request
r, ":", Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Request -> Int
rqClientPort Request
r]
      srvAddr :: String
srvAddr       = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqServerAddr Request
r, ":", Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Request -> Int
rqServerPort Request
r]
      contextpath :: String
contextpath   = ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqContextPath Request
r
      contentlength :: String
contentlength = String -> (Word64 -> String) -> Maybe Word64 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "n/a" Word64 -> String
forall a. Show a => a -> String
show (Request -> Maybe Word64
rqContentLength Request
r)
      secure :: String
secure        = if Request -> Bool
rqIsSecure Request
r then " secure" else ""

      params :: String
params        = String -> String -> [String] -> String
showFlds "\nparams: " ", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                      ((ByteString, [ByteString]) -> String)
-> [(ByteString, [ByteString])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (a :: ByteString
a,b :: [ByteString]
b) -> ByteString -> String
S.unpack ByteString
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [ByteString] -> String
forall a. Show a => a -> String
show [ByteString]
b)
                      (Params -> [(ByteString, [ByteString])]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Params -> [(ByteString, [ByteString])])
-> Params -> [(ByteString, [ByteString])]
forall a b. (a -> b) -> a -> b
$ Request -> Params
rqParams Request
r)
      cookies :: String
cookies       = String -> String -> [String] -> String
showFlds "\ncookies: " "\n         " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                      (Cookie -> String) -> [Cookie] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cookie -> String
forall a. Show a => a -> String
show (Request -> [Cookie]
rqCookies Request
r)

      showFlds :: String -> String -> [String] -> String
showFlds header :: String
header delim :: String
delim lst :: [String]
lst
                    = if Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ [String]
lst then String
header String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
delim [String]
lst)
                      else "" :: String

------------------------------------------------------------------------------
instance HasHeaders Request where
    headers :: Request -> Headers
headers           = Request -> Headers
rqHeaders
    updateHeaders :: (Headers -> Headers) -> Request -> Request
updateHeaders f :: Headers -> Headers
f r :: Request
r = Request
r { rqHeaders :: Headers
rqHeaders = Headers -> Headers
f (Request -> Headers
rqHeaders Request
r) }


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

------------------------------------------------------------------------------
-- response type
------------------------------------------------------------------------------

type StreamProc = OutputStream Builder -> IO (OutputStream Builder)
data ResponseBody = Stream (StreamProc)
                      -- ^ output body is a function that writes to a 'Builder'
                      -- stream

                  | SendFile FilePath (Maybe (Word64, Word64))
                      -- ^ output body is sendfile(), optional second argument
                      --   is a byte range to send


------------------------------------------------------------------------------
rspBodyMap :: (StreamProc -> StreamProc) -> ResponseBody -> ResponseBody
rspBodyMap :: (StreamProc -> StreamProc) -> ResponseBody -> ResponseBody
rspBodyMap f :: StreamProc -> StreamProc
f b :: ResponseBody
b = StreamProc -> ResponseBody
Stream (StreamProc -> ResponseBody) -> StreamProc -> ResponseBody
forall a b. (a -> b) -> a -> b
$ StreamProc -> StreamProc
f (StreamProc -> StreamProc) -> StreamProc -> StreamProc
forall a b. (a -> b) -> a -> b
$ ResponseBody -> StreamProc
rspBodyToEnum ResponseBody
b


------------------------------------------------------------------------------
rspBodyToEnum :: ResponseBody -> StreamProc
rspBodyToEnum :: ResponseBody -> StreamProc
rspBodyToEnum (Stream e :: StreamProc
e) = StreamProc
e

rspBodyToEnum (SendFile fp :: String
fp Nothing) = \out :: OutputStream Builder
out ->
    String
-> (InputStream ByteString -> IO (OutputStream Builder))
-> IO (OutputStream Builder)
forall a. String -> (InputStream ByteString -> IO a) -> IO a
Streams.withFileAsInput String
fp ((InputStream ByteString -> IO (OutputStream Builder))
 -> IO (OutputStream Builder))
-> (InputStream ByteString -> IO (OutputStream Builder))
-> IO (OutputStream Builder)
forall a b. (a -> b) -> a -> b
$ \is :: InputStream ByteString
is -> do
        InputStream Builder
is' <- (ByteString -> IO Builder)
-> InputStream ByteString -> IO (InputStream Builder)
forall a b. (a -> IO b) -> InputStream a -> IO (InputStream b)
Streams.mapM (Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> IO Builder)
-> (ByteString -> Builder) -> ByteString -> IO Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString) InputStream ByteString
is
        InputStream Builder -> OutputStream Builder -> IO ()
forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream Builder
is' OutputStream Builder
out
        StreamProc
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
out

rspBodyToEnum (SendFile fp :: String
fp (Just (start :: Word64
start, end :: Word64
end))) = \out :: OutputStream Builder
out ->
    String
-> IOMode
-> (Handle -> IO (OutputStream Builder))
-> IO (OutputStream Builder)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
fp IOMode
ReadMode ((Handle -> IO (OutputStream Builder))
 -> IO (OutputStream Builder))
-> (Handle -> IO (OutputStream Builder))
-> IO (OutputStream Builder)
forall a b. (a -> b) -> a -> b
$ \handle :: Handle
handle -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word64
start Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
handle SeekMode
AbsoluteSeek (Integer -> IO ()) -> Integer -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
start
        InputStream ByteString
is  <- Handle -> IO (InputStream ByteString)
Streams.handleToInputStream Handle
handle
        InputStream Builder
is' <- Int64 -> InputStream ByteString -> IO (InputStream ByteString)
Streams.takeBytes (Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int64) -> Word64 -> Int64
forall a b. (a -> b) -> a -> b
$ Word64
end Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
start) InputStream ByteString
is IO (InputStream ByteString)
-> (InputStream ByteString -> IO (InputStream Builder))
-> IO (InputStream Builder)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
               (ByteString -> IO Builder)
-> InputStream ByteString -> IO (InputStream Builder)
forall a b. (a -> IO b) -> InputStream a -> IO (InputStream b)
Streams.mapM (Builder -> IO Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> IO Builder)
-> (ByteString -> Builder) -> ByteString -> IO Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteString)
        InputStream Builder -> OutputStream Builder -> IO ()
forall a. InputStream a -> OutputStream a -> IO ()
Streams.connect InputStream Builder
is' OutputStream Builder
out
        StreamProc
forall (m :: * -> *) a. Monad m => a -> m a
return OutputStream Builder
out


------------------------------------------------------------------------------
-- | Represents an HTTP response.
data Response = Response
    { Response -> Headers
rspHeaders            :: Headers
    , Response -> Map ByteString Cookie
rspCookies            :: Map ByteString Cookie

      -- | We will need to inspect the content length no matter what, and
      --   looking up \"content-length\" in the headers and parsing the number
      --   out of the text will be too expensive.
    , Response -> Maybe Word64
rspContentLength      :: !(Maybe Word64)
    , Response -> ResponseBody
rspBody               :: ResponseBody

      -- | Returns the HTTP status code.
      --
      -- Example:
      --
      -- @
      -- ghci> rspStatus 'emptyResponse'
      -- 200
      -- @
    , Response -> Int
rspStatus             :: !Int

      -- | Returns the HTTP status explanation string.
      --
      -- Example:
      --
      -- @
      -- ghci> rspStatusReason 'emptyResponse'
      -- "OK"
      -- @
    , Response -> ByteString
rspStatusReason       :: !ByteString

      -- | If true, we are transforming the request body with
      -- 'transformRequestBody'
    , Response -> Bool
rspTransformingRqBody :: !Bool
    }


------------------------------------------------------------------------------
instance Show Response where
  show :: Response -> String
show r :: Response
r = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
statusline
                  , String
hdrs
                  , String
contentLength
                  , "\r\n"
                  , String
body
                  ]
    where
      statusline :: String
statusline = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ "HTTP/1.1 "
                          , Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Response -> Int
rspStatus Response
r
                          , " "
                          , ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Response -> ByteString
rspStatusReason Response
r
                          , "\r\n" ]

      hdrs :: String
hdrs = ((CI ByteString, ByteString) -> String)
-> [(CI ByteString, ByteString)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CI ByteString, ByteString) -> String
showHdr ([(CI ByteString, ByteString)] -> String)
-> [(CI ByteString, ByteString)] -> String
forall a b. (a -> b) -> a -> b
$ Headers -> [(CI ByteString, ByteString)]
H.toList (Headers -> [(CI ByteString, ByteString)])
-> Headers -> [(CI ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ Response -> Headers -> Headers
renderCookies Response
r
             (Headers -> Headers) -> Headers -> Headers
forall a b. (a -> b) -> a -> b
$ Response -> Headers
rspHeaders (Response -> Headers) -> Response -> Headers
forall a b. (a -> b) -> a -> b
$ Response -> Response
clearContentLength Response
r

      contentLength :: String
contentLength = String -> (Word64 -> String) -> Maybe Word64 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\l :: Word64
l -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["Content-Length: ", Word64 -> String
forall a. Show a => a -> String
show Word64
l, "\r\n"] ) (Response -> Maybe Word64
rspContentLength Response
r)

      showHdr :: (CI ByteString, ByteString) -> String
showHdr (k :: CI ByteString
k,v :: ByteString
v) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ ByteString -> String
S.unpack (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
k), ": ", ByteString -> String
S.unpack ByteString
v, "\r\n" ]

      -- io-streams are impure, so we're forced to use 'unsafePerformIO'.
      body :: String
body = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ do
        (os :: OutputStream Builder
os, grab :: IO [Builder]
grab) <- IO (OutputStream Builder, IO [Builder])
forall c. IO (OutputStream c, IO [c])
Streams.listOutputStream
        let f :: StreamProc
f = ResponseBody -> StreamProc
rspBodyToEnum (ResponseBody -> StreamProc) -> ResponseBody -> StreamProc
forall a b. (a -> b) -> a -> b
$ Response -> ResponseBody
rspBody Response
r
        OutputStream Builder
_ <- StreamProc
f OutputStream Builder
os
        ([Builder] -> String) -> IO [Builder] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> String
L.unpack (ByteString -> String)
-> ([Builder] -> ByteString) -> [Builder] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> ([Builder] -> Builder) -> [Builder] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat) IO [Builder]
grab



------------------------------------------------------------------------------
instance HasHeaders Response where
    headers :: Response -> Headers
headers = Response -> Headers
rspHeaders
    updateHeaders :: (Headers -> Headers) -> Response -> Response
updateHeaders f :: Headers -> Headers
f r :: Response
r = Response
r { rspHeaders :: Headers
rspHeaders = Headers -> Headers
f (Response -> Headers
rspHeaders Response
r) }


------------------------------------------------------------------------------
-- | Looks up the value(s) for the given named parameter. Parameters initially
-- come from the request's query string and any decoded POST body (if the
-- request's @Content-Type@ is @application\/x-www-form-urlencoded@).
-- Parameter values can be modified within handlers using "rqModifyParams".
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.Map" as M
-- ghci> :{
-- ghci| rq <- T.buildRequest $ do
-- ghci|         T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]
-- ghci|         T.setQueryStringRaw "baz=quux"
-- ghci| :}
-- ghci> 'rqParam' "baz" rq
-- Just ["qux","quux"]
-- @
rqParam :: ByteString           -- ^ parameter name to look up
        -> Request              -- ^ HTTP request
        -> Maybe [ByteString]
rqParam :: ByteString -> Request -> Maybe [ByteString]
rqParam k :: ByteString
k rq :: Request
rq = ByteString -> Params -> Maybe [ByteString]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
k (Params -> Maybe [ByteString]) -> Params -> Maybe [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> Params
rqParams Request
rq
{-# INLINE rqParam #-}


------------------------------------------------------------------------------
-- | Looks up the value(s) for the given named parameter in the POST parameters
-- mapping.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.Map" as M
-- ghci> :{
-- ghci| rq <- T.buildRequest $ do
-- ghci|         T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]
-- ghci|         T.setQueryStringRaw "baz=quux"
-- ghci| :}
-- ghci> 'rqPostParam' "baz" rq
-- Just ["qux"]
-- @
rqPostParam :: ByteString           -- ^ parameter name to look up
            -> Request              -- ^ HTTP request
            -> Maybe [ByteString]
rqPostParam :: ByteString -> Request -> Maybe [ByteString]
rqPostParam k :: ByteString
k rq :: Request
rq = ByteString -> Params -> Maybe [ByteString]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
k (Params -> Maybe [ByteString]) -> Params -> Maybe [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> Params
rqPostParams Request
rq
{-# INLINE rqPostParam #-}


------------------------------------------------------------------------------
-- | Looks up the value(s) for the given named parameter in the query
-- parameters mapping.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.Map" as M
-- ghci> :{
-- ghci| rq <- T.buildRequest $ do
-- ghci|         T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]
-- ghci|         T.setQueryStringRaw "baz=quux"
-- ghci| :}
-- ghci> 'rqQueryParam' "baz" rq
-- Just ["quux"]
-- @
rqQueryParam :: ByteString           -- ^ parameter name to look up
             -> Request              -- ^ HTTP request
             -> Maybe [ByteString]
rqQueryParam :: ByteString -> Request -> Maybe [ByteString]
rqQueryParam k :: ByteString
k rq :: Request
rq = ByteString -> Params -> Maybe [ByteString]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
k (Params -> Maybe [ByteString]) -> Params -> Maybe [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> Params
rqQueryParams Request
rq
{-# INLINE rqQueryParam #-}


------------------------------------------------------------------------------
-- | Modifies the parameters mapping (which is a @Map ByteString ByteString@)
-- in a 'Request' using the given function.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.Map" as M
-- ghci> :{
-- ghci| rq <- T.buildRequest $ do
-- ghci|         T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]
-- ghci|         T.setQueryStringRaw "baz=quux"
-- ghci| :}
-- ghci> 'rqParams' rq
-- fromList [("baz",["qux","quux"])]
-- ghci> 'rqParams' $ 'rqModifyParams' (M.delete "baz") rq
-- fromList []
-- @
rqModifyParams :: (Params -> Params) -> Request -> Request
rqModifyParams :: (Params -> Params) -> Request -> Request
rqModifyParams f :: Params -> Params
f r :: Request
r = Request
r { rqParams :: Params
rqParams = Params
p }
  where
    p :: Params
p = Params -> Params
f (Params -> Params) -> Params -> Params
forall a b. (a -> b) -> a -> b
$ Request -> Params
rqParams Request
r
{-# INLINE rqModifyParams #-}


------------------------------------------------------------------------------
-- | Writes a key-value pair to the parameters mapping within the given
-- request.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "Snap.Test" as T
-- ghci> import qualified "Data.Map" as M
-- ghci> :{
-- ghci| rq <- T.buildRequest $ do
-- ghci|         T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])]
-- ghci|         T.setQueryStringRaw "baz=quux"
-- ghci| :}
-- ghci> 'rqParams' rq
-- fromList [("baz",["qux","quux"])]
-- ghci> 'rqParams' $ 'rqSetParam' "baz" ["corge"] rq
-- fromList [("baz", ["corge"])]
-- @
rqSetParam :: ByteString        -- ^ parameter name
           -> [ByteString]      -- ^ parameter values
           -> Request           -- ^ request
           -> Request
rqSetParam :: ByteString -> [ByteString] -> Request -> Request
rqSetParam k :: ByteString
k v :: [ByteString]
v = (Params -> Params) -> Request -> Request
rqModifyParams ((Params -> Params) -> Request -> Request)
-> (Params -> Params) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> Params -> Params
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ByteString
k [ByteString]
v
{-# INLINE rqSetParam #-}


                                ---------------
                                -- responses --
                                ---------------

------------------------------------------------------------------------------
-- | An empty 'Response'.
--
-- Example:
--
-- @
-- ghci> 'emptyResponse'
-- HTTP\/1.1 200 OK
--
--
-- @
emptyResponse :: Response
emptyResponse :: Response
emptyResponse = Headers
-> Map ByteString Cookie
-> Maybe Word64
-> ResponseBody
-> Int
-> ByteString
-> Bool
-> Response
Response Headers
H.empty Map ByteString Cookie
forall k a. Map k a
Map.empty Maybe Word64
forall a. Maybe a
Nothing
                         (StreamProc -> ResponseBody
Stream (StreamProc
forall (m :: * -> *) a. Monad m => a -> m a
return StreamProc
-> (OutputStream Builder -> OutputStream Builder) -> StreamProc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputStream Builder -> OutputStream Builder
forall a. a -> a
id))
                         200 "OK" Bool
False


------------------------------------------------------------------------------
-- | Sets an HTTP response body to the given stream procedure.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "System.IO.Streams" as Streams
-- ghci> import qualified "Data.ByteString.Builder" as Builder
-- ghci> :{
-- ghci| let r = 'setResponseBody'
-- ghci|         (\out -> do
-- ghci|             Streams.write (Just $ Builder.'byteString' \"Hello, world!\") out
-- ghci|             return out)
-- ghci|         'emptyResponse'
-- ghci| :}
-- ghci> r
-- HTTP\/1.1 200 OK
--
-- Hello, world!
-- @
setResponseBody     :: (OutputStream Builder -> IO (OutputStream Builder))
                                   -- ^ new response body
                    -> Response    -- ^ response to modify
                    -> Response
setResponseBody :: StreamProc -> Response -> Response
setResponseBody e :: StreamProc
e r :: Response
r = Response
r { rspBody :: ResponseBody
rspBody = StreamProc -> ResponseBody
Stream StreamProc
e }
{-# INLINE setResponseBody #-}


------------------------------------------------------------------------------
-- | Sets the HTTP response status. Note: normally you would use
-- 'setResponseCode' unless you needed a custom response explanation.
--
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> setResponseStatus 500 \"Internal Server Error\" 'emptyResponse'
-- HTTP\/1.1 500 Internal Server Error
--
--
-- @
setResponseStatus   :: Int        -- ^ HTTP response integer code
                    -> ByteString -- ^ HTTP response explanation
                    -> Response   -- ^ Response to be modified
                    -> Response
setResponseStatus :: Int -> ByteString -> Response -> Response
setResponseStatus s :: Int
s reason :: ByteString
reason r :: Response
r = Response
r { rspStatus :: Int
rspStatus=Int
s, rspStatusReason :: ByteString
rspStatusReason=ByteString
reason }
{-# INLINE setResponseStatus #-}


------------------------------------------------------------------------------
-- | Sets the HTTP response code.
--
-- Example:
--
-- @
-- ghci> setResponseCode 404 'emptyResponse'
-- HTTP\/1.1 404 Not Found
--
--
-- @
setResponseCode   :: Int        -- ^ HTTP response integer code
                  -> Response   -- ^ Response to be modified
                  -> Response
setResponseCode :: Int -> Response -> Response
setResponseCode s :: Int
s r :: Response
r = Int -> ByteString -> Response -> Response
setResponseStatus Int
s ByteString
reason Response
r
  where
    reason :: ByteString
reason = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe "Unknown" (Int -> IntMap ByteString -> Maybe ByteString
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
s IntMap ByteString
statusReasonMap)
{-# INLINE setResponseCode #-}


------------------------------------------------------------------------------
-- | Modifies a response body.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import qualified "System.IO.Streams" as Streams
-- ghci> import qualified "Data.ByteString.Builder" as Builder
-- ghci> :{
-- ghci| let r = 'setResponseBody'
-- ghci|         (\out -> do
-- ghci|             Streams.write (Just $ Builder.'byteString' \"Hello, world!\") out
-- ghci|             return out)
-- ghci|         'emptyResponse'
-- ghci| :}
-- ghci> r
-- HTTP\/1.1 200 OK
--
-- Hello, world!
-- ghci> :{
-- ghci| let r' = 'modifyResponseBody'
-- ghci|          (\f out -> do
-- ghci|              out' <- f out
-- ghci|              Streams.write (Just $ Builder.'byteString' \"\\nBye, world!\") out'
-- ghci|              return out') r
-- ghci| :}
-- ghci> r'
-- HTTP\/1.1 200 OK
--
-- Hello, world!
-- Bye, world!
-- @
modifyResponseBody  :: ((OutputStream Builder -> IO (OutputStream Builder)) ->
                        (OutputStream Builder -> IO (OutputStream Builder)))
                    -> Response
                    -> Response
modifyResponseBody :: (StreamProc -> StreamProc) -> Response -> Response
modifyResponseBody f :: StreamProc -> StreamProc
f r :: Response
r = Response
r { rspBody :: ResponseBody
rspBody = (StreamProc -> StreamProc) -> ResponseBody -> ResponseBody
rspBodyMap StreamProc -> StreamProc
f (Response -> ResponseBody
rspBody Response
r) }
{-# INLINE modifyResponseBody #-}


------------------------------------------------------------------------------
-- | Sets the @Content-Type@ in the 'Response' headers.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> setContentType \"text\/html\" 'emptyResponse'
-- HTTP\/1.1 200 OK
-- content-type: text\/html
--
--
-- @
setContentType      :: ByteString -> Response -> Response
setContentType :: ByteString -> Response -> Response
setContentType = CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader "Content-Type"
{-# INLINE setContentType #-}


------------------------------------------------------------------------------
-- | Convert 'Cookie' into 'ByteString' for output.
--
-- TODO: Remove duplication. This function is copied from
-- snap-server/Snap.Internal.Http.Server.Session.
cookieToBS :: Cookie -> ByteString
cookieToBS :: Cookie -> ByteString
cookieToBS (Cookie k :: ByteString
k v :: ByteString
v mbExpTime :: Maybe UTCTime
mbExpTime mbDomain :: Maybe ByteString
mbDomain mbPath :: Maybe ByteString
mbPath isSec :: Bool
isSec isHOnly :: Bool
isHOnly) = ByteString
cookie
  where
    cookie :: ByteString
cookie = [ByteString] -> ByteString
S.concat [ByteString
k, "=", ByteString
v, ByteString
path, ByteString
exptime, ByteString
domain, ByteString
secure, ByteString
hOnly]
    path :: ByteString
path = ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (ByteString -> ByteString -> ByteString
S.append "; path=") Maybe ByteString
mbPath
    domain :: ByteString
domain = ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (ByteString -> ByteString -> ByteString
S.append "; domain=") Maybe ByteString
mbDomain
    exptime :: ByteString
exptime = ByteString
-> (UTCTime -> ByteString) -> Maybe UTCTime -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (ByteString -> ByteString -> ByteString
S.append "; expires=" (ByteString -> ByteString)
-> (UTCTime -> ByteString) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> ByteString
fmt) Maybe UTCTime
mbExpTime
    secure :: ByteString
secure = if Bool
isSec then "; Secure" else ""
    hOnly :: ByteString
hOnly = if Bool
isHOnly then "; HttpOnly" else ""

    -- TODO: 'formatHttpTime' uses "DD MMM YYYY" instead of "DD-MMM-YYYY",
    -- unlike the code in 'Snap.Internal.Http.Server.Session'. Is this form
    -- allowed?
    fmt :: UTCTime -> ByteString
fmt = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString)
-> (UTCTime -> IO ByteString) -> UTCTime -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTime -> IO ByteString
formatHttpTime (CTime -> IO ByteString)
-> (UTCTime -> CTime) -> UTCTime -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> CTime
toCTime

    toCTime :: UTCTime -> CTime
    toCTime :: UTCTime -> CTime
toCTime = Integer -> CTime
forall a. Num a => Integer -> a
fromInteger (Integer -> CTime) -> (UTCTime -> Integer) -> UTCTime -> CTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate (POSIXTime -> Integer)
-> (UTCTime -> POSIXTime) -> UTCTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds

------------------------------------------------------------------------------
-- | Render cookies from a given 'Response' to 'Headers'.
--
-- TODO: Remove duplication. This function is copied from
-- snap-server/Snap.Internal.Http.Server.Session.
renderCookies :: Response -> Headers -> Headers
renderCookies :: Response -> Headers -> Headers
renderCookies r :: Response
r hdrs :: Headers
hdrs
    | [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
cookies = Headers
hdrs
    | Bool
otherwise = (Headers -> ByteString -> Headers)
-> Headers -> [ByteString] -> Headers
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\m :: Headers
m v :: ByteString
v -> ByteString -> ByteString -> Headers -> Headers
H.unsafeInsert "set-cookie" ByteString
v Headers
m) Headers
hdrs [ByteString]
cookies

  where
    cookies :: [ByteString]
cookies = (Cookie -> ByteString) -> [Cookie] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cookie -> ByteString
cookieToBS ([Cookie] -> [ByteString])
-> (Map ByteString Cookie -> [Cookie])
-> Map ByteString Cookie
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ByteString Cookie -> [Cookie]
forall k a. Map k a -> [a]
Map.elems (Map ByteString Cookie -> [ByteString])
-> Map ByteString Cookie -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Response -> Map ByteString Cookie
rspCookies Response
r

------------------------------------------------------------------------------
-- | Adds an HTTP 'Cookie' to 'Response' headers.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False
-- ghci> 'getResponseCookie' \"name\" $ 'addResponseCookie' cookie 'emptyResponse'
-- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...})
-- @
addResponseCookie :: Cookie            -- ^ cookie value
                  -> Response          -- ^ response to modify
                  -> Response
addResponseCookie :: Cookie -> Response -> Response
addResponseCookie ck :: Cookie
ck@(Cookie k :: ByteString
k _ _ _ _ _ _) r :: Response
r = Response
r { rspCookies :: Map ByteString Cookie
rspCookies = Map ByteString Cookie
cks' }
  where
    cks' :: Map ByteString Cookie
cks'= ByteString
-> Cookie -> Map ByteString Cookie -> Map ByteString Cookie
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ByteString
k Cookie
ck (Map ByteString Cookie -> Map ByteString Cookie)
-> Map ByteString Cookie -> Map ByteString Cookie
forall a b. (a -> b) -> a -> b
$ Response -> Map ByteString Cookie
rspCookies Response
r
{-# INLINE addResponseCookie #-}


------------------------------------------------------------------------------
-- | Gets an HTTP 'Cookie' with the given name from 'Response' headers.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> 'getResponseCookie' \"cookie-name\" 'emptyResponse'
-- Nothing
-- @
getResponseCookie :: ByteString            -- ^ cookie name
                  -> Response              -- ^ response to query
                  -> Maybe Cookie
getResponseCookie :: ByteString -> Response -> Maybe Cookie
getResponseCookie cn :: ByteString
cn r :: Response
r = ByteString -> Map ByteString Cookie -> Maybe Cookie
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
cn (Map ByteString Cookie -> Maybe Cookie)
-> Map ByteString Cookie -> Maybe Cookie
forall a b. (a -> b) -> a -> b
$ Response -> Map ByteString Cookie
rspCookies Response
r
{-# INLINE getResponseCookie #-}


-- | Returns a list of 'Cookie's present in 'Response'
--
-- Example:
--
-- @
-- ghci> 'getResponseCookies' 'emptyResponse'
-- []
-- @
getResponseCookies :: Response              -- ^ response to query
                   -> [Cookie]
getResponseCookies :: Response -> [Cookie]
getResponseCookies = Map ByteString Cookie -> [Cookie]
forall k a. Map k a -> [a]
Map.elems (Map ByteString Cookie -> [Cookie])
-> (Response -> Map ByteString Cookie) -> Response -> [Cookie]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> Map ByteString Cookie
rspCookies
{-# INLINE getResponseCookies #-}


------------------------------------------------------------------------------
-- | Deletes an HTTP 'Cookie' from the 'Response' headers. Please note
-- this does not necessarily erase the cookie from the client browser.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False
-- ghci> let rsp    = 'addResponseCookie' cookie 'emptyResponse'
-- ghci> 'getResponseCookie' \"name\" rsp
-- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...})
-- ghci> 'getResponseCookie' \"name\" $ 'deleteResponseCookie' \"name\" rsp
-- Nothing
-- @
deleteResponseCookie :: ByteString        -- ^ cookie name
                     -> Response          -- ^ response to modify
                     -> Response
deleteResponseCookie :: ByteString -> Response -> Response
deleteResponseCookie cn :: ByteString
cn r :: Response
r = Response
r { rspCookies :: Map ByteString Cookie
rspCookies = Map ByteString Cookie
cks' }
  where
    cks' :: Map ByteString Cookie
cks'= ByteString -> Map ByteString Cookie -> Map ByteString Cookie
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ByteString
cn (Map ByteString Cookie -> Map ByteString Cookie)
-> Map ByteString Cookie -> Map ByteString Cookie
forall a b. (a -> b) -> a -> b
$ Response -> Map ByteString Cookie
rspCookies Response
r
{-# INLINE deleteResponseCookie #-}


------------------------------------------------------------------------------
-- | Modifies an HTTP 'Cookie' with given name in 'Response' headers.
-- Nothing will happen if a matching 'Cookie' can not be found in 'Response'.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> import "Data.Monoid"
-- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False
-- ghci> let rsp    = 'addResponseCookie' cookie 'emptyResponse'
-- ghci> 'getResponseCookie' \"name\" rsp
-- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...})
-- ghci> let f ck@('Cookie' { cookieName = name }) = ck { cookieName = name <> \"\'\"}
-- ghci> let rsp' = 'modifyResponseCookie' \"name\" f rsp
-- ghci> 'getResponseCookie' \"name\'\" rsp\'
-- Just (Cookie {cookieName = \"name\'\", ...})
-- ghci> 'getResponseCookie' \"name\" rsp\'
-- Just (Cookie {cookieName = \"name\", ...})
-- @
modifyResponseCookie :: ByteString          -- ^ cookie name
                     -> (Cookie -> Cookie)  -- ^ modifier function
                     -> Response            -- ^ response to modify
                     -> Response
modifyResponseCookie :: ByteString -> (Cookie -> Cookie) -> Response -> Response
modifyResponseCookie cn :: ByteString
cn f :: Cookie -> Cookie
f r :: Response
r = Response -> (Cookie -> Response) -> Maybe Cookie -> Response
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Response
r Cookie -> Response
modify (Maybe Cookie -> Response) -> Maybe Cookie -> Response
forall a b. (a -> b) -> a -> b
$ ByteString -> Response -> Maybe Cookie
getResponseCookie ByteString
cn Response
r
  where
    modify :: Cookie -> Response
modify ck :: Cookie
ck = Cookie -> Response -> Response
addResponseCookie (Cookie -> Cookie
f Cookie
ck) Response
r
{-# INLINE modifyResponseCookie #-}


------------------------------------------------------------------------------
-- | A note here: if you want to set the @Content-Length@ for the response,
-- Snap forces you to do it with this function rather than by setting it in
-- the headers; the @Content-Length@ in the headers will be ignored.
--
-- The reason for this is that Snap needs to look up the value of
-- @Content-Length@ for each request, and looking the string value up in the
-- headers and parsing the number out of the text will be too expensive.
--
-- If you don't set a content length in your response, HTTP keep-alive will be
-- disabled for HTTP\/1.0 clients, forcing a @Connection: close@. For
-- HTTP\/1.1 clients, Snap will switch to the chunked transfer encoding if
-- @Content-Length@ is not specified.
--
-- Example:
--
-- @
-- ghci> setContentLength 400 'emptyResponse'
-- HTTP\/1.1 200 OK
-- Content-Length: 400
--
--
-- @
setContentLength    :: Word64 -> Response -> Response
setContentLength :: Word64 -> Response -> Response
setContentLength !Word64
l r :: Response
r = Response
r { rspContentLength :: Maybe Word64
rspContentLength = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
l }
{-# INLINE setContentLength #-}


------------------------------------------------------------------------------
-- | Removes any @Content-Length@ set in the 'Response'.
--
-- Example:
--
-- @
-- ghci> clearContentLength $ 'setContentLength' 400 'emptyResponse'
-- HTTP\/1.1 200 OK
--
--
-- @
clearContentLength :: Response -> Response
clearContentLength :: Response -> Response
clearContentLength r :: Response
r = Response
r { rspContentLength :: Maybe Word64
rspContentLength = Maybe Word64
forall a. Maybe a
Nothing }
{-# INLINE clearContentLength #-}


                               ----------------
                               -- HTTP dates --
                               ----------------

------------------------------------------------------------------------------
-- | Convert a 'CTime' into an HTTP timestamp.
--
-- Example:
--
-- @
-- ghci> 'formatHttpTime' . 'fromIntegral' $ 10
-- \"Thu, 01 Jan 1970 00:00:10 GMT\"
-- @
formatHttpTime :: CTime -> IO ByteString


------------------------------------------------------------------------------
-- | Convert a 'CTime' into common log entry format.
formatLogTime :: CTime -> IO ByteString


------------------------------------------------------------------------------
-- | Converts an HTTP timestamp into a 'CTime'.
--
-- Example:
--
-- @
-- ghci> :set -XOverloadedStrings
-- ghci> 'parseHttpTime' \"Thu, 01 Jan 1970 00:00:10 GMT\"
-- 10
-- @
parseHttpTime :: ByteString -> IO CTime

#ifdef PORTABLE

------------------------------------------------------------------------------
-- local definitions
fromStr :: String -> ByteString
fromStr = S.pack                -- only because we know there's no unicode
{-# INLINE fromStr #-}


------------------------------------------------------------------------------
formatHttpTime = return . format . toUTCTime
  where
    format :: UTCTime -> ByteString
    format = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT"

    toUTCTime :: CTime -> UTCTime
    toUTCTime = posixSecondsToUTCTime . realToFrac


------------------------------------------------------------------------------
formatLogTime ctime = do
  t <- utcToLocalZonedTime $ toUTCTime ctime
  return $! format t

  where
    format :: ZonedTime -> ByteString
    format = fromStr . formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z"

    toUTCTime :: CTime -> UTCTime
    toUTCTime = posixSecondsToUTCTime . realToFrac


------------------------------------------------------------------------------
parseHttpTime = return . toCTime . prs . S.unpack
  where
    prs :: String -> Maybe UTCTime
    prs = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"

    toCTime :: Maybe UTCTime -> CTime
    toCTime (Just t) = fromInteger $ truncate $ utcTimeToPOSIXSeconds t
    toCTime Nothing  = fromInteger 0

#else

------------------------------------------------------------------------------
formatLogTime :: CTime -> IO ByteString
formatLogTime t :: CTime
t = do
    Ptr CChar
ptr <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
mallocBytes 40
    CTime -> Ptr CChar -> IO ()
c_format_log_time CTime
t Ptr CChar
ptr
    Ptr CChar -> IO ByteString
S.unsafePackMallocCString Ptr CChar
ptr


------------------------------------------------------------------------------
formatHttpTime :: CTime -> IO ByteString
formatHttpTime t :: CTime
t = do
    Ptr CChar
ptr <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
mallocBytes 40
    CTime -> Ptr CChar -> IO ()
c_format_http_time CTime
t Ptr CChar
ptr
    Ptr CChar -> IO ByteString
S.unsafePackMallocCString Ptr CChar
ptr


------------------------------------------------------------------------------
parseHttpTime :: ByteString -> IO CTime
parseHttpTime s :: ByteString
s = ByteString -> (Ptr CChar -> IO CTime) -> IO CTime
forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
S.unsafeUseAsCString ByteString
s ((Ptr CChar -> IO CTime) -> IO CTime)
-> (Ptr CChar -> IO CTime) -> IO CTime
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr CChar
ptr ->
    Ptr CChar -> IO CTime
c_parse_http_time Ptr CChar
ptr

#endif


------------------------------------------------------------------------------
-- | Adapted from:
--
-- <https://www.iana.org/assignments/http-status-codes/http-status-codes.txt>
statusReasonMap :: IM.IntMap ByteString
statusReasonMap :: IntMap ByteString
statusReasonMap = [(Int, ByteString)] -> IntMap ByteString
forall a. [(Int, a)] -> IntMap a
IM.fromList [
        (100, "Continue"),
        (101, "Switching Protocols"),
        (102, "Processing"),
        (103, "Early Hints"),
        -- 104-199 Unassigned
        (200, "OK"),
        (201, "Created"),
        (202, "Accepted"),
        (203, "Non-Authoritative Information"),
        (204, "No Content"),
        (205, "Reset Content"),
        (206, "Partial Content"),
        (207, "Multi-Status"),
        (208, "Already Reported"),
        -- 209-225 Unassigned
        (226, "IM Used"),
        -- 227-299 Unassigned,
        (300, "Multiple Choices"),
        (301, "Moved Permanently"),
        (302, "Found"),
        (303, "See Other"),
        (304, "Not Modified"),
        (305, "Use Proxy"),
        (306, "(Unused)"),
        (307, "Temporary Redirect"),
        (308, "Permanent Redirect"),
        -- 309-399 Unassigned
        (400, "Bad Request"),
        (401, "Unauthorized"),
        (402, "Payment Required"),
        (403, "Forbidden"),
        (404, "Not Found"),
        (405, "Method Not Allowed"),
        (406, "Not Acceptable"),
        (407, "Proxy Authentication Required"),
        (408, "Request Timeout"),
        (409, "Conflict"),
        (410, "Gone"),
        (411, "Length Required"),
        (412, "Precondition Failed"),
        (413, "Payload Too Large"),
        (414, "URI Too Long"),
        (415, "Unsupported Media Type"),
        (416, "Range Not Satisfiable"),
        (417, "Expectation Failed"),
        -- 418-420 Unassigned
        (421, "Misdirected Request"),
        (422, "Unprocessable Entity"),
        (423, "Locked"),
        (424, "Failed Dependency"),
        (425, "Too Early"),
        (426, "Upgrade Required"),
        -- 427 Unassigned
        (428, "Precondition Required"),
        (429, "Too Many Requests"),
        -- 430 Unassigned
        (431, "Request Header Fields Too Large"),
        -- 432-450 Unassigned
        (451, "Unavailable For Legal Reasons"),
        -- 452-499 Unassigned
        (500, "Internal Server Error"),
        (501, "Not Implemented"),
        (502, "Bad Gateway"),
        (503, "Service Unavailable"),
        (504, "Gateway Timeout"),
        (505, "HTTP Version Not Supported"),
        (506, "Variant Also Negotiates"),
        (507, "Insufficient Storage"),
        (508, "Loop Detected"),
        -- 509 Unassigned
        (510, "Not Extended"),
        (511, "Network Authentication Required")
        -- 512-599 Unassigned
    ]

------------------------------------------------------------------------------
-- Deprecated functions

-- | See 'rqClientAddr'.
rqRemoteAddr :: Request -> ByteString
rqRemoteAddr :: Request -> ByteString
rqRemoteAddr = Request -> ByteString
rqClientAddr
{-# DEPRECATED rqRemoteAddr "(snap-core >= 1.0.0.0) please use 'rqClientAddr', this will be removed in 1.1.*" #-}

-- | See 'rqClientPort'.
rqRemotePort :: Request -> Int
rqRemotePort :: Request -> Int
rqRemotePort = Request -> Int
rqClientPort
{-# DEPRECATED rqRemotePort "(snap-core >= 1.0.0.0) please use 'rqClientPort', this will be removed in 1.1.*" #-}