1 -- | An internal Snap module containing HTTP types.
    2 --
    3 -- /N.B./ this is an internal interface, please don't write user code that
    4 -- depends on it. Most of these declarations (except for the
    5 -- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Types".
    6 
    7 {-# LANGUAGE BangPatterns #-}
    8 {-# LANGUAGE CPP #-}
    9 {-# LANGUAGE EmptyDataDecls #-}
   10 {-# LANGUAGE ForeignFunctionInterface #-}
   11 {-# LANGUAGE OverloadedStrings #-}
   12 {-# LANGUAGE RankNTypes #-}
   13 {-# LANGUAGE TypeSynonymInstances #-}
   14 
   15 module Snap.Internal.Http.Types where
   16 
   17 
   18 ------------------------------------------------------------------------------
   19 import           Blaze.ByteString.Builder
   20 import           Control.Applicative hiding (empty)
   21 import           Control.Monad (liftM, when)
   22 import qualified Data.Attoparsec as Atto
   23 import           Data.Attoparsec hiding (many, Result(..))
   24 import           Data.Bits
   25 import           Data.ByteString (ByteString)
   26 import qualified Data.ByteString.Char8 as B
   27 import           Data.ByteString.Internal (c2w,w2c)
   28 import qualified Data.ByteString.Nums.Careless.Hex as Cvt
   29 import qualified Data.ByteString as S
   30 import qualified Data.ByteString.Unsafe as S
   31 import           Data.Char
   32 import           Data.DList (DList)
   33 import qualified Data.DList as DL
   34 import           Data.Int
   35 import qualified Data.IntMap as IM
   36 import           Data.IORef
   37 import           Data.List hiding (take)
   38 import           Data.Map (Map)
   39 import qualified Data.Map as Map
   40 import           Data.Maybe
   41 import           Data.Monoid
   42 import           Data.Time.Clock
   43 import           Data.Word
   44 import           Foreign hiding (new)
   45 import           Foreign.C.Types
   46 import           Prelude hiding (take)
   47 
   48 
   49 #ifdef PORTABLE
   50 import           Data.Time.Format
   51 import           Data.Time.LocalTime
   52 import           Data.Time.Clock.POSIX
   53 import           System.Locale (defaultTimeLocale)
   54 #else
   55 import           Data.Time.Format ()
   56 import           Foreign.C.String
   57 #endif
   58 
   59 ------------------------------------------------------------------------------
   60 import           Data.CaseInsensitive   (CI)
   61 import qualified Data.CaseInsensitive as CI
   62 import           Snap.Iteratee (Enumerator)
   63 import qualified Snap.Iteratee as I
   64 
   65 
   66 #ifndef PORTABLE
   67 
   68 ------------------------------------------------------------------------------
   69 -- foreign imports from cbits
   70 
   71 foreign import ccall unsafe "set_c_locale"
   72         set_c_locale :: IO ()
   73 
   74 foreign import ccall unsafe "c_parse_http_time"
   75         c_parse_http_time :: CString -> IO CTime
   76 
   77 foreign import ccall unsafe "c_format_http_time"
   78         c_format_http_time :: CTime -> CString -> IO ()
   79 
   80 foreign import ccall unsafe "c_format_log_time"
   81         c_format_log_time :: CTime -> CString -> IO ()
   82 
   83 #endif
   84 
   85 
   86 ------------------------------------------------------------------------------
   87 -- | A type alias for a case-insensitive key-value mapping.
   88 type Headers = Map (CI ByteString) [ByteString]
   89 
   90 
   91 ------------------------------------------------------------------------------
   92 -- | A typeclass for datatypes which contain HTTP headers.
   93 class HasHeaders a where
   94 
   95     -- | Modify the datatype's headers.
   96     updateHeaders :: (Headers -> Headers) -> a -> a
   97 
   98     -- | Retrieve the headers from a datatype that has headers.
   99     headers       :: a -> Headers
  100 
  101 
  102 ------------------------------------------------------------------------------
  103 -- | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header
  104 -- with the same name already exists, the new value is appended to the headers
  105 -- list.
  106 addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
  107 addHeader k v = updateHeaders $ Map.insertWith' (++) k [v]
  108 
  109 
  110 ------------------------------------------------------------------------------
  111 -- | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with
  112 -- the same name already exists, it is overwritten with the new value.
  113 setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a
  114 setHeader k v = updateHeaders $ Map.insert k [v]
  115 
  116 
  117 ------------------------------------------------------------------------------
  118 -- | Gets all of the values for a given header.
  119 getHeaders :: (HasHeaders a) => CI ByteString -> a -> Maybe [ByteString]
  120 getHeaders k a = Map.lookup k $ headers a
  121 
  122 
  123 ------------------------------------------------------------------------------
  124 -- | Gets a header value out of a 'HasHeaders' datatype. If many headers came
  125 -- in with the same name, they will be catenated together.
  126 getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString
  127 getHeader k a = liftM (S.intercalate " ") (Map.lookup k $ headers a)
  128 
  129 
  130 ------------------------------------------------------------------------------
  131 -- | Clears a header value from a 'HasHeaders' datatype.
  132 deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a
  133 deleteHeader k = updateHeaders $ Map.delete k
  134 
  135 
  136 ------------------------------------------------------------------------------
  137 -- | Enumerates the HTTP method values (see
  138 -- <http://tools.ietf.org/html/rfc2068.html#section-5.1.1>).
  139 data Method  = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT
  140                deriving(Show,Read,Ord,Eq)
  141 
  142 
  143 ------------------------------------------------------------------------------
  144 type HttpVersion = (Int,Int)
  145 
  146 
  147 ------------------------------------------------------------------------------
  148 -- | A datatype representing an HTTP cookie.
  149 data Cookie = Cookie {
  150       -- | The name of the cookie.
  151       cookieName    :: !ByteString
  152 
  153       -- | The cookie's string value.
  154     , cookieValue   :: !ByteString
  155 
  156       -- | The cookie's expiration value, if it has one.
  157     , cookieExpires :: !(Maybe UTCTime)
  158 
  159       -- | The cookie's \"domain\" value, if it has one.
  160     , cookieDomain  :: !(Maybe ByteString)
  161 
  162       -- | The cookie path.
  163     , cookiePath    :: !(Maybe ByteString)
  164 } deriving (Eq, Show)
  165 
  166 
  167 ------------------------------------------------------------------------------
  168 -- | A type alias for the HTTP parameters mapping. Each parameter
  169 -- key maps to a list of ByteString values; if a parameter is specified
  170 -- multiple times (e.g.: \"@GET /foo?param=bar1&param=bar2@\"), looking up
  171 -- \"@param@\" in the mapping will give you @[\"bar1\", \"bar2\"]@.
  172 type Params = Map ByteString [ByteString]
  173 
  174 
  175 ------------------------------------------------------------------------------
  176 -- request type
  177 ------------------------------------------------------------------------------
  178 
  179 -- | An existential wrapper for the 'Enumerator ByteString IO a' type
  180 data SomeEnumerator = SomeEnumerator (forall a . Enumerator ByteString IO a)
  181 
  182 
  183 ------------------------------------------------------------------------------
  184 -- | Contains all of the information about an incoming HTTP request.
  185 data Request = Request
  186     { -- | The server name of the request, as it came in from the request's
  187       -- @Host:@ header.
  188       rqServerName     :: !ByteString
  189 
  190       -- | Returns the port number the HTTP server is listening on.
  191     , rqServerPort     :: !Int
  192 
  193       -- | The remote IP address.
  194     , rqRemoteAddr     :: !ByteString
  195 
  196       -- | The remote TCP port number.
  197     , rqRemotePort     :: !Int
  198 
  199       -- | The local IP address for this request.
  200     , rqLocalAddr      :: !ByteString
  201 
  202       -- | Returns the port number the HTTP server is listening on.
  203     , rqLocalPort      :: !Int
  204 
  205       -- | Returns the HTTP server's idea of its local hostname.
  206     , rqLocalHostname  :: !ByteString
  207 
  208       -- | Returns @True@ if this is an @HTTPS@ session.
  209     , rqIsSecure       :: !Bool
  210     , rqHeaders        :: Headers
  211     , rqBody           :: IORef SomeEnumerator
  212 
  213       -- | Returns the @Content-Length@ of the HTTP request body.
  214     , rqContentLength  :: !(Maybe Int)
  215 
  216       -- | Returns the HTTP request method.
  217     , rqMethod         :: !Method
  218 
  219       -- | Returns the HTTP version used by the client.
  220     , rqVersion        :: !HttpVersion
  221 
  222       -- | Returns a list of the cookies that came in from the HTTP request
  223       -- headers.
  224     , rqCookies        :: [Cookie]
  225 
  226 
  227       -- | We'll be doing web components (or \"snaplets\") for version 0.2.
  228       -- The \"snaplet path\" refers to the place on the URL where your
  229       -- containing snaplet is hung. The value of 'rqSnapletPath' is either
  230       -- @\"\"@ (at the top-level context) or is a path beginning with a
  231       -- slash, but not ending with one.
  232       --
  233       -- An identity is that:
  234       --
  235       -- > rqURI r == S.concat [ rqSnapletPath r
  236       -- >                     , rqContextPath r
  237       -- >                     , rqPathInfo r
  238       -- >                     , let q = rqQueryString r
  239       -- >                     , in if S.null q
  240       -- >                            then ""
  241       -- >                            else S.append "?" q
  242       -- >                     ]
  243       --
  244       -- note that until we introduce snaplets in v0.2, 'rqSnapletPath' will
  245       -- be \"\"
  246     , rqSnapletPath    :: !ByteString
  247 
  248       -- | Handlers can (/will be; --ed/) be hung on a @URI@ \"entry point\";
  249       -- this is called the \"context path\". If a handler is hung on the
  250       -- context path @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the
  251       -- value of 'rqPathInfo' will be @\"bar\"@.
  252     , rqPathInfo       :: !ByteString
  253 
  254       -- | The \"context path\" of the request; catenating 'rqContextPath', and
  255       -- 'rqPathInfo' should get you back to the original 'rqURI' (ignoring
  256       -- query strings). The 'rqContextPath' always begins and ends with a
  257       -- slash (@\"\/\"@) character, and represents the path (relative to your
  258       -- component\/snaplet) you took to get to your handler.
  259     , rqContextPath    :: !ByteString
  260 
  261       -- | Returns the @URI@ requested by the client.
  262     , rqURI            :: !ByteString
  263 
  264       -- | Returns the HTTP query string for this 'Request'.
  265     , rqQueryString    :: !ByteString
  266 
  267       -- | Returns the 'Params' mapping for this 'Request'. \"Parameters\" are
  268       -- automatically decoded from the query string and @POST@ body and
  269       -- entered into this mapping.
  270     , rqParams         :: Params
  271     }
  272 
  273 
  274 ------------------------------------------------------------------------------
  275 instance Show Request where
  276   show r = concat [ "Request <\n"
  277                   , body
  278                   , ">" ]
  279     where
  280       body = concat $ map (("    "++) . (++ "\n")) [
  281                       sname
  282                     , remote
  283                     , local
  284                     , beginheaders
  285                     , hdrs
  286                     , endheaders
  287                     , contentlength
  288                     , method
  289                     , version
  290                     , cookies
  291                     , pathinfo
  292                     , contextpath
  293                     , snapletpath
  294                     , uri
  295                     , params
  296                     ]
  297 
  298       sname         = concat [ "server-name: ", toStr $ rqServerName r ]
  299       remote        = concat [ "remote: "
  300                              , toStr $ rqRemoteAddr r
  301                              , ":"
  302                              , show (rqRemotePort r)
  303                              ]
  304       local         = concat [ "local: "
  305                              , toStr $ rqLocalAddr r
  306                              , ":"
  307                              , show $ rqServerPort r
  308                              ]
  309       beginheaders  =
  310           "Headers:\n      ========================================"
  311       endheaders    = "  ========================================"
  312       hdrs' (a,b)   = (B.unpack $ CI.original a) ++ ": " ++ (show (map B.unpack b))
  313       hdrs          = "      " ++ (concat $ intersperse "\n " $
  314                                    map hdrs' (Map.toAscList $ rqHeaders r))
  315       contentlength = concat [ "content-length: "
  316                              , show $ rqContentLength r
  317                              ]
  318       method        = concat [ "method: "
  319                              , show $ rqMethod r
  320                              ]
  321       version       = concat [ "version: "
  322                              , show $ rqVersion r
  323                              ]
  324       cookies'      = "      " ++ (concat $ intersperse "\n " $
  325                                    map show $ rqCookies r)
  326       cookies       = concat
  327           [ "cookies:\n"
  328           , "      ========================================\n"
  329           , cookies'
  330           , "\n      ========================================"
  331           ]
  332       pathinfo      = concat [ "pathinfo: ", toStr $ rqPathInfo r ]
  333       contextpath   = concat [ "contextpath: ", toStr $ rqContextPath r ]
  334       snapletpath   = concat [ "snapletpath: ", toStr $ rqSnapletPath r ]
  335       uri           = concat [ "URI: ", toStr $ rqURI r ]
  336       params'       = "      " ++
  337                       (concat $ intersperse "\n " $
  338                        map (\ (a,b) -> B.unpack a ++ ": " ++ show b) $
  339                        Map.toAscList $ rqParams r)
  340       params        = concat
  341           [ "params:\n"
  342           , "      ========================================\n"
  343           , params'
  344           , "\n      ========================================"
  345           ]
  346 
  347 
  348 ------------------------------------------------------------------------------
  349 instance HasHeaders Request where
  350     headers           = rqHeaders
  351     updateHeaders f r = r { rqHeaders = f (rqHeaders r) }
  352 
  353 
  354 ------------------------------------------------------------------------------
  355 instance HasHeaders Headers where
  356     headers       = id
  357     updateHeaders = id
  358 
  359 ------------------------------------------------------------------------------
  360 -- response type
  361 ------------------------------------------------------------------------------
  362 
  363 data ResponseBody = Enum (forall a . Enumerator Builder IO a)
  364                       -- ^ output body is a 'Builder' enumerator
  365 
  366                   | SendFile FilePath (Maybe (Int64,Int64))
  367                       -- ^ output body is sendfile(), optional second argument
  368                       --   is a byte range to send
  369 
  370 
  371 ------------------------------------------------------------------------------
  372 rspBodyMap :: (forall a .
  373                Enumerator Builder IO a -> Enumerator Builder IO a)
  374            -> ResponseBody
  375            -> ResponseBody
  376 rspBodyMap f b      = Enum $ f $ rspBodyToEnum b
  377 
  378 
  379 
  380 ------------------------------------------------------------------------------
  381 rspBodyToEnum :: ResponseBody -> Enumerator Builder IO a
  382 rspBodyToEnum (Enum e) = e
  383 rspBodyToEnum (SendFile fp Nothing) =
  384     I.mapEnum toByteString fromByteString $ I.enumFile fp
  385 rspBodyToEnum (SendFile fp (Just s)) =
  386     I.mapEnum toByteString fromByteString $ I.enumFilePartial fp s
  387 
  388 
  389 ------------------------------------------------------------------------------
  390 -- | Represents an HTTP response.
  391 data Response = Response
  392     { rspHeaders            :: Headers
  393     , rspCookies            :: Map ByteString Cookie
  394     , rspHttpVersion        :: !HttpVersion
  395 
  396       -- | We will need to inspect the content length no matter what, and
  397       --   looking up \"content-length\" in the headers and parsing the number
  398       --   out of the text will be too expensive.
  399     , rspContentLength      :: !(Maybe Int64)
  400     , rspBody               :: ResponseBody
  401 
  402       -- | Returns the HTTP status code.
  403     , rspStatus             :: !Int
  404 
  405       -- | Returns the HTTP status explanation string.
  406     , rspStatusReason       :: !ByteString
  407 
  408       -- | If true, we are transforming the request body with
  409       -- 'transformRequestBody'
  410     , rspTransformingRqBody :: !Bool
  411     }
  412 
  413 
  414 ------------------------------------------------------------------------------
  415 instance Show Response where
  416   show r = concat [ "Response <\n"
  417                   , body
  418                   , ">" ]
  419     where
  420       body = concat $ map (("    "++) . (++ "\n")) [
  421                          hdrs
  422                        , version
  423                        , status
  424                        , reason
  425                        ]
  426 
  427       hdrs    = concat [ "headers:\n"
  428                        , "      ==============================\n      "
  429                        , show $ rspHeaders r
  430                        , "\n      ==============================" ]
  431 
  432       version = concat [ "version: ", show $ rspHttpVersion r ]
  433       status  = concat [ "status: ", show $ rspStatus r ]
  434       reason  = concat [ "reason: ", toStr $ rspStatusReason r ]
  435 
  436 
  437 ------------------------------------------------------------------------------
  438 instance HasHeaders Response where
  439     headers = rspHeaders
  440     updateHeaders f r = r { rspHeaders = f (rspHeaders r) }
  441 
  442 
  443 ------------------------------------------------------------------------------
  444 -- | Looks up the value(s) for the given named parameter. Parameters initially
  445 -- come from the request's query string and any decoded POST body (if the
  446 -- request's @Content-Type@ is @application\/x-www-form-urlencoded@).
  447 -- Parameter values can be modified within handlers using "rqModifyParams".
  448 rqParam :: ByteString           -- ^ parameter name to look up
  449         -> Request              -- ^ HTTP request
  450         -> Maybe [ByteString]
  451 rqParam k rq = Map.lookup k $ rqParams rq
  452 {-# INLINE rqParam #-}
  453 
  454 
  455 ------------------------------------------------------------------------------
  456 -- | Modifies the parameters mapping (which is a @Map ByteString ByteString@)
  457 -- in a 'Request' using the given function.
  458 rqModifyParams :: (Params -> Params) -> Request -> Request
  459 rqModifyParams f r = r { rqParams = p }
  460   where
  461     p = f $ rqParams r
  462 {-# INLINE rqModifyParams #-}
  463 
  464 
  465 ------------------------------------------------------------------------------
  466 -- | Writes a key-value pair to the parameters mapping within the given
  467 -- request.
  468 rqSetParam :: ByteString        -- ^ parameter name
  469            -> [ByteString]      -- ^ parameter values
  470            -> Request           -- ^ request
  471            -> Request
  472 rqSetParam k v = rqModifyParams $ Map.insert k v
  473 {-# INLINE rqSetParam #-}
  474 
  475 ------------------------------------------------------------------------------
  476 -- responses
  477 ------------------------------------------------------------------------------
  478 
  479 -- | An empty 'Response'.
  480 emptyResponse :: Response
  481 emptyResponse = Response Map.empty Map.empty (1,1) Nothing
  482                          (Enum (I.enumBuilder mempty))
  483                          200 "OK" False
  484 
  485 
  486 ------------------------------------------------------------------------------
  487 -- | Sets an HTTP response body to the given 'Enumerator' value.
  488 setResponseBody     :: (forall a . Enumerator Builder IO a)
  489                                    -- ^ new response body enumerator
  490                     -> Response    -- ^ response to modify
  491                     -> Response
  492 setResponseBody e r = r { rspBody = Enum e }
  493 {-# INLINE setResponseBody #-}
  494 
  495 
  496 ------------------------------------------------------------------------------
  497 -- | Sets the HTTP response status. Note: normally you would use
  498 -- 'setResponseCode' unless you needed a custom response explanation.
  499 --
  500 setResponseStatus   :: Int        -- ^ HTTP response integer code
  501                     -> ByteString -- ^ HTTP response explanation
  502                     -> Response   -- ^ Response to be modified
  503                     -> Response
  504 setResponseStatus s reason r = r { rspStatus=s, rspStatusReason=reason }
  505 {-# INLINE setResponseStatus #-}
  506 
  507 
  508 ------------------------------------------------------------------------------
  509 -- | Sets the HTTP response code.
  510 setResponseCode   :: Int        -- ^ HTTP response integer code
  511                   -> Response   -- ^ Response to be modified
  512                   -> Response
  513 setResponseCode s r = setResponseStatus s reason r
  514   where
  515     reason = fromMaybe "Unknown" (IM.lookup s statusReasonMap)
  516 {-# INLINE setResponseCode #-}
  517 
  518 
  519 ------------------------------------------------------------------------------
  520 -- | Modifies a response body.
  521 modifyResponseBody  :: (forall a . Enumerator Builder IO a
  522                                 -> Enumerator Builder IO a)
  523                     -> Response
  524                     -> Response
  525 modifyResponseBody f r = r { rspBody = rspBodyMap f (rspBody r) }
  526 {-# INLINE modifyResponseBody #-}
  527 
  528 
  529 ------------------------------------------------------------------------------
  530 -- | Sets the @Content-Type@ in the 'Response' headers.
  531 setContentType      :: ByteString -> Response -> Response
  532 setContentType = setHeader "Content-Type"
  533 {-# INLINE setContentType #-}
  534 
  535 
  536 ------------------------------------------------------------------------------
  537 -- | addCookie has been deprecated and will be removed in 0.5. Please use
  538 -- 'addResponseCookie' instead.
  539 addCookie :: Cookie                   -- ^ cookie value
  540           -> Response                 -- ^ response to modify
  541           -> Response
  542 addCookie = addResponseCookie
  543 
  544 
  545 ------------------------------------------------------------------------------
  546 -- | Adds an HTTP 'Cookie' to 'Response' headers.
  547 addResponseCookie :: Cookie            -- ^ cookie value
  548                   -> Response          -- ^ response to modify
  549                   -> Response
  550 addResponseCookie ck@(Cookie k _ _ _ _) r = r { rspCookies = cks' }
  551   where
  552     cks'= Map.insert k ck $ rspCookies r
  553 {-# INLINE addResponseCookie #-}
  554 
  555 
  556 ------------------------------------------------------------------------------
  557 -- | Gets an HTTP 'Cookie' with the given name from 'Response' headers.
  558 getResponseCookie :: ByteString            -- ^ cookie name
  559                   -> Response              -- ^ response to query
  560                   -> Maybe Cookie
  561 getResponseCookie cn r = Map.lookup cn $ rspCookies r
  562 {-# INLINE getResponseCookie #-}
  563 
  564 
  565 -- | Returns a list of 'Cookie's present in 'Response'
  566 getResponseCookies :: Response              -- ^ response to query
  567                    -> [Cookie]
  568 getResponseCookies = Map.elems . rspCookies
  569 {-# INLINE getResponseCookies #-}
  570 
  571 
  572 ------------------------------------------------------------------------------
  573 -- | Deletes an HTTP 'Cookie' from the 'Response' headers.
  574 deleteResponseCookie :: ByteString        -- ^ cookie name
  575                      -> Response          -- ^ response to modify
  576                      -> Response
  577 deleteResponseCookie cn r = r { rspCookies = cks' }
  578   where
  579     cks'= Map.delete cn $ rspCookies r
  580 {-# INLINE deleteResponseCookie #-}
  581 
  582 
  583 ------------------------------------------------------------------------------
  584 -- | Modifies an HTTP 'Cookie' with given name in 'Response' headers.
  585 -- Nothing will happen if a matching 'Cookie' can not be found in 'Response'.
  586 modifyResponseCookie :: ByteString          -- ^ cookie name
  587                      -> (Cookie -> Cookie)  -- ^ modifier function
  588                      -> Response            -- ^ response to modify
  589                      -> Response
  590 modifyResponseCookie cn f r = maybe r modify $ getResponseCookie cn r
  591   where
  592     modify ck = addResponseCookie (f ck) r
  593 {-# INLINE modifyResponseCookie #-}
  594 
  595 
  596 ------------------------------------------------------------------------------
  597 -- | A note here: if you want to set the @Content-Length@ for the response,
  598 -- Snap forces you to do it with this function rather than by setting it in
  599 -- the headers; the @Content-Length@ in the headers will be ignored.
  600 --
  601 -- The reason for this is that Snap needs to look up the value of
  602 -- @Content-Length@ for each request, and looking the string value up in the
  603 -- headers and parsing the number out of the text will be too expensive.
  604 --
  605 -- If you don't set a content length in your response, HTTP keep-alive will be
  606 -- disabled for HTTP\/1.0 clients, forcing a @Connection: close@. For
  607 -- HTTP\/1.1 clients, Snap will switch to the chunked transfer encoding if
  608 -- @Content-Length@ is not specified.
  609 setContentLength    :: Int64 -> Response -> Response
  610 setContentLength l r = r { rspContentLength = Just l }
  611 {-# INLINE setContentLength #-}
  612 
  613 
  614 ------------------------------------------------------------------------------
  615 -- | Removes any @Content-Length@ set in the 'Response'.
  616 clearContentLength :: Response -> Response
  617 clearContentLength r = r { rspContentLength = Nothing }
  618 {-# INLINE clearContentLength #-}
  619 
  620 
  621 ------------------------------------------------------------------------------
  622 -- HTTP dates
  623 
  624 -- | Converts a 'CTime' into an HTTP timestamp.
  625 formatHttpTime :: CTime -> IO ByteString
  626 
  627 -- | Converts a 'CTime' into common log entry format.
  628 formatLogTime :: CTime -> IO ByteString
  629 
  630 -- | Converts an HTTP timestamp into a 'CTime'.
  631 parseHttpTime :: ByteString -> IO CTime
  632 
  633 #ifdef PORTABLE
  634 
  635 formatHttpTime = return . format . toUTCTime
  636   where
  637     format :: UTCTime -> ByteString
  638     format = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT"
  639 
  640     toUTCTime :: CTime -> UTCTime
  641     toUTCTime = posixSecondsToUTCTime . realToFrac
  642 
  643 formatLogTime ctime = do
  644   t <- utcToLocalZonedTime $ toUTCTime ctime
  645   return $ format t
  646 
  647   where
  648     format :: ZonedTime -> ByteString
  649     format = fromStr . formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z"
  650 
  651     toUTCTime :: CTime -> UTCTime
  652     toUTCTime = posixSecondsToUTCTime . realToFrac
  653 
  654 
  655 parseHttpTime = return . toCTime . prs . toStr
  656   where
  657     prs :: String -> Maybe UTCTime
  658     prs = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
  659 
  660     toCTime :: Maybe UTCTime -> CTime
  661     toCTime (Just t) = fromInteger $ truncate $ utcTimeToPOSIXSeconds t
  662     toCTime Nothing  = fromInteger 0
  663 
  664 #else
  665 
  666 formatLogTime t = do
  667     ptr <- mallocBytes 40
  668     c_format_log_time t ptr
  669     S.unsafePackMallocCString ptr
  670 
  671 formatHttpTime t = do
  672     ptr <- mallocBytes 40
  673     c_format_http_time t ptr
  674     S.unsafePackMallocCString ptr
  675 
  676 parseHttpTime s = S.unsafeUseAsCString s $ \ptr ->
  677     c_parse_http_time ptr
  678 
  679 #endif
  680 
  681 
  682 ------------------------------------------------------------------------------
  683 -- URL ENCODING
  684 ------------------------------------------------------------------------------
  685 
  686 parseToCompletion :: Parser a -> ByteString -> Maybe a
  687 parseToCompletion p s = toResult $ finish r
  688   where
  689     r = parse p s
  690 
  691     toResult (Atto.Done _ c) = Just c
  692     toResult _               = Nothing
  693 
  694 
  695 ------------------------------------------------------------------------------
  696 pUrlEscaped :: Parser ByteString
  697 pUrlEscaped = do
  698     sq <- nextChunk DL.empty
  699     return $ S.concat $ DL.toList sq
  700 
  701   where
  702     nextChunk :: DList ByteString -> Parser (DList ByteString)
  703     nextChunk s = (endOfInput *> pure s) <|> do
  704         c <- anyWord8
  705         case w2c c of
  706           '+' -> plusSpace s
  707           '%' -> percentEncoded s
  708           _   -> unEncoded c s
  709 
  710     percentEncoded :: DList ByteString -> Parser (DList ByteString)
  711     percentEncoded l = do
  712         hx <- take 2
  713         when (S.length hx /= 2 ||
  714                (not $ S.all (isHexDigit . w2c) hx)) $
  715              fail "bad hex in url"
  716 
  717         let code = (Cvt.hex hx) :: Word8
  718         nextChunk $ DL.snoc l (S.singleton code)
  719 
  720     unEncoded :: Word8 -> DList ByteString -> Parser (DList ByteString)
  721     unEncoded c l' = do
  722         let l = DL.snoc l' (S.singleton c)
  723         bs <- takeTill (flip elem (map c2w "%+"))
  724         if S.null bs
  725           then nextChunk l
  726           else nextChunk $ DL.snoc l bs
  727 
  728     plusSpace :: DList ByteString -> Parser (DList ByteString)
  729     plusSpace l = nextChunk (DL.snoc l (S.singleton $ c2w ' '))
  730 
  731 
  732 ------------------------------------------------------------------------------
  733 -- | Decodes an URL-escaped string (see
  734 -- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)
  735 urlDecode :: ByteString -> Maybe ByteString
  736 urlDecode = parseToCompletion pUrlEscaped
  737 
  738 
  739 ------------------------------------------------------------------------------
  740 -- "...Only alphanumerics [0-9a-zA-Z], the special characters "$-_.+!*'(),"
  741 -- [not including the quotes - ed], and reserved characters used for their
  742 -- reserved purposes may be used unencoded within a URL."
  743 
  744 -- | URL-escapes a string (see
  745 -- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)
  746 urlEncode :: ByteString -> ByteString
  747 urlEncode = toByteString . S.foldl' f mempty
  748   where
  749     f b c =
  750         if c == c2w ' '
  751           then b `mappend` fromWord8 (c2w '+')
  752           else if isKosher c
  753                  then b `mappend` fromWord8 c
  754                  else b `mappend` hexd c
  755 
  756     isKosher w = any ($ c) [ isAlphaNum
  757                            , flip elem ['$', '-', '.', '!', '*'
  758                                        , '\'', '(', ')', ',' ]]
  759       where
  760         c = w2c w
  761 
  762 
  763 ------------------------------------------------------------------------------
  764 hexd :: Word8 -> Builder
  765 hexd c = fromWord8 (c2w '%') `mappend` fromWord8 hi `mappend` fromWord8 low
  766   where
  767     d   = c2w . intToDigit
  768     low = d $ fromEnum $ c .&. 0xf
  769     hi  = d $ fromEnum $ (c .&. 0xf0) `shift` (-4)
  770 
  771 
  772 ------------------------------------------------------------------------------
  773 finish :: Atto.Result a -> Atto.Result a
  774 finish (Atto.Partial f) = flip feed "" $ f ""
  775 finish x                = x
  776 
  777 
  778 ------------------------------------------------------------------------------
  779 -- local definitions
  780 fromStr :: String -> ByteString
  781 fromStr = S.pack . map c2w
  782 {-# INLINE fromStr #-}
  783 
  784 ------------------------------------------------------------------------------
  785 -- private helper functions
  786 toStr :: ByteString -> String
  787 toStr = map w2c . S.unpack
  788 
  789 
  790 ------------------------------------------------------------------------------
  791 statusReasonMap :: IM.IntMap ByteString
  792 statusReasonMap = IM.fromList [
  793         (100, "Continue"),
  794         (101, "Switching Protocols"),
  795         (200, "OK"),
  796         (201, "Created"),
  797         (202, "Accepted"),
  798         (203, "Non-Authoritative Information"),
  799         (204, "No Content"),
  800         (205, "Reset Content"),
  801         (206, "Partial Content"),
  802         (300, "Multiple Choices"),
  803         (301, "Moved Permanently"),
  804         (302, "Found"),
  805         (303, "See Other"),
  806         (304, "Not Modified"),
  807         (305, "Use Proxy"),
  808         (307, "Temporary Redirect"),
  809         (400, "Bad Request"),
  810         (401, "Unauthorized"),
  811         (402, "Payment Required"),
  812         (403, "Forbidden"),
  813         (404, "Not Found"),
  814         (405, "Method Not Allowed"),
  815         (406, "Not Acceptable"),
  816         (407, "Proxy Authentication Required"),
  817         (408, "Request Time-out"),
  818         (409, "Conflict"),
  819         (410, "Gone"),
  820         (411, "Length Required"),
  821         (412, "Precondition Failed"),
  822         (413, "Request Entity Too Large"),
  823         (414, "Request-URI Too Large"),
  824         (415, "Unsupported Media Type"),
  825         (416, "Requested range not satisfiable"),
  826         (417, "Expectation Failed"),
  827         (500, "Internal Server Error"),
  828         (501, "Not Implemented"),
  829         (502, "Bad Gateway"),
  830         (503, "Service Unavailable"),
  831         (504, "Gateway Time-out"),
  832         (505, "HTTP Version not supported")
  833     ]