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¶m=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 ]