1 {-# LANGUAGE DeriveDataTypeable #-} 2 {-# LANGUAGE EmptyDataDecls #-} 3 {-# LANGUAGE FlexibleInstances #-} 4 {-# LANGUAGE OverloadedStrings #-} 5 {-# LANGUAGE PackageImports #-} 6 {-# LANGUAGE RankNTypes #-} 7 8 module Snap.Internal.Types where 9 10 ------------------------------------------------------------------------------ 11 import "MonadCatchIO-transformers" Control.Monad.CatchIO 12 13 import Blaze.ByteString.Builder 14 import Blaze.ByteString.Builder.Char.Utf8 15 import Control.Applicative 16 import Control.Exception (throwIO, ErrorCall(..)) 17 import Control.Monad 18 import Control.Monad.State 19 import Data.ByteString.Char8 (ByteString) 20 import qualified Data.ByteString.Char8 as S 21 import qualified Data.ByteString.Lazy.Char8 as L 22 import Data.CaseInsensitive (CI) 23 import Data.Int 24 import Data.IORef 25 import Data.Maybe 26 import Data.Monoid 27 import qualified Data.Text as T 28 import qualified Data.Text.Lazy as LT 29 import Data.Typeable 30 import Prelude hiding (catch, take) 31 32 33 ------------------------------------------------------------------ 34 import Snap.Internal.Http.Types 35 import Snap.Internal.Iteratee.Debug 36 import Snap.Util.Readable 37 import Snap.Iteratee 38 39 40 ------------------------------------------------------------------------------ 41 -- The Snap Monad 42 ------------------------------------------------------------------------------ 43 44 {-| 45 46 'Snap' is the 'Monad' that user web handlers run in. 'Snap' gives you: 47 48 1. stateful access to fetch or modify an HTTP 'Request' 49 50 2. stateful access to fetch or modify an HTTP 'Response' 51 52 3. failure \/ 'Alternative' \/ 'MonadPlus' semantics: a 'Snap' handler can 53 choose not to handle a given request, using 'empty' or its synonym 'pass', 54 and you can try alternative handlers with the '<|>' operator: 55 56 > a :: Snap String 57 > a = pass 58 > 59 > b :: Snap String 60 > b = return "foo" 61 > 62 > c :: Snap String 63 > c = a <|> b -- try running a, if it fails then try b 64 65 4. convenience functions ('writeBS', 'writeLBS', 'writeText', 'writeLazyText', 66 'addToOutput') for writing output to the 'Response': 67 68 > a :: (forall a . Enumerator a) -> Snap () 69 > a someEnumerator = do 70 > writeBS "I'm a strict bytestring" 71 > writeLBS "I'm a lazy bytestring" 72 > addToOutput someEnumerator 73 74 5. early termination: if you call 'finishWith': 75 76 > a :: Snap () 77 > a = do 78 > modifyResponse $ setResponseStatus 500 "Internal Server Error" 79 > writeBS "500 error" 80 > r <- getResponse 81 > finishWith r 82 83 then any subsequent processing will be skipped and supplied 'Response' 84 value will be returned from 'runSnap' as-is. 85 86 6. access to the 'IO' monad through a 'MonadIO' instance: 87 88 > a :: Snap () 89 > a = liftIO fireTheMissiles 90 91 7. the ability to set a timeout which will kill the handler thread after @N@ 92 seconds of inactivity: 93 94 > a :: Snap () 95 > a = setTimeout 30 96 97 You may notice that most of the type signatures in this module contain a 98 @(MonadSnap m) => ...@ typeclass constraint. 'MonadSnap' is a typeclass which, 99 in essence, says \"you can get back to the 'Snap' monad from here\". Using 100 'MonadSnap' you can extend the 'Snap' monad with additional functionality and 101 still have access to most of the 'Snap' functions without writing 'lift' 102 everywhere. Instances are already provided for most of the common monad 103 transformers ('ReaderT', 'WriterT', 'StateT', etc.). 104 105 -} 106 107 ------------------------------------------------------------------------------ 108 -- | 'MonadSnap' is a type class, analogous to 'MonadIO' for 'IO', that makes 109 -- it easy to wrap 'Snap' inside monad transformers. 110 class (Monad m, MonadIO m, MonadCatchIO m, MonadPlus m, Functor m, 111 Applicative m, Alternative m) => MonadSnap m where 112 liftSnap :: Snap a -> m a 113 114 115 ------------------------------------------------------------------------------ 116 data SnapResult a = PassOnProcessing 117 | EarlyTermination Response 118 | SnapValue a 119 120 ------------------------------------------------------------------------------ 121 newtype Snap a = Snap { 122 unSnap :: StateT SnapState (Iteratee ByteString IO) (SnapResult a) 123 } 124 125 126 ------------------------------------------------------------------------------ 127 data SnapState = SnapState 128 { _snapRequest :: Request 129 , _snapResponse :: Response 130 , _snapLogError :: ByteString -> IO () 131 , _snapSetTimeout :: Int -> IO () } 132 133 134 ------------------------------------------------------------------------------ 135 instance Monad Snap where 136 (>>=) = snapBind 137 return = snapReturn 138 fail = snapFail 139 {- 140 (Snap m) >>= f = 141 Snap $ do 142 eth <- m 143 maybe (return Nothing) 144 (either (return . Just . Left) 145 (unSnap . f)) 146 eth 147 148 return = Snap . return . Just . Right 149 fail = const $ Snap $ return Nothing 150 -} 151 152 ------------------------------------------------------------------------------ 153 snapBind :: Snap a -> (a -> Snap b) -> Snap b 154 snapBind (Snap m) f = Snap $ do 155 res <- m 156 157 case res of 158 SnapValue a -> unSnap $ f a 159 PassOnProcessing -> return PassOnProcessing 160 EarlyTermination r -> return $! EarlyTermination r 161 {-# INLINE snapBind #-} 162 163 164 snapReturn :: a -> Snap a 165 snapReturn = Snap . return . SnapValue 166 {-# INLINE snapReturn #-} 167 168 169 snapFail :: String -> Snap a 170 snapFail _ = Snap $ return PassOnProcessing 171 {-# INLINE snapFail #-} 172 173 174 ------------------------------------------------------------------------------ 175 instance MonadIO Snap where 176 liftIO m = Snap $ liftM SnapValue $ liftIO m 177 178 179 ------------------------------------------------------------------------------ 180 instance MonadCatchIO Snap where 181 catch (Snap m) handler = Snap $ do 182 x <- try m 183 case x of 184 (Left e) -> let (Snap z) = handler e in z 185 (Right y) -> return y 186 187 block (Snap m) = Snap $ block m 188 unblock (Snap m) = Snap $ unblock m 189 190 191 ------------------------------------------------------------------------------ 192 instance MonadPlus Snap where 193 mzero = Snap $ return PassOnProcessing 194 195 a `mplus` b = 196 Snap $ do 197 r <- unSnap a 198 case r of 199 PassOnProcessing -> unSnap b 200 _ -> return r 201 202 203 ------------------------------------------------------------------------------ 204 instance Functor Snap where 205 fmap = liftM 206 207 208 ------------------------------------------------------------------------------ 209 instance Applicative Snap where 210 pure = return 211 (<*>) = ap 212 213 214 ------------------------------------------------------------------------------ 215 instance Alternative Snap where 216 empty = mzero 217 (<|>) = mplus 218 219 220 ------------------------------------------------------------------------------ 221 instance MonadSnap Snap where 222 liftSnap = id 223 224 225 226 ------------------------------------------------------------------------------ 227 -- | The Typeable instance is here so Snap can be dynamically executed with 228 -- Hint. 229 snapTyCon :: TyCon 230 snapTyCon = mkTyCon "Snap.Types.Snap" 231 {-# NOINLINE snapTyCon #-} 232 233 instance Typeable1 Snap where 234 typeOf1 _ = mkTyConApp snapTyCon [] 235 236 237 ------------------------------------------------------------------------------ 238 liftIter :: MonadSnap m => Iteratee ByteString IO a -> m a 239 liftIter i = liftSnap $ Snap (lift i >>= return . SnapValue) 240 241 242 ------------------------------------------------------------------------------ 243 -- | Sends the request body through an iteratee (data consumer) and 244 -- returns the result. 245 runRequestBody :: MonadSnap m => Iteratee ByteString IO a -> m a 246 runRequestBody iter = do 247 req <- getRequest 248 senum <- liftIO $ readIORef $ rqBody req 249 let (SomeEnumerator enum) = senum 250 251 -- make sure the iteratee consumes all of the output 252 let iter' = iter >>= \a -> skipToEof >> return a 253 254 -- run the iteratee 255 step <- liftIO $ runIteratee iter' 256 result <- liftIter $ enum step 257 258 -- stuff a new dummy enumerator into the request, so you can only try to 259 -- read the request body from the socket once 260 liftIO $ writeIORef (rqBody req) 261 (SomeEnumerator $ joinI . take 0 ) 262 263 return result 264 265 266 ------------------------------------------------------------------------------ 267 -- | Returns the request body as a bytestring. 268 getRequestBody :: MonadSnap m => m L.ByteString 269 getRequestBody = liftM L.fromChunks $ runRequestBody consume 270 {-# INLINE getRequestBody #-} 271 272 273 ------------------------------------------------------------------------------ 274 -- | Normally Snap is careful to ensure that the request body is fully 275 -- consumed after your web handler runs, but before the 'Response' enumerator 276 -- is streamed out the socket. If you want to transform the request body into 277 -- some output in O(1) space, you should use this function. 278 -- 279 -- Note that upon calling this function, response processing finishes early as 280 -- if you called 'finishWith'. Make sure you set any content types, headers, 281 -- cookies, etc. before you call this function. 282 -- 283 transformRequestBody :: (forall a . Enumerator Builder IO a) 284 -- ^ the output 'Iteratee' is passed to this 285 -- 'Enumerator', and then the resulting 'Iteratee' is 286 -- fed the request body stream. Your 'Enumerator' is 287 -- responsible for transforming the input. 288 -> Snap () 289 transformRequestBody trans = do 290 req <- getRequest 291 let ioref = rqBody req 292 senum <- liftIO $ readIORef ioref 293 let (SomeEnumerator enum') = senum 294 let enum = mapEnum toByteString fromByteString enum' 295 liftIO $ writeIORef ioref (SomeEnumerator enumEOF) 296 297 origRsp <- getResponse 298 let rsp = setResponseBody 299 (\writeEnd -> do 300 let i = iterateeDebugWrapperWith showBuilder 301 "transformRequestBody" 302 $ trans writeEnd 303 st <- liftIO $ runIteratee i 304 305 enum st) 306 $ origRsp { rspTransformingRqBody = True } 307 finishWith rsp 308 309 310 ------------------------------------------------------------------------------ 311 -- | Short-circuits a 'Snap' monad action early, storing the given 312 -- 'Response' value in its state. 313 finishWith :: MonadSnap m => Response -> m a 314 finishWith = liftSnap . Snap . return . EarlyTermination 315 {-# INLINE finishWith #-} 316 317 318 ------------------------------------------------------------------------------ 319 -- | Capture the flow of control in case a handler calls 'finishWith'. 320 -- 321 -- /WARNING/: in the event of a call to 'transformRequestBody' it is possible 322 -- to violate HTTP protocol safety when using this function. If you call 323 -- 'catchFinishWith' it is suggested that you do not modify the body of the 324 -- 'Response' which was passed to the 'finishWith' call. 325 catchFinishWith :: Snap a -> Snap (Either Response a) 326 catchFinishWith (Snap m) = Snap $ do 327 r <- m 328 case r of 329 PassOnProcessing -> return PassOnProcessing 330 EarlyTermination resp -> return $! SnapValue $! Left resp 331 SnapValue a -> return $! SnapValue $! Right a 332 {-# INLINE catchFinishWith #-} 333 334 335 ------------------------------------------------------------------------------ 336 -- | Fails out of a 'Snap' monad action. This is used to indicate 337 -- that you choose not to handle the given request within the given 338 -- handler. 339 pass :: MonadSnap m => m a 340 pass = empty 341 342 343 ------------------------------------------------------------------------------ 344 -- | Runs a 'Snap' monad action only if the request's HTTP method matches 345 -- the given method. 346 method :: MonadSnap m => Method -> m a -> m a 347 method m action = do 348 req <- getRequest 349 unless (rqMethod req == m) pass 350 action 351 {-# INLINE method #-} 352 353 354 ------------------------------------------------------------------------------ 355 -- | Runs a 'Snap' monad action only if the request's HTTP method matches 356 -- one of the given methods. 357 methods :: MonadSnap m => [Method] -> m a -> m a 358 methods ms action = do 359 req <- getRequest 360 unless (rqMethod req `elem` ms) pass 361 action 362 {-# INLINE methods #-} 363 364 365 ------------------------------------------------------------------------------ 366 -- Appends n bytes of the path info to the context path with a 367 -- trailing slash. 368 updateContextPath :: Int -> Request -> Request 369 updateContextPath n req | n > 0 = req { rqContextPath = ctx 370 , rqPathInfo = pinfo } 371 | otherwise = req 372 where 373 ctx' = S.take n (rqPathInfo req) 374 ctx = S.concat [rqContextPath req, ctx', "/"] 375 pinfo = S.drop (n+1) (rqPathInfo req) 376 377 378 ------------------------------------------------------------------------------ 379 -- Runs a 'Snap' monad action only if the 'rqPathInfo' matches the given 380 -- predicate. 381 pathWith :: MonadSnap m 382 => (ByteString -> ByteString -> Bool) 383 -> ByteString 384 -> m a 385 -> m a 386 pathWith c p action = do 387 req <- getRequest 388 unless (c p (rqPathInfo req)) pass 389 localRequest (updateContextPath $ S.length p) action 390 391 392 ------------------------------------------------------------------------------ 393 -- | Runs a 'Snap' monad action only when the 'rqPathInfo' of the request 394 -- starts with the given path. For example, 395 -- 396 -- > dir "foo" handler 397 -- 398 -- Will fail if 'rqPathInfo' is not \"@\/foo@\" or \"@\/foo\/...@\", and will 399 -- add @\"foo\/\"@ to the handler's local 'rqContextPath'. 400 dir :: MonadSnap m 401 => ByteString -- ^ path component to match 402 -> m a -- ^ handler to run 403 -> m a 404 dir = pathWith f 405 where 406 f dr pinfo = dr == x 407 where 408 (x,_) = S.break (=='/') pinfo 409 {-# INLINE dir #-} 410 411 412 ------------------------------------------------------------------------------ 413 -- | Runs a 'Snap' monad action only for requests where 'rqPathInfo' is 414 -- exactly equal to the given string. If the path matches, locally sets 415 -- 'rqContextPath' to the old value of 'rqPathInfo', sets 'rqPathInfo'=\"\", 416 -- and runs the given handler. 417 path :: MonadSnap m 418 => ByteString -- ^ path to match against 419 -> m a -- ^ handler to run 420 -> m a 421 path = pathWith (==) 422 {-# INLINE path #-} 423 424 425 ------------------------------------------------------------------------------ 426 -- | Runs a 'Snap' monad action only when the first path component is 427 -- successfully parsed as the argument to the supplied handler function. 428 pathArg :: (Readable a, MonadSnap m) 429 => (a -> m b) 430 -> m b 431 pathArg f = do 432 req <- getRequest 433 let (p,_) = S.break (=='/') (rqPathInfo req) 434 a <- fromBS p 435 localRequest (updateContextPath $ S.length p) (f a) 436 437 438 ------------------------------------------------------------------------------ 439 -- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty. 440 ifTop :: MonadSnap m => m a -> m a 441 ifTop = path "" 442 {-# INLINE ifTop #-} 443 444 445 ------------------------------------------------------------------------------ 446 -- | Local Snap version of 'get'. 447 sget :: Snap SnapState 448 sget = Snap $ liftM SnapValue get 449 {-# INLINE sget #-} 450 451 452 ------------------------------------------------------------------------------ 453 -- | Local Snap monad version of 'modify'. 454 smodify :: (SnapState -> SnapState) -> Snap () 455 smodify f = Snap $ modify f >> return (SnapValue ()) 456 {-# INLINE smodify #-} 457 458 459 ------------------------------------------------------------------------------ 460 -- | Grabs the 'Request' object out of the 'Snap' monad. 461 getRequest :: MonadSnap m => m Request 462 getRequest = liftSnap $ liftM _snapRequest sget 463 {-# INLINE getRequest #-} 464 465 466 ------------------------------------------------------------------------------ 467 -- | Grabs the 'Response' object out of the 'Snap' monad. 468 getResponse :: MonadSnap m => m Response 469 getResponse = liftSnap $ liftM _snapResponse sget 470 {-# INLINE getResponse #-} 471 472 473 ------------------------------------------------------------------------------ 474 -- | Puts a new 'Response' object into the 'Snap' monad. 475 putResponse :: MonadSnap m => Response -> m () 476 putResponse r = liftSnap $ smodify $ \ss -> ss { _snapResponse = r } 477 {-# INLINE putResponse #-} 478 479 480 ------------------------------------------------------------------------------ 481 -- | Puts a new 'Request' object into the 'Snap' monad. 482 putRequest :: MonadSnap m => Request -> m () 483 putRequest r = liftSnap $ smodify $ \ss -> ss { _snapRequest = r } 484 {-# INLINE putRequest #-} 485 486 487 ------------------------------------------------------------------------------ 488 -- | Modifies the 'Request' object stored in a 'Snap' monad. 489 modifyRequest :: MonadSnap m => (Request -> Request) -> m () 490 modifyRequest f = liftSnap $ 491 smodify $ \ss -> ss { _snapRequest = f $ _snapRequest ss } 492 {-# INLINE modifyRequest #-} 493 494 495 ------------------------------------------------------------------------------ 496 -- | Modifes the 'Response' object stored in a 'Snap' monad. 497 modifyResponse :: MonadSnap m => (Response -> Response) -> m () 498 modifyResponse f = liftSnap $ 499 smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss } 500 {-# INLINE modifyResponse #-} 501 502 503 ------------------------------------------------------------------------------ 504 -- | Performs a redirect by setting the @Location@ header to the given target 505 -- URL/path and the status code to 302 in the 'Response' object stored in a 506 -- 'Snap' monad. Note that the target URL is not validated in any way. 507 -- Consider using 'redirect\'' instead, which allows you to choose the correct 508 -- status code. 509 redirect :: MonadSnap m => ByteString -> m a 510 redirect target = redirect' target 302 511 {-# INLINE redirect #-} 512 513 514 ------------------------------------------------------------------------------ 515 -- | Performs a redirect by setting the @Location@ header to the given target 516 -- URL/path and the status code (should be one of 301, 302, 303 or 307) in the 517 -- 'Response' object stored in a 'Snap' monad. Note that the target URL is not 518 -- validated in any way. 519 redirect' :: MonadSnap m => ByteString -> Int -> m a 520 redirect' target status = do 521 r <- getResponse 522 523 finishWith 524 $ setResponseCode status 525 $ setContentLength 0 526 $ modifyResponseBody (const $ enumBuilder mempty) 527 $ setHeader "Location" target r 528 529 {-# INLINE redirect' #-} 530 531 532 ------------------------------------------------------------------------------ 533 -- | Log an error message in the 'Snap' monad 534 logError :: MonadSnap m => ByteString -> m () 535 logError s = liftSnap $ Snap $ gets _snapLogError >>= (\l -> liftIO $ l s) 536 >> return (SnapValue ()) 537 {-# INLINE logError #-} 538 539 540 ------------------------------------------------------------------------------ 541 -- | Adds the output from the given enumerator to the 'Response' 542 -- stored in the 'Snap' monad state. 543 addToOutput :: MonadSnap m 544 => (forall a . Enumerator Builder IO a) -- ^ output to add 545 -> m () 546 addToOutput enum = modifyResponse $ modifyResponseBody (>==> enum) 547 548 549 ------------------------------------------------------------------------------ 550 -- | Adds the given 'Builder' to the body of the 'Response' stored in the 551 -- | 'Snap' monad state. 552 writeBuilder :: MonadSnap m => Builder -> m () 553 writeBuilder b = addToOutput $ enumBuilder b 554 {-# INLINE writeBuilder #-} 555 556 557 ------------------------------------------------------------------------------ 558 -- | Adds the given strict 'ByteString' to the body of the 'Response' stored 559 -- in the 'Snap' monad state. 560 -- 561 -- Warning: This function is intentionally non-strict. If any pure 562 -- exceptions are raised by the expression creating the 'ByteString', 563 -- the exception won't actually be raised within the Snap handler. 564 writeBS :: MonadSnap m => ByteString -> m () 565 writeBS s = writeBuilder $ fromByteString s 566 567 568 ------------------------------------------------------------------------------ 569 -- | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored 570 -- in the 'Snap' monad state. 571 -- 572 -- Warning: This function is intentionally non-strict. If any pure 573 -- exceptions are raised by the expression creating the 'ByteString', 574 -- the exception won't actually be raised within the Snap handler. 575 writeLBS :: MonadSnap m => L.ByteString -> m () 576 writeLBS s = writeBuilder $ fromLazyByteString s 577 578 579 ------------------------------------------------------------------------------ 580 -- | Adds the given strict 'T.Text' to the body of the 'Response' stored in 581 -- the 'Snap' monad state. 582 -- 583 -- Warning: This function is intentionally non-strict. If any pure 584 -- exceptions are raised by the expression creating the 'ByteString', 585 -- the exception won't actually be raised within the Snap handler. 586 writeText :: MonadSnap m => T.Text -> m () 587 writeText s = writeBuilder $ fromText s 588 589 590 ------------------------------------------------------------------------------ 591 -- | Adds the given lazy 'LT.Text' to the body of the 'Response' stored in the 592 -- 'Snap' monad state. 593 -- 594 -- Warning: This function is intentionally non-strict. If any pure 595 -- exceptions are raised by the expression creating the 'ByteString', 596 -- the exception won't actually be raised within the Snap handler. 597 writeLazyText :: MonadSnap m => LT.Text -> m () 598 writeLazyText s = writeBuilder $ fromLazyText s 599 600 601 ------------------------------------------------------------------------------ 602 -- | Sets the output to be the contents of the specified file. 603 -- 604 -- Calling 'sendFile' will overwrite any output queued to be sent in the 605 -- 'Response'. If the response body is not modified after the call to 606 -- 'sendFile', Snap will use the efficient @sendfile()@ system call on 607 -- platforms that support it. 608 -- 609 -- If the response body is modified (using 'modifyResponseBody'), the file 610 -- will be read using @mmap()@. 611 sendFile :: (MonadSnap m) => FilePath -> m () 612 sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f Nothing } 613 614 615 ------------------------------------------------------------------------------ 616 -- | Sets the output to be the contents of the specified file, within the 617 -- given (start,end) range. 618 -- 619 -- Calling 'sendFilePartial' will overwrite any output queued to be sent in 620 -- the 'Response'. If the response body is not modified after the call to 621 -- 'sendFilePartial', Snap will use the efficient @sendfile()@ system call on 622 -- platforms that support it. 623 -- 624 -- If the response body is modified (using 'modifyResponseBody'), the file 625 -- will be read using @mmap()@. 626 sendFilePartial :: (MonadSnap m) => FilePath -> (Int64,Int64) -> m () 627 sendFilePartial f rng = modifyResponse $ \r -> 628 r { rspBody = SendFile f (Just rng) } 629 630 631 ------------------------------------------------------------------------------ 632 -- | Runs a 'Snap' action with a locally-modified 'Request' state 633 -- object. The 'Request' object in the Snap monad state after the call 634 -- to localRequest will be unchanged. 635 localRequest :: MonadSnap m => (Request -> Request) -> m a -> m a 636 localRequest f m = do 637 req <- getRequest 638 639 runAct req <|> (putRequest req >> pass) 640 641 where 642 runAct req = do 643 modifyRequest f 644 result <- m 645 putRequest req 646 return result 647 {-# INLINE localRequest #-} 648 649 650 ------------------------------------------------------------------------------ 651 -- | Fetches the 'Request' from state and hands it to the given action. 652 withRequest :: MonadSnap m => (Request -> m a) -> m a 653 withRequest = (getRequest >>=) 654 {-# INLINE withRequest #-} 655 656 657 ------------------------------------------------------------------------------ 658 -- | Fetches the 'Response' from state and hands it to the given action. 659 withResponse :: MonadSnap m => (Response -> m a) -> m a 660 withResponse = (getResponse >>=) 661 {-# INLINE withResponse #-} 662 663 664 ------------------------------------------------------------------------------ 665 -- | Modifies the 'Request' in the state to set the 'rqRemoteAddr' 666 -- field to the value in the X-Forwarded-For header. If the header is 667 -- not present, this action has no effect. 668 -- 669 -- This action should be used only when working behind a reverse http 670 -- proxy that sets the X-Forwarded-For header. This is the only way to 671 -- ensure the value in the X-Forwarded-For header can be trusted. 672 -- 673 -- This is provided as a filter so actions that require the remote 674 -- address can get it in a uniform manner. It has specifically limited 675 -- functionality to ensure that its transformation can be trusted, 676 -- when used correctly. 677 ipHeaderFilter :: MonadSnap m => m () 678 ipHeaderFilter = ipHeaderFilter' "x-forwarded-for" 679 680 681 ------------------------------------------------------------------------------ 682 -- | Modifies the 'Request' in the state to set the 'rqRemoteAddr' 683 -- field to the value from the header specified. If the header 684 -- specified is not present, this action has no effect. 685 -- 686 -- This action should be used only when working behind a reverse http 687 -- proxy that sets the header being looked at. This is the only way to 688 -- ensure the value in the header can be trusted. 689 -- 690 -- This is provided as a filter so actions that require the remote 691 -- address can get it in a uniform manner. It has specifically limited 692 -- functionality to ensure that its transformation can be trusted, 693 -- when used correctly. 694 ipHeaderFilter' :: MonadSnap m => CI ByteString -> m () 695 ipHeaderFilter' header = do 696 headerContents <- getHeader header <$> getRequest 697 698 let whitespace = " \t\r\n" 699 ipChrs = ".0123456789" 700 trim f s = f (`elem` s) 701 702 clean = trim S.takeWhile ipChrs . trim S.dropWhile whitespace 703 setIP ip = modifyRequest $ \rq -> rq { rqRemoteAddr = clean ip } 704 maybe (return ()) setIP headerContents 705 706 707 ------------------------------------------------------------------------------ 708 -- | This function brackets a Snap action in resource acquisition and 709 -- release. This is provided because MonadCatchIO's 'bracket' function 710 -- doesn't work properly in the case of a short-circuit return from 711 -- the action being bracketed. 712 -- 713 -- In order to prevent confusion regarding the effects of the 714 -- aquisition and release actions on the Snap state, this function 715 -- doesn't accept Snap actions for the acquire or release actions. 716 -- 717 -- This function will run the release action in all cases where the 718 -- acquire action succeeded. This includes the following behaviors 719 -- from the bracketed Snap action. 720 -- 721 -- 1. Normal completion 722 -- 723 -- 2. Short-circuit completion, either from calling 'fail' or 'finishWith' 724 -- 725 -- 3. An exception being thrown. 726 bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c 727 bracketSnap before after thing = block . Snap $ do 728 a <- liftIO before 729 let after' = liftIO $ after a 730 (Snap thing') = thing a 731 r <- unblock thing' `onException` after' 732 _ <- after' 733 return r 734 735 736 ------------------------------------------------------------------------------ 737 -- | This exception is thrown if the handler you supply to 'runSnap' fails. 738 data NoHandlerException = NoHandlerException 739 deriving (Eq, Typeable) 740 741 742 ------------------------------------------------------------------------------ 743 instance Show NoHandlerException where 744 show NoHandlerException = "No handler for request" 745 746 747 ------------------------------------------------------------------------------ 748 instance Exception NoHandlerException 749 750 751 ------------------------------------------------------------------------------ 752 -- | Runs a 'Snap' monad action in the 'Iteratee IO' monad. 753 runSnap :: Snap a 754 -> (ByteString -> IO ()) 755 -> (Int -> IO ()) 756 -> Request 757 -> Iteratee ByteString IO (Request,Response) 758 runSnap (Snap m) logerr timeoutAction req = do 759 (r, ss') <- runStateT m ss 760 761 let resp = case r of 762 PassOnProcessing -> fourohfour 763 EarlyTermination x -> x 764 SnapValue _ -> _snapResponse ss' 765 766 return (_snapRequest ss', resp) 767 768 where 769 fourohfour = 770 setContentLength 3 $ 771 setResponseStatus 404 "Not Found" $ 772 modifyResponseBody (>==> enumBuilder (fromByteString "404")) $ 773 emptyResponse 774 775 dresp = emptyResponse { rspHttpVersion = rqVersion req } 776 777 ss = SnapState req dresp logerr timeoutAction 778 {-# INLINE runSnap #-} 779 780 781 ------------------------------------------------------------------------------ 782 evalSnap :: Snap a 783 -> (ByteString -> IO ()) 784 -> (Int -> IO ()) 785 -> Request 786 -> Iteratee ByteString IO a 787 evalSnap (Snap m) logerr timeoutAction req = do 788 (r, _) <- runStateT m ss 789 790 case r of 791 PassOnProcessing -> liftIO $ throwIO NoHandlerException 792 EarlyTermination _ -> liftIO $ throwIO $ ErrorCall "no value" 793 SnapValue x -> return x 794 795 where 796 dresp = emptyResponse { rspHttpVersion = rqVersion req } 797 ss = SnapState req dresp logerr timeoutAction 798 {-# INLINE evalSnap #-} 799 800 801 802 ------------------------------------------------------------------------------ 803 -- | See 'rqParam'. Looks up a value for the given named parameter in the 804 -- 'Request'. If more than one value was entered for the given parameter name, 805 -- 'getParam' gloms the values together with: 806 -- 807 -- @ 'S.intercalate' \" \"@ 808 -- 809 getParam :: MonadSnap m 810 => ByteString -- ^ parameter name to look up 811 -> m (Maybe ByteString) 812 getParam k = do 813 rq <- getRequest 814 return $ liftM (S.intercalate " ") $ rqParam k rq 815 816 817 ------------------------------------------------------------------------------ 818 -- | See 'rqParams'. Convenience function to return 'Params' from the 819 -- 'Request' inside of a 'MonadSnap' instance. 820 getParams :: MonadSnap m => m Params 821 getParams = getRequest >>= return . rqParams 822 823 824 ------------------------------------------------------------------------------ 825 -- | Gets the HTTP 'Cookie' with the specified name. 826 getCookie :: MonadSnap m 827 => ByteString 828 -> m (Maybe Cookie) 829 getCookie name = withRequest $ 830 return . listToMaybe . filter (\c -> cookieName c == name) . rqCookies 831 832 833 ------------------------------------------------------------------------------ 834 -- | Gets the HTTP 'Cookie' with the specified name and decodes it. If the 835 -- decoding fails, the handler calls pass. 836 readCookie :: (MonadSnap m, Readable a) 837 => ByteString 838 -> m a 839 readCookie name = maybe pass (fromBS . cookieValue) =<< getCookie name 840 841 842 ------------------------------------------------------------------------------ 843 -- | Causes the handler thread to be killed @n@ seconds from now. 844 setTimeout :: MonadSnap m 845 => Int -> m () 846 setTimeout n = do 847 t <- getTimeoutAction 848 liftIO $ t n 849 850 851 ------------------------------------------------------------------------------ 852 -- | Returns an 'IO' action which you can use to reset the handling thread's 853 -- timeout value. 854 getTimeoutAction :: MonadSnap m => m (Int -> IO ()) 855 getTimeoutAction = liftSnap $ liftM _snapSetTimeout sget