{-# 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 CI ByteString
k 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 CI ByteString
k 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 CI ByteString
k 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 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
    Method
a == :: Method -> Method -> Bool
== Method
b =
        Method -> Method
normalizeMethod Method
a Method -> Method -> Bool
`eq` Method -> Method
normalizeMethod Method
b
      where
        Method
GET       eq :: Method -> Method -> Bool
`eq` Method
GET       = Bool
True
        Method
HEAD      `eq` Method
HEAD      = Bool
True
        Method
POST      `eq` Method
POST      = Bool
True
        Method
PUT       `eq` Method
PUT       = Bool
True
        Method
DELETE    `eq` Method
DELETE    = Bool
True
        Method
TRACE     `eq` Method
TRACE     = Bool
True
        Method
OPTIONS   `eq` Method
OPTIONS   = Bool
True
        Method
CONNECT   `eq` Method
CONNECT   = Bool
True
        Method
PATCH     `eq` Method
PATCH     = Bool
True
        Method ByteString
x1 `eq` Method ByteString
y1 = ByteString
x1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
y1
        Method
_         `eq` Method
_         = Bool
False

instance Ord Method where
        compare :: Method -> Method -> Ordering
compare Method
a Method
b =
            Method -> Method -> Ordering
check (Method -> Method
normalizeMethod Method
a) (Method -> Method
normalizeMethod Method
b)
          where
            check :: Method -> Method -> Ordering
check   Method
GET          Method
GET           = Ordering
EQ
            check   Method
HEAD         Method
HEAD          = Ordering
EQ
            check   Method
POST         Method
POST          = Ordering
EQ
            check   Method
PUT          Method
PUT           = Ordering
EQ
            check   Method
DELETE       Method
DELETE        = Ordering
EQ
            check   Method
TRACE        Method
TRACE         = Ordering
EQ
            check   Method
OPTIONS      Method
OPTIONS       = Ordering
EQ
            check   Method
CONNECT      Method
CONNECT       = Ordering
EQ
            check   Method
PATCH        Method
PATCH         = Ordering
EQ
            check   (Method  ByteString
x1) (Method   ByteString
y1) = ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ByteString
x1 ByteString
y1
            check   Method
x            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{})     = Int
0
            tag (HEAD{})    = Int
1
            tag (POST{})    = Int
2
            tag (PUT{})     = Int
3
            tag (DELETE{})  = Int
4
            tag (TRACE{})   = Int
5
            tag (OPTIONS{}) = Int
6
            tag (CONNECT{}) = Int
7
            tag (PATCH{})   = Int
8
            tag (Method{})  = Int
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 ByteString
name) = case ByteString
name of
                                    ByteString
"GET"     -> Method
GET
                                    ByteString
"HEAD"    -> Method
HEAD
                                    ByteString
"POST"    -> Method
POST
                                    ByteString
"PUT"     -> Method
PUT
                                    ByteString
"DELETE"  -> Method
DELETE
                                    ByteString
"TRACE"   -> Method
TRACE
                                    ByteString
"OPTIONS" -> Method
OPTIONS
                                    ByteString
"CONNECT" -> Method
CONNECT
                                    ByteString
"PATCH"   -> Method
PATCH
                                    ByteString
_         -> Method
m
normalizeMethod 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 Request
r = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
method, String
" ", String
uri, String
" HTTP/", String
version, String
"\n"
                  , String
hdrs, String
"\n\n"
                  , String
"sn=\"", String
sname, String
"\" c=", String
clntAddr, String
" s=", String
srvAddr
                  , String
" ctx=", String
contextpath, String
" 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 (Int
mj, 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
"." 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 String
"\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 (CI ByteString
a,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
": " 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, String
":", 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, String
":", 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 String
"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 String
" secure" else String
""

      params :: String
params        = String -> String -> [String] -> String
showFlds String
"\nparams: " String
", " ([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 (\ (ByteString
a,[ByteString]
b) -> ByteString -> String
S.unpack ByteString
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " 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 String
"\ncookies: " String
"\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 String
header String
delim [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
"" :: String

------------------------------------------------------------------------------
instance HasHeaders Request where
    headers :: Request -> Headers
headers           = Request -> Headers
rqHeaders
    updateHeaders :: (Headers -> Headers) -> Request -> Request
updateHeaders Headers -> Headers
f 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 StreamProc -> StreamProc
f 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 StreamProc
e) = StreamProc
e

rspBodyToEnum (SendFile String
fp Maybe (Word64, Word64)
Nothing) = \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
$ \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 String
fp (Just (Word64
start, Word64
end))) = \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 -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word64
start Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
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 Response
r = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
statusline
                  , String
hdrs
                  , String
contentLength
                  , String
"\r\n"
                  , String
body
                  ]
    where
      statusline :: String
statusline = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"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
                          , String
" "
                          , ByteString -> String
S.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Response -> ByteString
rspStatusReason Response
r
                          , String
"\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 String
"" (\Word64
l -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"Content-Length: ", Word64 -> String
forall a. Show a => a -> String
show Word64
l, String
"\r\n"] ) (Response -> Maybe Word64
rspContentLength Response
r)

      showHdr :: (CI ByteString, ByteString) -> String
showHdr (CI ByteString
k,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), String
": ", ByteString -> String
S.unpack ByteString
v, String
"\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
        (OutputStream Builder
os, 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 Headers -> Headers
f 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 ByteString
k 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 ByteString
k 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 ByteString
k 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 Params -> Params
f 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 ByteString
k [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))
                         Int
200 ByteString
"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 StreamProc
e 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 Int
s ByteString
reason 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 Int
s 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 ByteString
"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 StreamProc -> StreamProc
f 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 CI ByteString
"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 ByteString
k ByteString
v Maybe UTCTime
mbExpTime Maybe ByteString
mbDomain Maybe ByteString
mbPath Bool
isSec Bool
isHOnly) = ByteString
cookie
  where
    cookie :: ByteString
cookie = [ByteString] -> ByteString
S.concat [ByteString
k, ByteString
"=", 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 -> ByteString
S.append ByteString
"; 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 -> ByteString
S.append ByteString
"; 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 -> ByteString
S.append ByteString
"; 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 ByteString
"; Secure" else ByteString
""
    hOnly :: ByteString
hOnly = if Bool
isHOnly then ByteString
"; HttpOnly" else ByteString
""

    -- 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 Response
r 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' (\Headers
m ByteString
v -> ByteString -> ByteString -> Headers -> Headers
H.unsafeInsert ByteString
"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 ByteString
k ByteString
_ Maybe UTCTime
_ Maybe ByteString
_ Maybe ByteString
_ Bool
_ Bool
_) 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 ByteString
cn 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 ByteString
cn 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 ByteString
cn Cookie -> Cookie
f 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 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 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 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'.
--
-- If the given time string is unparseable, this function will return 0.
--
-- 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 CTime
t = do
    Ptr CChar
ptr <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
mallocBytes Int
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 CTime
t = do
    Ptr CChar
ptr <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
mallocBytes Int
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 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 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 [
        (Int
100, ByteString
"Continue"),
        (Int
101, ByteString
"Switching Protocols"),
        (Int
102, ByteString
"Processing"),
        (Int
103, ByteString
"Early Hints"),
        -- 104-199 Unassigned
        (Int
200, ByteString
"OK"),
        (Int
201, ByteString
"Created"),
        (Int
202, ByteString
"Accepted"),
        (Int
203, ByteString
"Non-Authoritative Information"),
        (Int
204, ByteString
"No Content"),
        (Int
205, ByteString
"Reset Content"),
        (Int
206, ByteString
"Partial Content"),
        (Int
207, ByteString
"Multi-Status"),
        (Int
208, ByteString
"Already Reported"),
        -- 209-225 Unassigned
        (Int
226, ByteString
"IM Used"),
        -- 227-299 Unassigned,
        (Int
300, ByteString
"Multiple Choices"),
        (Int
301, ByteString
"Moved Permanently"),
        (Int
302, ByteString
"Found"),
        (Int
303, ByteString
"See Other"),
        (Int
304, ByteString
"Not Modified"),
        (Int
305, ByteString
"Use Proxy"),
        (Int
306, ByteString
"(Unused)"),
        (Int
307, ByteString
"Temporary Redirect"),
        (Int
308, ByteString
"Permanent Redirect"),
        -- 309-399 Unassigned
        (Int
400, ByteString
"Bad Request"),
        (Int
401, ByteString
"Unauthorized"),
        (Int
402, ByteString
"Payment Required"),
        (Int
403, ByteString
"Forbidden"),
        (Int
404, ByteString
"Not Found"),
        (Int
405, ByteString
"Method Not Allowed"),
        (Int
406, ByteString
"Not Acceptable"),
        (Int
407, ByteString
"Proxy Authentication Required"),
        (Int
408, ByteString
"Request Timeout"),
        (Int
409, ByteString
"Conflict"),
        (Int
410, ByteString
"Gone"),
        (Int
411, ByteString
"Length Required"),
        (Int
412, ByteString
"Precondition Failed"),
        (Int
413, ByteString
"Payload Too Large"),
        (Int
414, ByteString
"URI Too Long"),
        (Int
415, ByteString
"Unsupported Media Type"),
        (Int
416, ByteString
"Range Not Satisfiable"),
        (Int
417, ByteString
"Expectation Failed"),
        -- 418-420 Unassigned
        (Int
421, ByteString
"Misdirected Request"),
        (Int
422, ByteString
"Unprocessable Entity"),
        (Int
423, ByteString
"Locked"),
        (Int
424, ByteString
"Failed Dependency"),
        (Int
425, ByteString
"Too Early"),
        (Int
426, ByteString
"Upgrade Required"),
        -- 427 Unassigned
        (Int
428, ByteString
"Precondition Required"),
        (Int
429, ByteString
"Too Many Requests"),
        -- 430 Unassigned
        (Int
431, ByteString
"Request Header Fields Too Large"),
        -- 432-450 Unassigned
        (Int
451, ByteString
"Unavailable For Legal Reasons"),
        -- 452-499 Unassigned
        (Int
500, ByteString
"Internal Server Error"),
        (Int
501, ByteString
"Not Implemented"),
        (Int
502, ByteString
"Bad Gateway"),
        (Int
503, ByteString
"Service Unavailable"),
        (Int
504, ByteString
"Gateway Timeout"),
        (Int
505, ByteString
"HTTP Version Not Supported"),
        (Int
506, ByteString
"Variant Also Negotiates"),
        (Int
507, ByteString
"Insufficient Storage"),
        (Int
508, ByteString
"Loop Detected"),
        -- 509 Unassigned
        (Int
510, ByteString
"Not Extended"),
        (Int
511, ByteString
"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.*" #-}