1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE CPP #-} 3 {-# LANGUAGE EmptyDataDecls #-} 4 {-# LANGUAGE ExistentialQuantification #-} 5 {-# LANGUAGE FlexibleInstances #-} 6 {-# LANGUAGE ForeignFunctionInterface #-} 7 {-# LANGUAGE OverloadedStrings #-} 8 {-# LANGUAGE Rank2Types #-} 9 {-# LANGUAGE TypeSynonymInstances #-} 10 11 ------------------------------------------------------------------------------ 12 -- | An internal Snap module containing HTTP types. 13 -- 14 -- /N.B./ this is an internal interface, please don't write user code that 15 -- depends on it. Most of these declarations (except for the 16 -- unsafe/encapsulation-breaking ones) are re-exported from "Snap.Core". 17 -- 18 module Snap.Internal.Http.Types where 19 20 ------------------------------------------------------------------------------ 21 import Control.Monad (unless) 22 import Data.ByteString (ByteString) 23 import Data.ByteString.Builder (Builder, byteString, toLazyByteString) 24 import qualified Data.ByteString.Char8 as S 25 import qualified Data.ByteString.Lazy.Char8 as L 26 import Data.CaseInsensitive (CI) 27 import qualified Data.CaseInsensitive as CI 28 import qualified Data.IntMap as IM 29 import Data.List hiding (take) 30 import Data.Map (Map) 31 import qualified Data.Map as Map 32 import Data.Maybe (Maybe (..), fromMaybe, maybe) 33 import Data.Monoid (mconcat) 34 import Data.Time.Clock (UTCTime) 35 import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) 36 import Data.Word (Word64) 37 import Foreign.C.Types (CTime (..)) 38 import Prelude (Bool (..), Eq (..), FilePath, IO, Int, Integral (..), Monad (..), Num ((-)), Ord (..), Ordering (..), Read (..), Show (..), String, fmap, fromInteger, fromIntegral, id, not, otherwise, truncate, ($), (.)) 39 #ifdef PORTABLE 40 import Prelude (realToFrac, ($!)) 41 #endif 42 import System.IO (IOMode (ReadMode), SeekMode (AbsoluteSeek), hSeek, withBinaryFile) 43 import System.IO.Streams (InputStream, OutputStream) 44 import qualified System.IO.Streams as Streams 45 import System.IO.Unsafe (unsafePerformIO) 46 47 ------------------------------------------------------------------------------ 48 #ifdef PORTABLE 49 import Data.Time.Clock.POSIX 50 import Data.Time.Clock.POSIX 51 import Data.Time.Format 52 import Data.Time.Locale.Compat (defaultTimeLocale) 53 import Data.Time.LocalTime 54 #else 55 import qualified Data.ByteString.Unsafe as S 56 import Data.Time.Format () 57 import Foreign.C.String (CString) 58 import Foreign.Marshal.Alloc (mallocBytes) 59 #endif 60 61 ------------------------------------------------------------------------------ 62 import Snap.Types.Headers (Headers) 63 import qualified Snap.Types.Headers as H 64 65 66 #ifndef PORTABLE 67 68 ------------------------------------------------------------------------------ 69 -- foreign imports from cbits 70 foreign import ccall unsafe "set_c_locale" 71 set_c_locale :: IO () 72 73 foreign import ccall unsafe "c_parse_http_time" 74 c_parse_http_time :: CString -> IO CTime 75 76 foreign import ccall unsafe "c_format_http_time" 77 c_format_http_time :: CTime -> CString -> IO () 78 79 foreign import ccall unsafe "c_format_log_time" 80 c_format_log_time :: CTime -> CString -> IO () 81 82 #endif 83 84 85 ------------------------------------------------------------------------------ 86 -- | A typeclass for datatypes which contain HTTP headers. 87 class HasHeaders a where 88 -- | Modify the datatype's headers. 89 updateHeaders :: (Headers -> Headers) -> a -> a 90 91 -- | Retrieve the headers from a datatype that has headers. 92 headers :: a -> Headers 93 94 95 ------------------------------------------------------------------------------ 96 -- | Adds a header key-value-pair to the 'HasHeaders' datatype. If a header 97 -- with the same name already exists, the new value is appended to the headers 98 -- list. 99 -- 100 -- Example: 101 -- 102 -- @ 103 -- ghci> import qualified "Snap.Types.Headers" as H 104 -- ghci> 'addHeader' "Host" "localhost" H.'empty' 105 -- H {unH = [("host","localhost")]} 106 -- ghci> 'addHeader' "Host" "127.0.0.1" it 107 -- H {unH = [("host","localhost,127.0.0.1")]} 108 -- @ 109 addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a 110 addHeader k v = updateHeaders $ H.insert k v 111 112 113 ------------------------------------------------------------------------------ 114 -- | Sets a header key-value-pair in a 'HasHeaders' datatype. If a header with 115 -- the same name already exists, it is overwritten with the new value. 116 -- 117 -- Example: 118 -- 119 -- @ 120 -- ghci> import qualified "Snap.Types.Headers" as H 121 -- ghci> 'setHeader' "Host" "localhost" H.'empty' 122 -- H {unH = [(\"host\",\"localhost\")]} 123 -- ghci> setHeader "Host" "127.0.0.1" it 124 -- H {unH = [("host","127.0.0.1")]} 125 -- @ 126 setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a 127 setHeader k v = updateHeaders $ H.set k v 128 129 130 ------------------------------------------------------------------------------ 131 -- | Gets a header value out of a 'HasHeaders' datatype. 132 -- 133 -- Example: 134 -- 135 -- @ 136 -- ghci> import qualified "Snap.Types.Headers" as H 137 -- ghci> 'getHeader' "Host" $ 'setHeader' "Host" "localhost" H.'empty' 138 -- Just "localhost" 139 -- @ 140 getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString 141 getHeader k a = H.lookup k $ headers a 142 143 144 ------------------------------------------------------------------------------ 145 -- | Lists all the headers out of a 'HasHeaders' datatype. If many 146 -- headers came in with the same name, they will be catenated together. 147 -- 148 -- Example: 149 -- 150 -- @ 151 -- ghci> import qualified "Snap.Types.Headers" as H 152 -- ghci> 'listHeaders' $ 'setHeader' "Host" "localhost" H.'empty' 153 -- [("host","localhost")] 154 -- @ 155 listHeaders :: (HasHeaders a) => a -> [(CI ByteString, ByteString)] 156 listHeaders = H.toList . headers 157 158 159 ------------------------------------------------------------------------------ 160 -- | Clears a header value from a 'HasHeaders' datatype. 161 -- 162 -- Example: 163 -- 164 -- @ 165 -- ghci> import qualified "Snap.Types.Headers" as H 166 -- ghci> 'deleteHeader' "Host" $ 'setHeader' "Host" "localhost" H.'empty' 167 -- H {unH = []} 168 -- @ 169 deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a 170 deleteHeader k = updateHeaders $ H.delete k 171 172 173 ------------------------------------------------------------------------------ 174 -- | Enumerates the HTTP method values (see 175 -- <http://tools.ietf.org/html/rfc2068.html#section-5.1.1>). 176 data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT | 177 PATCH | Method ByteString 178 deriving(Show, Read) 179 180 instance Eq Method where 181 a == b = 182 normalizeMethod a `eq` normalizeMethod b 183 where 184 GET `eq` GET = True 185 HEAD `eq` HEAD = True 186 POST `eq` POST = True 187 PUT `eq` PUT = True 188 DELETE `eq` DELETE = True 189 TRACE `eq` TRACE = True 190 OPTIONS `eq` OPTIONS = True 191 CONNECT `eq` CONNECT = True 192 PATCH `eq` PATCH = True 193 Method x1 `eq` Method y1 = x1 == y1 194 _ `eq` _ = False 195 196 instance Ord Method where 197 compare a b = 198 check (normalizeMethod a) (normalizeMethod b) 199 where 200 check GET GET = EQ 201 check HEAD HEAD = EQ 202 check POST POST = EQ 203 check PUT PUT = EQ 204 check DELETE DELETE = EQ 205 check TRACE TRACE = EQ 206 check OPTIONS OPTIONS = EQ 207 check CONNECT CONNECT = EQ 208 check PATCH PATCH = EQ 209 check (Method x1) (Method y1) = compare x1 y1 210 check x y = compare (tag x) (tag y) 211 212 tag :: Method -> Int 213 tag (GET{}) = 0 214 tag (HEAD{}) = 1 215 tag (POST{}) = 2 216 tag (PUT{}) = 3 217 tag (DELETE{}) = 4 218 tag (TRACE{}) = 5 219 tag (OPTIONS{}) = 6 220 tag (CONNECT{}) = 7 221 tag (PATCH{}) = 8 222 tag (Method{}) = 9 223 224 -- | Equate the special case constructors with their corresponding 225 -- @Method name@ variant. 226 {-# INLINE normalizeMethod #-} 227 normalizeMethod :: Method -> Method 228 normalizeMethod m@(Method name) = case name of 229 "GET" -> GET 230 "HEAD" -> HEAD 231 "POST" -> POST 232 "PUT" -> PUT 233 "DELETE" -> DELETE 234 "TRACE" -> TRACE 235 "OPTIONS" -> OPTIONS 236 "CONNECT" -> CONNECT 237 "PATCH" -> PATCH 238 _ -> m 239 normalizeMethod m = m 240 241 242 ------------------------------------------------------------------------------ 243 -- | Represents a (major, minor) version of the HTTP protocol. 244 type HttpVersion = (Int,Int) 245 246 247 ------------------------------------------------------------------------------ 248 -- | A datatype representing an HTTP cookie. 249 data Cookie = Cookie { 250 -- | The name of the cookie. 251 cookieName :: !ByteString 252 253 -- | The cookie's string value. 254 , cookieValue :: !ByteString 255 256 -- | The cookie's expiration value, if it has one. 257 , cookieExpires :: !(Maybe UTCTime) 258 259 -- | The cookie's \"domain\" value, if it has one. 260 , cookieDomain :: !(Maybe ByteString) 261 262 -- | The cookie path. 263 , cookiePath :: !(Maybe ByteString) 264 265 -- | Tag as secure cookie? 266 , cookieSecure :: !Bool 267 268 -- | HTTP only? 269 , cookieHttpOnly :: !Bool 270 } deriving (Eq, Show) 271 272 273 ------------------------------------------------------------------------------ 274 -- | A type alias for the HTTP parameters mapping. Each parameter 275 -- key maps to a list of 'ByteString' values; if a parameter is specified 276 -- multiple times (e.g.: \"@GET /foo?param=bar1¶m=bar2@\"), looking up 277 -- \"@param@\" in the mapping will give you @[\"bar1\", \"bar2\"]@. 278 type Params = Map ByteString [ByteString] 279 280 281 ------------------------------------------------------------------------------ 282 -- request type 283 ------------------------------------------------------------------------------ 284 285 ------------------------------------------------------------------------------ 286 -- | Contains all of the information about an incoming HTTP request. 287 data Request = Request 288 { -- | The server name of the request, as it came in from the request's 289 -- @Host:@ header. 290 -- 291 -- Example: 292 -- 293 -- @ 294 -- ghci> :set -XOverloadedStrings 295 -- ghci> import qualified "Snap.Test" as T 296 -- ghci> import qualified "Data.Map" as M 297 -- ghci> :{ 298 -- ghci| rq <- T.buildRequest $ do 299 -- ghci| T.get "\/foo\/bar" M.empty 300 -- ghci| T.setHeader "host" "example.com" 301 -- ghci| :} 302 -- ghci> rqHostName rq 303 -- "example.com" 304 -- @ 305 rqHostName :: ByteString 306 307 -- | The remote IP address. 308 -- 309 -- Example: 310 -- 311 -- @ 312 -- ghci> :set -XOverloadedStrings 313 -- ghci> import qualified "Snap.Test" as T 314 -- ghci> import qualified "Data.Map" as M 315 -- ghci> rqClientAddr \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 316 -- "127.0.0.1" 317 -- @ 318 , rqClientAddr :: ByteString 319 320 -- | The remote TCP port number. 321 -- 322 -- Example: 323 -- 324 -- @ 325 -- ghci> :set -XOverloadedStrings 326 -- ghci> import qualified "Snap.Test" as T 327 -- ghci> import qualified "Data.Map" as M 328 -- ghci> rqClientPort \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 329 -- "60000" 330 -- @ 331 , rqClientPort :: {-# UNPACK #-} !Int 332 333 -- | The local IP address for this request. 334 -- 335 -- Example: 336 -- 337 -- @ 338 -- ghci> :set -XOverloadedStrings 339 -- ghci> import qualified "Snap.Test" as T 340 -- ghci> import qualified "Data.Map" as M 341 -- ghci> rqServerAddr \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 342 -- "127.0.0.1" 343 -- @ 344 , rqServerAddr :: ByteString 345 346 -- | Returns the port number the HTTP server is listening on. This may be 347 -- useless from the perspective of external requests, e.g. if the server 348 -- is running behind a proxy. 349 -- 350 -- Example: 351 -- 352 -- @ 353 -- ghci> :set -XOverloadedStrings 354 -- ghci> import qualified "Snap.Test" as T 355 -- ghci> import qualified "Data.Map" as M 356 -- ghci> rqServerPort \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 357 -- 8080 358 -- @ 359 , rqServerPort :: {-# UNPACK #-} !Int 360 361 -- | Returns the HTTP server's idea of its local hostname, including 362 -- port. This is as configured with the @Config@ object at startup. 363 -- 364 -- Example: 365 -- 366 -- @ 367 -- ghci> :set -XOverloadedStrings 368 -- ghci> import qualified "Snap.Test" as T 369 -- ghci> import qualified "Data.Map" as M 370 -- ghci> rqLocalHostname \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 371 -- "localhost" 372 -- @ 373 , rqLocalHostname :: ByteString 374 375 -- | Returns @True@ if this is an HTTPS session. 376 -- 377 -- Example: 378 -- 379 -- @ 380 -- ghci> :set -XOverloadedStrings 381 -- ghci> import qualified "Snap.Test" as T 382 -- ghci> import qualified "Data.Map" as M 383 -- ghci> rqIsSecure \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 384 -- False 385 -- @ 386 , rqIsSecure :: !Bool 387 388 -- | Contains all HTTP 'Headers' associated with this request. 389 -- 390 -- Example: 391 -- 392 -- @ 393 -- ghci> :set -XOverloadedStrings 394 -- ghci> import qualified "Snap.Test" as T 395 -- ghci> import qualified "Data.Map" as M 396 -- ghci> rqHeaders \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 397 -- H {unH = [("host","localhost")]} 398 -- @ 399 , rqHeaders :: Headers 400 401 -- | Actual body of the request. 402 , rqBody :: InputStream ByteString 403 404 -- | Returns the @Content-Length@ of the HTTP request body. 405 -- 406 -- Example: 407 -- 408 -- @ 409 -- ghci> :set -XOverloadedStrings 410 -- ghci> import qualified "Snap.Test" as T 411 -- ghci> import qualified "Data.Map" as M 412 -- ghci> rqContentLength \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 413 -- Nothing 414 -- @ 415 , rqContentLength :: !(Maybe Word64) 416 417 -- | Returns the HTTP request method. 418 -- 419 -- Example: 420 -- 421 -- @ 422 -- ghci> :set -XOverloadedStrings 423 -- ghci> import qualified "Snap.Test" as T 424 -- ghci> import qualified "Data.Map" as M 425 -- ghci> rqMethod \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 426 -- GET 427 -- @ 428 , rqMethod :: !Method 429 430 -- | Returns the HTTP version used by the client. 431 -- 432 -- Example: 433 -- 434 -- @ 435 -- ghci> :set -XOverloadedStrings 436 -- ghci> import qualified "Snap.Test" as T 437 -- ghci> import qualified "Data.Map" as M 438 -- ghci> rqVersion \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 439 -- (1,1) 440 -- @ 441 , rqVersion :: {-# UNPACK #-} !HttpVersion 442 443 -- | Returns a list of the cookies that came in from the HTTP request 444 -- headers. 445 -- 446 -- Example: 447 -- 448 -- @ 449 -- ghci> :set -XOverloadedStrings 450 -- ghci> import qualified "Snap.Test" as T 451 -- ghci> import qualified "Data.Map" as M 452 -- ghci> rqCookies \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 453 -- [] 454 -- @ 455 , rqCookies :: [Cookie] 456 457 -- | Handlers can be hung on a @URI@ \"entry point\"; this is called the 458 -- \"context path\". If a handler is hung on the context path 459 -- @\"\/foo\/\"@, and you request @\"\/foo\/bar\"@, the value of 460 -- 'rqPathInfo' will be @\"bar\"@. 461 -- 462 -- The following identity holds: 463 -- 464 -- > rqURI r == S.concat [ rqContextPath r 465 -- > , rqPathInfo r 466 -- > , let q = rqQueryString r 467 -- > in if S.null q 468 -- > then "" 469 -- > else S.append "?" q 470 -- > ] 471 -- 472 -- Example: 473 -- 474 -- @ 475 -- ghci> :set -XOverloadedStrings 476 -- ghci> import qualified "Snap.Test" as T 477 -- ghci> import qualified "Data.Map" as M 478 -- ghci> rqPathInfo \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 479 -- "foo/bar" 480 -- @ 481 , rqPathInfo :: ByteString 482 483 -- | The \"context path\" of the request; catenating 'rqContextPath', 484 -- and 'rqPathInfo' should get you back to the original 'rqURI' 485 -- (ignoring query strings). The 'rqContextPath' always begins and ends 486 -- with a slash (@\"\/\"@) character, and represents the path (relative 487 -- to your component\/snaplet) you took to get to your handler. 488 -- 489 -- Example: 490 -- 491 -- @ 492 -- ghci> :set -XOverloadedStrings 493 -- ghci> import qualified "Snap.Test" as T 494 -- ghci> import qualified "Data.Map" as M 495 -- ghci> rqContextPath \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 496 -- "/" 497 -- @ 498 , rqContextPath :: ByteString 499 500 -- | Returns the @URI@ requested by the client. 501 -- 502 -- Example: 503 -- 504 -- @ 505 -- ghci> :set -XOverloadedStrings 506 -- ghci> import qualified "Snap.Test" as T 507 -- ghci> import qualified "Data.Map" as M 508 -- ghci> rqURI \`fmap\` T.buildRequest (T.get "\/foo\/bar" M.empty) 509 -- "foo/bar" 510 -- @ 511 , rqURI :: ByteString 512 513 -- | Returns the HTTP query string for this 'Request'. 514 -- 515 -- Example: 516 -- 517 -- @ 518 -- ghci> :set -XOverloadedStrings 519 -- ghci> import qualified "Snap.Test" as T 520 -- ghci> import qualified "Data.Map" as M 521 -- ghci> rq <- T.buildRequest (T.get "\/foo\/bar" (M.fromList [("name", ["value"])])) 522 -- ghci> rqQueryString rq 523 -- "name=value" 524 -- @ 525 , rqQueryString :: ByteString 526 527 -- | Returns the parameters mapping for this 'Request'. \"Parameters\" 528 -- are automatically decoded from the URI's query string and @POST@ body 529 -- and entered into this mapping. The 'rqParams' value is thus a union of 530 -- 'rqQueryParams' and 'rqPostParams'. 531 -- 532 -- Example: 533 -- 534 -- @ 535 -- ghci> :set -XOverloadedStrings 536 -- ghci> import qualified "Snap.Test" as T 537 -- ghci> import qualified "Data.Map" as M 538 -- ghci> :{ 539 -- ghci| rq <- T.buildRequest $ do 540 -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])] 541 -- ghci| T.setQueryStringRaw "baz=quux" 542 -- ghci| :} 543 -- ghci> rqParams rq 544 -- fromList [("baz",["qux","quux"])] 545 -- @ 546 , rqParams :: Params 547 548 -- | The parameter mapping decoded from the URI's query string. 549 -- 550 -- Example: 551 -- 552 -- @ 553 -- ghci> :set -XOverloadedStrings 554 -- ghci> import qualified "Snap.Test" as T 555 -- ghci> import qualified "Data.Map" as M 556 -- ghci> :{ 557 -- ghci| rq <- T.buildRequest $ do 558 -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])] 559 -- ghci| T.setQueryStringRaw "baz=quux" 560 -- ghci| :} 561 -- ghci> rqQueryParams rq 562 -- fromList [("baz",["quux"])] 563 -- @ 564 , rqQueryParams :: Params 565 566 -- | The parameter mapping decoded from the POST body. Note that Snap 567 -- only auto-decodes POST request bodies when the request's 568 -- @Content-Type@ is @application\/x-www-form-urlencoded@. 569 -- For @multipart\/form-data@ use 'Snap.Util.FileUploads.handleFileUploads' 570 -- to decode the POST request and fill this mapping. 571 -- 572 -- Example: 573 -- 574 -- @ 575 -- ghci> :set -XOverloadedStrings 576 -- ghci> import qualified "Snap.Test" as T 577 -- ghci> import qualified "Data.Map" as M 578 -- ghci> :{ 579 -- ghci| rq <- T.buildRequest $ do 580 -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])] 581 -- ghci| T.setQueryStringRaw "baz=quux" 582 -- ghci| :} 583 -- ghci> rqPostParams rq 584 -- fromList [("baz",["qux"])] 585 -- @ 586 , rqPostParams :: Params 587 } 588 589 590 ------------------------------------------------------------------------------ 591 instance Show Request where 592 show r = concat [ method, " ", uri, " HTTP/", version, "\n" 593 , hdrs, "\n\n" 594 , "sn=\"", sname, "\" c=", clntAddr, " s=", srvAddr 595 , " ctx=", contextpath, " clen=", contentlength, secure 596 , params, cookies 597 ] 598 where 599 method = show $ rqMethod r 600 uri = S.unpack $ rqURI r 601 version = let (mj, mn) = rqVersion r in show mj ++ "." ++ show mn 602 hdrs = intercalate "\n" $ map showHdr (H.toList $ rqHeaders r) 603 showHdr (a,b) = (S.unpack $ CI.original a) ++ ": " ++ S.unpack b 604 sname = S.unpack $ rqLocalHostname r 605 clntAddr = concat [S.unpack $ rqClientAddr r, ":", show $ rqClientPort r] 606 srvAddr = concat [S.unpack $ rqServerAddr r, ":", show $ rqServerPort r] 607 contextpath = S.unpack $ rqContextPath r 608 contentlength = maybe "n/a" show (rqContentLength r) 609 secure = if rqIsSecure r then " secure" else "" 610 611 params = showFlds "\nparams: " ", " $ 612 map (\ (a,b) -> S.unpack a ++ ": " ++ show b) 613 (Map.toAscList $ rqParams r) 614 cookies = showFlds "\ncookies: " "\n " $ 615 map show (rqCookies r) 616 617 showFlds header delim lst 618 = if not . null $ lst then header ++ (intercalate delim lst) 619 else "" :: String 620 621 ------------------------------------------------------------------------------ 622 instance HasHeaders Request where 623 headers = rqHeaders 624 updateHeaders f r = r { rqHeaders = f (rqHeaders r) } 625 626 627 ------------------------------------------------------------------------------ 628 instance HasHeaders Headers where 629 headers = id 630 updateHeaders = id 631 632 ------------------------------------------------------------------------------ 633 -- response type 634 ------------------------------------------------------------------------------ 635 636 type StreamProc = OutputStream Builder -> IO (OutputStream Builder) 637 data ResponseBody = Stream (StreamProc) 638 -- ^ output body is a function that writes to a 'Builder' 639 -- stream 640 641 | SendFile FilePath (Maybe (Word64, Word64)) 642 -- ^ output body is sendfile(), optional second argument 643 -- is a byte range to send 644 645 646 ------------------------------------------------------------------------------ 647 rspBodyMap :: (StreamProc -> StreamProc) -> ResponseBody -> ResponseBody 648 rspBodyMap f b = Stream $ f $ rspBodyToEnum b 649 650 651 ------------------------------------------------------------------------------ 652 rspBodyToEnum :: ResponseBody -> StreamProc 653 rspBodyToEnum (Stream e) = e 654 655 rspBodyToEnum (SendFile fp Nothing) = \out -> 656 Streams.withFileAsInput fp $ \is -> do 657 is' <- Streams.mapM (return . byteString) is 658 Streams.connect is' out 659 return out 660 661 rspBodyToEnum (SendFile fp (Just (start, end))) = \out -> 662 withBinaryFile fp ReadMode $ \handle -> do 663 unless (start == 0) $ hSeek handle AbsoluteSeek $ toInteger start 664 is <- Streams.handleToInputStream handle 665 is' <- Streams.takeBytes (fromIntegral $ end - start) is >>= 666 Streams.mapM (return . byteString) 667 Streams.connect is' out 668 return out 669 670 671 ------------------------------------------------------------------------------ 672 -- | Represents an HTTP response. 673 data Response = Response 674 { rspHeaders :: Headers 675 , rspCookies :: Map ByteString Cookie 676 677 -- | We will need to inspect the content length no matter what, and 678 -- looking up \"content-length\" in the headers and parsing the number 679 -- out of the text will be too expensive. 680 , rspContentLength :: !(Maybe Word64) 681 , rspBody :: ResponseBody 682 683 -- | Returns the HTTP status code. 684 -- 685 -- Example: 686 -- 687 -- @ 688 -- ghci> rspStatus 'emptyResponse' 689 -- 200 690 -- @ 691 , rspStatus :: !Int 692 693 -- | Returns the HTTP status explanation string. 694 -- 695 -- Example: 696 -- 697 -- @ 698 -- ghci> rspStatusReason 'emptyResponse' 699 -- "OK" 700 -- @ 701 , rspStatusReason :: !ByteString 702 703 -- | If true, we are transforming the request body with 704 -- 'transformRequestBody' 705 , rspTransformingRqBody :: !Bool 706 } 707 708 709 ------------------------------------------------------------------------------ 710 instance Show Response where 711 show r = concat [ statusline 712 , hdrs 713 , contentLength 714 , "\r\n" 715 , body 716 ] 717 where 718 statusline = concat [ "HTTP/1.1 " 719 , show $ rspStatus r 720 , " " 721 , S.unpack $ rspStatusReason r 722 , "\r\n" ] 723 724 hdrs = concatMap showHdr $ H.toList $ renderCookies r 725 $ rspHeaders $ clearContentLength r 726 727 contentLength = maybe "" (\l -> concat ["Content-Length: ", show l, "\r\n"] ) (rspContentLength r) 728 729 showHdr (k,v) = concat [ S.unpack (CI.original k), ": ", S.unpack v, "\r\n" ] 730 731 -- io-streams are impure, so we're forced to use 'unsafePerformIO'. 732 body = unsafePerformIO $ do 733 (os, grab) <- Streams.listOutputStream 734 let f = rspBodyToEnum $ rspBody r 735 _ <- f os 736 fmap (L.unpack . toLazyByteString . mconcat) grab 737 738 739 740 ------------------------------------------------------------------------------ 741 instance HasHeaders Response where 742 headers = rspHeaders 743 updateHeaders f r = r { rspHeaders = f (rspHeaders r) } 744 745 746 ------------------------------------------------------------------------------ 747 -- | Looks up the value(s) for the given named parameter. Parameters initially 748 -- come from the request's query string and any decoded POST body (if the 749 -- request's @Content-Type@ is @application\/x-www-form-urlencoded@). 750 -- Parameter values can be modified within handlers using "rqModifyParams". 751 -- 752 -- Example: 753 -- 754 -- @ 755 -- ghci> :set -XOverloadedStrings 756 -- ghci> import qualified "Snap.Test" as T 757 -- ghci> import qualified "Data.Map" as M 758 -- ghci> :{ 759 -- ghci| rq <- T.buildRequest $ do 760 -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])] 761 -- ghci| T.setQueryStringRaw "baz=quux" 762 -- ghci| :} 763 -- ghci> 'rqParam' "baz" rq 764 -- Just ["qux","quux"] 765 -- @ 766 rqParam :: ByteString -- ^ parameter name to look up 767 -> Request -- ^ HTTP request 768 -> Maybe [ByteString] 769 rqParam k rq = Map.lookup k $ rqParams rq 770 {-# INLINE rqParam #-} 771 772 773 ------------------------------------------------------------------------------ 774 -- | Looks up the value(s) for the given named parameter in the POST parameters 775 -- mapping. 776 -- 777 -- Example: 778 -- 779 -- @ 780 -- ghci> :set -XOverloadedStrings 781 -- ghci> import qualified "Snap.Test" as T 782 -- ghci> import qualified "Data.Map" as M 783 -- ghci> :{ 784 -- ghci| rq <- T.buildRequest $ do 785 -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])] 786 -- ghci| T.setQueryStringRaw "baz=quux" 787 -- ghci| :} 788 -- ghci> 'rqPostParam' "baz" rq 789 -- Just ["qux"] 790 -- @ 791 rqPostParam :: ByteString -- ^ parameter name to look up 792 -> Request -- ^ HTTP request 793 -> Maybe [ByteString] 794 rqPostParam k rq = Map.lookup k $ rqPostParams rq 795 {-# INLINE rqPostParam #-} 796 797 798 ------------------------------------------------------------------------------ 799 -- | Looks up the value(s) for the given named parameter in the query 800 -- parameters mapping. 801 -- 802 -- Example: 803 -- 804 -- @ 805 -- ghci> :set -XOverloadedStrings 806 -- ghci> import qualified "Snap.Test" as T 807 -- ghci> import qualified "Data.Map" as M 808 -- ghci> :{ 809 -- ghci| rq <- T.buildRequest $ do 810 -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])] 811 -- ghci| T.setQueryStringRaw "baz=quux" 812 -- ghci| :} 813 -- ghci> 'rqQueryParam' "baz" rq 814 -- Just ["quux"] 815 -- @ 816 rqQueryParam :: ByteString -- ^ parameter name to look up 817 -> Request -- ^ HTTP request 818 -> Maybe [ByteString] 819 rqQueryParam k rq = Map.lookup k $ rqQueryParams rq 820 {-# INLINE rqQueryParam #-} 821 822 823 ------------------------------------------------------------------------------ 824 -- | Modifies the parameters mapping (which is a @Map ByteString ByteString@) 825 -- in a 'Request' using the given function. 826 -- 827 -- Example: 828 -- 829 -- @ 830 -- ghci> :set -XOverloadedStrings 831 -- ghci> import qualified "Snap.Test" as T 832 -- ghci> import qualified "Data.Map" as M 833 -- ghci> :{ 834 -- ghci| rq <- T.buildRequest $ do 835 -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])] 836 -- ghci| T.setQueryStringRaw "baz=quux" 837 -- ghci| :} 838 -- ghci> 'rqParams' rq 839 -- fromList [("baz",["qux","quux"])] 840 -- ghci> 'rqParams' $ 'rqModifyParams' (M.delete "baz") rq 841 -- fromList [] 842 -- @ 843 rqModifyParams :: (Params -> Params) -> Request -> Request 844 rqModifyParams f r = r { rqParams = p } 845 where 846 p = f $ rqParams r 847 {-# INLINE rqModifyParams #-} 848 849 850 ------------------------------------------------------------------------------ 851 -- | Writes a key-value pair to the parameters mapping within the given 852 -- request. 853 -- 854 -- Example: 855 -- 856 -- @ 857 -- ghci> :set -XOverloadedStrings 858 -- ghci> import qualified "Snap.Test" as T 859 -- ghci> import qualified "Data.Map" as M 860 -- ghci> :{ 861 -- ghci| rq <- T.buildRequest $ do 862 -- ghci| T.postUrlEncoded "\/foo\/bar" $ M.fromList [("baz", ["qux"])] 863 -- ghci| T.setQueryStringRaw "baz=quux" 864 -- ghci| :} 865 -- ghci> 'rqParams' rq 866 -- fromList [("baz",["qux","quux"])] 867 -- ghci> 'rqParams' $ 'rqSetParam' "baz" ["corge"] rq 868 -- fromList [("baz", ["corge"])] 869 -- @ 870 rqSetParam :: ByteString -- ^ parameter name 871 -> [ByteString] -- ^ parameter values 872 -> Request -- ^ request 873 -> Request 874 rqSetParam k v = rqModifyParams $ Map.insert k v 875 {-# INLINE rqSetParam #-} 876 877 878 --------------- 879 -- responses -- 880 --------------- 881 882 ------------------------------------------------------------------------------ 883 -- | An empty 'Response'. 884 -- 885 -- Example: 886 -- 887 -- @ 888 -- ghci> 'emptyResponse' 889 -- HTTP\/1.1 200 OK 890 -- 891 -- 892 -- @ 893 emptyResponse :: Response 894 emptyResponse = Response H.empty Map.empty Nothing 895 (Stream (return . id)) 896 200 "OK" False 897 898 899 ------------------------------------------------------------------------------ 900 -- | Sets an HTTP response body to the given stream procedure. 901 -- 902 -- Example: 903 -- 904 -- @ 905 -- ghci> :set -XOverloadedStrings 906 -- ghci> import qualified "System.IO.Streams" as Streams 907 -- ghci> import qualified "Data.ByteString.Builder" as Builder 908 -- ghci> :{ 909 -- ghci| let r = 'setResponseBody' 910 -- ghci| (\out -> do 911 -- ghci| Streams.write (Just $ Builder.'byteString' \"Hello, world!\") out 912 -- ghci| return out) 913 -- ghci| 'emptyResponse' 914 -- ghci| :} 915 -- ghci> r 916 -- HTTP\/1.1 200 OK 917 -- 918 -- Hello, world! 919 -- @ 920 setResponseBody :: (OutputStream Builder -> IO (OutputStream Builder)) 921 -- ^ new response body 922 -> Response -- ^ response to modify 923 -> Response 924 setResponseBody e r = r { rspBody = Stream e } 925 {-# INLINE setResponseBody #-} 926 927 928 ------------------------------------------------------------------------------ 929 -- | Sets the HTTP response status. Note: normally you would use 930 -- 'setResponseCode' unless you needed a custom response explanation. 931 -- 932 -- 933 -- Example: 934 -- 935 -- @ 936 -- ghci> :set -XOverloadedStrings 937 -- ghci> setResponseStatus 500 \"Internal Server Error\" 'emptyResponse' 938 -- HTTP\/1.1 500 Internal Server Error 939 -- 940 -- 941 -- @ 942 setResponseStatus :: Int -- ^ HTTP response integer code 943 -> ByteString -- ^ HTTP response explanation 944 -> Response -- ^ Response to be modified 945 -> Response 946 setResponseStatus s reason r = r { rspStatus=s, rspStatusReason=reason } 947 {-# INLINE setResponseStatus #-} 948 949 950 ------------------------------------------------------------------------------ 951 -- | Sets the HTTP response code. 952 -- 953 -- Example: 954 -- 955 -- @ 956 -- ghci> setResponseCode 404 'emptyResponse' 957 -- HTTP\/1.1 404 Not Found 958 -- 959 -- 960 -- @ 961 setResponseCode :: Int -- ^ HTTP response integer code 962 -> Response -- ^ Response to be modified 963 -> Response 964 setResponseCode s r = setResponseStatus s reason r 965 where 966 reason = fromMaybe "Unknown" (IM.lookup s statusReasonMap) 967 {-# INLINE setResponseCode #-} 968 969 970 ------------------------------------------------------------------------------ 971 -- | Modifies a response body. 972 -- 973 -- Example: 974 -- 975 -- @ 976 -- ghci> :set -XOverloadedStrings 977 -- ghci> import qualified "System.IO.Streams" as Streams 978 -- ghci> import qualified "Data.ByteString.Builder" as Builder 979 -- ghci> :{ 980 -- ghci| let r = 'setResponseBody' 981 -- ghci| (\out -> do 982 -- ghci| Streams.write (Just $ Builder.'byteString' \"Hello, world!\") out 983 -- ghci| return out) 984 -- ghci| 'emptyResponse' 985 -- ghci| :} 986 -- ghci> r 987 -- HTTP\/1.1 200 OK 988 -- 989 -- Hello, world! 990 -- ghci> :{ 991 -- ghci| let r' = 'modifyResponseBody' 992 -- ghci| (\f out -> do 993 -- ghci| out' <- f out 994 -- ghci| Streams.write (Just $ Builder.'byteString' \"\\nBye, world!\") out' 995 -- ghci| return out') r 996 -- ghci| :} 997 -- ghci> r' 998 -- HTTP\/1.1 200 OK 999 -- 1000 -- Hello, world! 1001 -- Bye, world! 1002 -- @ 1003 modifyResponseBody :: ((OutputStream Builder -> IO (OutputStream Builder)) -> 1004 (OutputStream Builder -> IO (OutputStream Builder))) 1005 -> Response 1006 -> Response 1007 modifyResponseBody f r = r { rspBody = rspBodyMap f (rspBody r) } 1008 {-# INLINE modifyResponseBody #-} 1009 1010 1011 ------------------------------------------------------------------------------ 1012 -- | Sets the @Content-Type@ in the 'Response' headers. 1013 -- 1014 -- Example: 1015 -- 1016 -- @ 1017 -- ghci> :set -XOverloadedStrings 1018 -- ghci> setContentType \"text\/html\" 'emptyResponse' 1019 -- HTTP\/1.1 200 OK 1020 -- content-type: text\/html 1021 -- 1022 -- 1023 -- @ 1024 setContentType :: ByteString -> Response -> Response 1025 setContentType = setHeader "Content-Type" 1026 {-# INLINE setContentType #-} 1027 1028 1029 ------------------------------------------------------------------------------ 1030 -- | Convert 'Cookie' into 'ByteString' for output. 1031 -- 1032 -- TODO: Remove duplication. This function is copied from 1033 -- snap-server/Snap.Internal.Http.Server.Session. 1034 cookieToBS :: Cookie -> ByteString 1035 cookieToBS (Cookie k v mbExpTime mbDomain mbPath isSec isHOnly) = cookie 1036 where 1037 cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly] 1038 path = maybe "" (S.append "; path=") mbPath 1039 domain = maybe "" (S.append "; domain=") mbDomain 1040 exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime 1041 secure = if isSec then "; Secure" else "" 1042 hOnly = if isHOnly then "; HttpOnly" else "" 1043 1044 -- TODO: 'formatHttpTime' uses "DD MMM YYYY" instead of "DD-MMM-YYYY", 1045 -- unlike the code in 'Snap.Internal.Http.Server.Session'. Is this form 1046 -- allowed? 1047 fmt = unsafePerformIO . formatHttpTime . toCTime 1048 1049 toCTime :: UTCTime -> CTime 1050 toCTime = fromInteger . truncate . utcTimeToPOSIXSeconds 1051 1052 ------------------------------------------------------------------------------ 1053 -- | Render cookies from a given 'Response' to 'Headers'. 1054 -- 1055 -- TODO: Remove duplication. This function is copied from 1056 -- snap-server/Snap.Internal.Http.Server.Session. 1057 renderCookies :: Response -> Headers -> Headers 1058 renderCookies r hdrs 1059 | null cookies = hdrs 1060 | otherwise = foldl' (\m v -> H.unsafeInsert "set-cookie" v m) hdrs cookies 1061 1062 where 1063 cookies = fmap cookieToBS . Map.elems $ rspCookies r 1064 1065 ------------------------------------------------------------------------------ 1066 -- | Adds an HTTP 'Cookie' to 'Response' headers. 1067 -- 1068 -- Example: 1069 -- 1070 -- @ 1071 -- ghci> :set -XOverloadedStrings 1072 -- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False 1073 -- ghci> 'getResponseCookie' \"name\" $ 'addResponseCookie' cookie 'emptyResponse' 1074 -- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...}) 1075 -- @ 1076 addResponseCookie :: Cookie -- ^ cookie value 1077 -> Response -- ^ response to modify 1078 -> Response 1079 addResponseCookie ck@(Cookie k _ _ _ _ _ _) r = r { rspCookies = cks' } 1080 where 1081 cks'= Map.insert k ck $ rspCookies r 1082 {-# INLINE addResponseCookie #-} 1083 1084 1085 ------------------------------------------------------------------------------ 1086 -- | Gets an HTTP 'Cookie' with the given name from 'Response' headers. 1087 -- 1088 -- Example: 1089 -- 1090 -- @ 1091 -- ghci> :set -XOverloadedStrings 1092 -- ghci> 'getResponseCookie' \"cookie-name\" 'emptyResponse' 1093 -- Nothing 1094 -- @ 1095 getResponseCookie :: ByteString -- ^ cookie name 1096 -> Response -- ^ response to query 1097 -> Maybe Cookie 1098 getResponseCookie cn r = Map.lookup cn $ rspCookies r 1099 {-# INLINE getResponseCookie #-} 1100 1101 1102 -- | Returns a list of 'Cookie's present in 'Response' 1103 -- 1104 -- Example: 1105 -- 1106 -- @ 1107 -- ghci> 'getResponseCookies' 'emptyResponse' 1108 -- [] 1109 -- @ 1110 getResponseCookies :: Response -- ^ response to query 1111 -> [Cookie] 1112 getResponseCookies = Map.elems . rspCookies 1113 {-# INLINE getResponseCookies #-} 1114 1115 1116 ------------------------------------------------------------------------------ 1117 -- | Deletes an HTTP 'Cookie' from the 'Response' headers. Please note 1118 -- this does not necessarily erase the cookie from the client browser. 1119 -- 1120 -- Example: 1121 -- 1122 -- @ 1123 -- ghci> :set -XOverloadedStrings 1124 -- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False 1125 -- ghci> let rsp = 'addResponseCookie' cookie 'emptyResponse' 1126 -- ghci> 'getResponseCookie' \"name\" rsp 1127 -- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...}) 1128 -- ghci> 'getResponseCookie' \"name\" $ 'deleteResponseCookie' \"name\" rsp 1129 -- Nothing 1130 -- @ 1131 deleteResponseCookie :: ByteString -- ^ cookie name 1132 -> Response -- ^ response to modify 1133 -> Response 1134 deleteResponseCookie cn r = r { rspCookies = cks' } 1135 where 1136 cks'= Map.delete cn $ rspCookies r 1137 {-# INLINE deleteResponseCookie #-} 1138 1139 1140 ------------------------------------------------------------------------------ 1141 -- | Modifies an HTTP 'Cookie' with given name in 'Response' headers. 1142 -- Nothing will happen if a matching 'Cookie' can not be found in 'Response'. 1143 -- 1144 -- Example: 1145 -- 1146 -- @ 1147 -- ghci> :set -XOverloadedStrings 1148 -- ghci> import "Data.Monoid" 1149 -- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False 1150 -- ghci> let rsp = 'addResponseCookie' cookie 'emptyResponse' 1151 -- ghci> 'getResponseCookie' \"name\" rsp 1152 -- Just (Cookie {cookieName = \"name\", cookieValue = \"value\", ...}) 1153 -- ghci> let f ck@('Cookie' { cookieName = name }) = ck { cookieName = name <> \"\'\"} 1154 -- ghci> let rsp' = 'modifyResponseCookie' \"name\" f rsp 1155 -- ghci> 'getResponseCookie' \"name\'\" rsp\' 1156 -- Just (Cookie {cookieName = \"name\'\", ...}) 1157 -- ghci> 'getResponseCookie' \"name\" rsp\' 1158 -- Just (Cookie {cookieName = \"name\", ...}) 1159 -- @ 1160 modifyResponseCookie :: ByteString -- ^ cookie name 1161 -> (Cookie -> Cookie) -- ^ modifier function 1162 -> Response -- ^ response to modify 1163 -> Response 1164 modifyResponseCookie cn f r = maybe r modify $ getResponseCookie cn r 1165 where 1166 modify ck = addResponseCookie (f ck) r 1167 {-# INLINE modifyResponseCookie #-} 1168 1169 1170 ------------------------------------------------------------------------------ 1171 -- | A note here: if you want to set the @Content-Length@ for the response, 1172 -- Snap forces you to do it with this function rather than by setting it in 1173 -- the headers; the @Content-Length@ in the headers will be ignored. 1174 -- 1175 -- The reason for this is that Snap needs to look up the value of 1176 -- @Content-Length@ for each request, and looking the string value up in the 1177 -- headers and parsing the number out of the text will be too expensive. 1178 -- 1179 -- If you don't set a content length in your response, HTTP keep-alive will be 1180 -- disabled for HTTP\/1.0 clients, forcing a @Connection: close@. For 1181 -- HTTP\/1.1 clients, Snap will switch to the chunked transfer encoding if 1182 -- @Content-Length@ is not specified. 1183 -- 1184 -- Example: 1185 -- 1186 -- @ 1187 -- ghci> setContentLength 400 'emptyResponse' 1188 -- HTTP\/1.1 200 OK 1189 -- Content-Length: 400 1190 -- 1191 -- 1192 -- @ 1193 setContentLength :: Word64 -> Response -> Response 1194 setContentLength !l r = r { rspContentLength = Just l } 1195 {-# INLINE setContentLength #-} 1196 1197 1198 ------------------------------------------------------------------------------ 1199 -- | Removes any @Content-Length@ set in the 'Response'. 1200 -- 1201 -- Example: 1202 -- 1203 -- @ 1204 -- ghci> clearContentLength $ 'setContentLength' 400 'emptyResponse' 1205 -- HTTP\/1.1 200 OK 1206 -- 1207 -- 1208 -- @ 1209 clearContentLength :: Response -> Response 1210 clearContentLength r = r { rspContentLength = Nothing } 1211 {-# INLINE clearContentLength #-} 1212 1213 1214 ---------------- 1215 -- HTTP dates -- 1216 ---------------- 1217 1218 ------------------------------------------------------------------------------ 1219 -- | Convert a 'CTime' into an HTTP timestamp. 1220 -- 1221 -- Example: 1222 -- 1223 -- @ 1224 -- ghci> 'formatHttpTime' . 'fromIntegral' $ 10 1225 -- \"Thu, 01 Jan 1970 00:00:10 GMT\" 1226 -- @ 1227 formatHttpTime :: CTime -> IO ByteString 1228 1229 1230 ------------------------------------------------------------------------------ 1231 -- | Convert a 'CTime' into common log entry format. 1232 formatLogTime :: CTime -> IO ByteString 1233 1234 1235 ------------------------------------------------------------------------------ 1236 -- | Converts an HTTP timestamp into a 'CTime'. 1237 -- 1238 -- Example: 1239 -- 1240 -- @ 1241 -- ghci> :set -XOverloadedStrings 1242 -- ghci> 'parseHttpTime' \"Thu, 01 Jan 1970 00:00:10 GMT\" 1243 -- 10 1244 -- @ 1245 parseHttpTime :: ByteString -> IO CTime 1246 1247 #ifdef PORTABLE 1248 1249 ------------------------------------------------------------------------------ 1250 -- local definitions 1251 fromStr :: String -> ByteString 1252 fromStr = S.pack -- only because we know there's no unicode 1253 {-# INLINE fromStr #-} 1254 1255 1256 ------------------------------------------------------------------------------ 1257 formatHttpTime = return . format . toUTCTime 1258 where 1259 format :: UTCTime -> ByteString 1260 format = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT" 1261 1262 toUTCTime :: CTime -> UTCTime 1263 toUTCTime = posixSecondsToUTCTime . realToFrac 1264 1265 1266 ------------------------------------------------------------------------------ 1267 formatLogTime ctime = do 1268 t <- utcToLocalZonedTime $ toUTCTime ctime 1269 return $! format t 1270 1271 where 1272 format :: ZonedTime -> ByteString 1273 format = fromStr . formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" 1274 1275 toUTCTime :: CTime -> UTCTime 1276 toUTCTime = posixSecondsToUTCTime . realToFrac 1277 1278 1279 ------------------------------------------------------------------------------ 1280 parseHttpTime = return . toCTime . prs . S.unpack 1281 where 1282 prs :: String -> Maybe UTCTime 1283 prs = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" 1284 1285 toCTime :: Maybe UTCTime -> CTime 1286 toCTime (Just t) = fromInteger $ truncate $ utcTimeToPOSIXSeconds t 1287 toCTime Nothing = fromInteger 0 1288 1289 #else 1290 1291 ------------------------------------------------------------------------------ 1292 formatLogTime t = do 1293 ptr <- mallocBytes 40 1294 c_format_log_time t ptr 1295 S.unsafePackMallocCString ptr 1296 1297 1298 ------------------------------------------------------------------------------ 1299 formatHttpTime t = do 1300 ptr <- mallocBytes 40 1301 c_format_http_time t ptr 1302 S.unsafePackMallocCString ptr 1303 1304 1305 ------------------------------------------------------------------------------ 1306 parseHttpTime s = S.unsafeUseAsCString s $ \ptr -> 1307 c_parse_http_time ptr 1308 1309 #endif 1310 1311 1312 ------------------------------------------------------------------------------ 1313 statusReasonMap :: IM.IntMap ByteString 1314 statusReasonMap = IM.fromList [ 1315 (100, "Continue"), 1316 (101, "Switching Protocols"), 1317 (200, "OK"), 1318 (201, "Created"), 1319 (202, "Accepted"), 1320 (203, "Non-Authoritative Information"), 1321 (204, "No Content"), 1322 (205, "Reset Content"), 1323 (206, "Partial Content"), 1324 (300, "Multiple Choices"), 1325 (301, "Moved Permanently"), 1326 (302, "Found"), 1327 (303, "See Other"), 1328 (304, "Not Modified"), 1329 (305, "Use Proxy"), 1330 (307, "Temporary Redirect"), 1331 (400, "Bad Request"), 1332 (401, "Unauthorized"), 1333 (402, "Payment Required"), 1334 (403, "Forbidden"), 1335 (404, "Not Found"), 1336 (405, "Method Not Allowed"), 1337 (406, "Not Acceptable"), 1338 (407, "Proxy Authentication Required"), 1339 (408, "Request Time-out"), 1340 (409, "Conflict"), 1341 (410, "Gone"), 1342 (411, "Length Required"), 1343 (412, "Precondition Failed"), 1344 (413, "Request Entity Too Large"), 1345 (414, "Request-URI Too Large"), 1346 (415, "Unsupported Media Type"), 1347 (416, "Requested range not satisfiable"), 1348 (417, "Expectation Failed"), 1349 (500, "Internal Server Error"), 1350 (501, "Not Implemented"), 1351 (502, "Bad Gateway"), 1352 (503, "Service Unavailable"), 1353 (504, "Gateway Time-out"), 1354 (505, "HTTP Version not supported") 1355 ] 1356 1357 1358 ------------------------------------------------------------------------------ 1359 -- Deprecated functions 1360 1361 -- | See 'rqClientAddr'. 1362 rqRemoteAddr :: Request -> ByteString 1363 rqRemoteAddr = rqClientAddr 1364 {-# DEPRECATED rqRemoteAddr "(snap-core >= 1.0.0.0) please use 'rqClientAddr', this will be removed in 1.1.*" #-} 1365 1366 -- | See 'rqClientPort'. 1367 rqRemotePort :: Request -> Int 1368 rqRemotePort = rqClientPort 1369 {-# DEPRECATED rqRemotePort "(snap-core >= 1.0.0.0) please use 'rqClientPort', this will be removed in 1.1.*" #-}