1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE CPP #-} 3 {-# LANGUAGE DeriveDataTypeable #-} 4 {-# LANGUAGE ExistentialQuantification #-} 5 {-# LANGUAGE FlexibleContexts #-} 6 {-# LANGUAGE FlexibleInstances #-} 7 {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 {-# LANGUAGE MultiParamTypeClasses #-} 9 {-# LANGUAGE OverloadedStrings #-} 10 {-# LANGUAGE Rank2Types #-} 11 {-# LANGUAGE ScopedTypeVariables #-} 12 {-# LANGUAGE TypeFamilies #-} 13 {-# LANGUAGE TypeSynonymInstances #-} 14 #if __GLASGOW_HASKELL__ >= 708 15 {-# LANGUAGE StandaloneDeriving #-} 16 #endif 17 18 module Snap.Internal.Core 19 ( MonadSnap(..) 20 , SnapResult(..) 21 , EscapeHttpHandler 22 , EscapeSnap(..) 23 , Zero(..) 24 , Snap(..) 25 , SnapState(..) 26 , runRequestBody 27 , readRequestBody 28 , transformRequestBody 29 , finishWith 30 , catchFinishWith 31 , pass 32 , method 33 , methods 34 , updateContextPath 35 , pathWith 36 , dir 37 , path 38 , pathArg 39 , ifTop 40 , sget 41 , smodify 42 , getRequest 43 , getResponse 44 , getsRequest 45 , getsResponse 46 , putRequest 47 , putResponse 48 , modifyRequest 49 , modifyResponse 50 , redirect 51 , redirect' 52 , logError 53 , addToOutput 54 , writeBuilder 55 , writeBS 56 , writeLBS 57 , writeText 58 , writeLazyText 59 , sendFile 60 , sendFilePartial 61 , localRequest 62 , withRequest 63 , withResponse 64 , ipHeaderFilter 65 , ipHeaderFilter' 66 , bracketSnap 67 , NoHandlerException(..) 68 , terminateConnection 69 , escapeHttp 70 , runSnap 71 , fixupResponse 72 , evalSnap 73 , getParamFrom 74 , getParam 75 , getPostParam 76 , getQueryParam 77 , getParams 78 , getPostParams 79 , getQueryParams 80 , getCookie 81 , readCookie 82 , expireCookie 83 , setTimeout 84 , extendTimeout 85 , modifyTimeout 86 , getTimeoutModifier 87 , module Snap.Internal.Http.Types 88 ) where 89 90 ------------------------------------------------------------------------------ 91 import Control.Applicative (Alternative ((<|>), empty), Applicative ((<*>), pure), (<$>)) 92 import Control.Exception.Lifted (ErrorCall (..), Exception, Handler (..), SomeException (..), catch, catches, mask, onException, throwIO) 93 import Control.Monad (Functor (..), Monad (..), MonadPlus (..), ap, liftM, unless, (=<<)) 94 import Control.Monad.Base (MonadBase (..)) 95 import Control.Monad.IO.Class (MonadIO (..)) 96 import Control.Monad.Trans.Control (MonadBaseControl (..)) 97 import Control.Monad.Trans.State (StateT (..)) 98 import Data.ByteString.Builder (Builder, byteString, lazyByteString) 99 import Data.ByteString.Char8 (ByteString) 100 import qualified Data.ByteString.Char8 as S (break, concat, drop, dropWhile, intercalate, length, take, takeWhile) 101 import qualified Data.ByteString.Internal as S (create) 102 import qualified Data.ByteString.Lazy.Char8 as L (ByteString, fromChunks) 103 import Data.CaseInsensitive (CI) 104 import Data.Maybe (Maybe (..), listToMaybe, maybe) 105 import qualified Data.Text as T (Text) 106 import qualified Data.Text.Encoding as T (encodeUtf8) 107 import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8) 108 import qualified Data.Text.Lazy as LT (Text) 109 import Data.Time (Day (ModifiedJulianDay), UTCTime (UTCTime)) 110 #if __GLASGOW_HASKELL__ < 708 111 import Data.Typeable (TyCon, Typeable, Typeable1 (..), mkTyCon3, mkTyConApp) 112 #else 113 import Data.Typeable (Typeable) 114 #endif 115 import Data.Word (Word64, Word8) 116 import Foreign.Ptr (Ptr, plusPtr) 117 import Foreign.Storable (poke) 118 import Prelude (Bool (..), Either (..), Eq (..), FilePath, IO, Int, Num (..), Ord (..), Show (..), String, const, divMod, elem, filter, fromIntegral, id, map, max, otherwise, quot, ($), ($!), (++), (.), (||)) 119 import System.IO.Streams (InputStream, OutputStream) 120 import qualified System.IO.Streams as Streams 121 import System.Posix.Types (FileOffset) 122 import System.PosixCompat.Files (fileSize, getFileStatus) 123 #if !MIN_VERSION_bytestring(0,10,6) 124 import qualified Data.ByteString.Internal as S (inlinePerformIO) 125 #else 126 import qualified Data.ByteString.Internal as S (accursedUnutterablePerformIO) 127 #endif 128 ------------------------------------------------------------------------------ 129 import qualified Data.Readable as R 130 import Snap.Internal.Http.Types (Cookie (..), HasHeaders (..), HttpVersion, Method (..), Params, Request (..), Response (..), ResponseBody (..), StreamProc, addHeader, addResponseCookie, clearContentLength, deleteHeader, deleteResponseCookie, emptyResponse, formatHttpTime, formatLogTime, getHeader, getResponseCookie, getResponseCookies, listHeaders, modifyResponseBody, modifyResponseCookie, normalizeMethod, parseHttpTime, rqModifyParams, rqParam, rqPostParam, rqQueryParam, rqSetParam, rspBodyMap, rspBodyToEnum, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, setResponseStatus, statusReasonMap) 131 import Snap.Internal.Parsing (urlDecode) 132 import qualified Snap.Types.Headers as H 133 ------------------------------------------------------------------------------ 134 135 136 ------------------------------------------------------------------------------ 137 -- | 'MonadSnap' is a type class, analogous to 'MonadIO' for 'IO', that makes it 138 -- easy to wrap 'Snap' inside monad transformers. 139 class (Monad m, MonadIO m, MonadBaseControl IO m, MonadPlus m, Functor m, 140 Applicative m, Alternative m) => MonadSnap m where 141 -- | Lift a computation from the 'Snap' monad. 142 liftSnap :: Snap a -> m a 143 144 145 ------------------------------------------------------------------------------ 146 data SnapResult a = SnapValue a 147 | Zero Zero 148 149 150 ------------------------------------------------------------------------------ 151 -- | Type of external handler passed to 'escapeHttp'. 152 type EscapeHttpHandler = ((Int -> Int) -> IO ()) -- ^ timeout modifier 153 -> InputStream ByteString -- ^ socket read end 154 -> OutputStream Builder -- ^ socket write end 155 -> IO () 156 157 158 ------------------------------------------------------------------------------ 159 -- | Used internally to implement 'escapeHttp'. 160 data EscapeSnap = TerminateConnection SomeException 161 | EscapeHttp EscapeHttpHandler 162 deriving (Typeable) 163 164 instance Exception EscapeSnap 165 166 instance Show EscapeSnap where 167 show (TerminateConnection e) = "<terminated: " ++ show e ++ ">" 168 show (EscapeHttp _) = "<escape http>" 169 170 171 ------------------------------------------------------------------------------ 172 data Zero = PassOnProcessing 173 | EarlyTermination Response 174 | EscapeSnap EscapeSnap 175 176 -------------------- 177 -- The Snap Monad -- 178 -------------------- 179 {-| 180 'Snap' is the 'Monad' that user web handlers run in. 'Snap' gives you: 181 182 1. Stateful access to fetch or modify an HTTP 'Request'. 183 184 @ 185 printRqContextPath :: Snap () 186 printRqContextPath = 'writeBS' . 'rqContextPath' =<< 'getRequest' 187 @ 188 189 2. Stateful access to fetch or modify an HTTP 'Response'. 190 191 @ 192 printRspStatusReason :: Snap () 193 printRspStatusReason = 'writeBS' . 'rspStatusReason' =<< 'getResponse' 194 @ 195 196 3. Failure \/ 'Alternative' \/ 'MonadPlus' semantics: a 'Snap' handler can 197 choose not to handle a given request, using 'empty' or its synonym 'pass', and 198 you can try alternative handlers with the '<|>' operator: 199 200 @ 201 a :: Snap String 202 a = 'pass' 203 204 b :: Snap String 205 b = return \"foo\" 206 207 c :: Snap String 208 c = a '<|>' b -- try running a, if it fails then try b 209 @ 210 211 4. Convenience functions ('writeBS', 'writeLBS', 'writeText', 'writeLazyText', 212 'addToOutput') for queueing output to be written to the 'Response', or for 213 streaming to the response using 214 <http://hackage.haskell.org/package/io-streams io-streams>: 215 216 @ 217 example :: ('OutputStream' 'Builder' -> IO ('OutputStream' 'Builder')) -> Snap () 218 example streamProc = do 219 'writeBS' \"I\'m a strict bytestring\" 220 'writeLBS' \"I\'m a lazy bytestring\" 221 'writeText' \"I\'m strict text\" 222 'addToOutput' streamProc 223 @ 224 225 5. Early termination: if you call 'finishWith': 226 227 @ 228 a :: Snap () 229 a = do 230 'modifyResponse' $ 'setResponseStatus' 500 \"Internal Server Error\" 231 'writeBS' \"500 error\" 232 r <- 'getResponse' 233 'finishWith' r 234 @ 235 236 then any subsequent processing will be skipped and the supplied 'Response' 237 value will be returned from 'runSnap' as-is. 238 239 6. Access to the 'IO' monad through a 'MonadIO' instance: 240 241 @ 242 a :: Snap () 243 a = 'liftIO' fireTheMissiles 244 @ 245 246 7. The ability to set or extend a timeout which will kill the handler thread 247 after @N@ seconds of inactivity (the default is 20 seconds): 248 249 @ 250 a :: Snap () 251 a = 'setTimeout' 30 252 @ 253 254 8. Throw and catch exceptions using a 'MonadBaseControl' instance: 255 256 @ 257 import "Control.Exception.Lifted" ('SomeException', 'throwIO', 'catch') 258 259 foo :: Snap () 260 foo = bar \`catch\` \(e::'SomeException') -> baz 261 where 262 bar = 'throwIO' FooException 263 @ 264 265 9. Log a message to the error log: 266 267 @ 268 foo :: Snap () 269 foo = 'logError' \"grumble.\" 270 @ 271 -} 272 273 -- Haddock comment broken in two to work around https://github.com/haskell/haddock/issues/313 274 275 -- | You may notice that most of the type signatures in this module contain a 276 -- @('MonadSnap' m) => ...@ typeclass constraint. 'MonadSnap' is a typeclass 277 -- which, in essence, says \"you can get back to the 'Snap' monad from 278 -- here\". Using 'MonadSnap' you can extend the 'Snap' monad with additional 279 -- functionality and still have access to most of the 'Snap' functions without 280 -- writing 'Control.Monad.Trans.Class.lift' everywhere. Instances are already 281 -- provided for most of the common monad transformers 282 -- ('Control.Monad.Trans.Reader.ReaderT', 'Control.Monad.Trans.Writer.WriterT', 283 -- 'Control.Monad.Trans.State.StateT', etc.). 284 newtype Snap a = Snap { 285 unSnap :: forall r . (a -> SnapState -> IO r) -- success continuation 286 -> (Zero -> SnapState -> IO r) -- mzero continuation 287 -> SnapState -- state for the monad 288 -> IO r 289 } 290 291 292 ------------------------------------------------------------------------------ 293 data SnapState = SnapState 294 { _snapRequest :: Request 295 , _snapResponse :: Response 296 , _snapLogError :: ByteString -> IO () 297 , _snapModifyTimeout :: (Int -> Int) -> IO () 298 } 299 300 -- TODO(greg): error log action and timeout modifier are never modified. 301 -- Splitting them out into their own datatype would save 16 bytes of allocation 302 -- every time you modify the request or response, but would gobble a register. 303 -- Benchmark it both ways. 304 305 ------------------------------------------------------------------------------ 306 instance Monad Snap where 307 (>>=) = snapBind 308 return = snapReturn 309 fail = snapFail 310 311 312 ------------------------------------------------------------------------------ 313 snapBind :: Snap a -> (a -> Snap b) -> Snap b 314 snapBind m f = Snap $ \sk fk st -> unSnap m (\a st' -> unSnap (f a) sk fk st') fk st 315 {-# INLINE snapBind #-} 316 317 318 snapReturn :: a -> Snap a 319 snapReturn = pure 320 {-# INLINE snapReturn #-} 321 322 323 snapFail :: String -> Snap a 324 snapFail !_ = Snap $ \_ fk st -> fk PassOnProcessing st 325 {-# INLINE snapFail #-} 326 327 328 ------------------------------------------------------------------------------ 329 instance MonadIO Snap where 330 liftIO m = Snap $ \sk _ st -> do x <- m 331 sk x st 332 333 334 ------------------------------------------------------------------------------ 335 instance (MonadBase IO) Snap where 336 liftBase = liftIO 337 338 339 ------------------------------------------------------------------------------ 340 newtype StSnap a = StSnap { 341 unStSnap :: StM (StateT SnapState IO) (SnapResult a) 342 } 343 344 instance (MonadBaseControl IO) Snap where 345 type StM Snap a = StSnap a 346 347 liftBaseWith f = stateTToSnap $ liftM SnapValue $ 348 liftBaseWith $ \g' -> f $ \m -> 349 liftM StSnap $ g' $ snapToStateT m 350 {-# INLINE liftBaseWith #-} 351 352 restoreM = stateTToSnap . restoreM . unStSnap 353 {-# INLINE restoreM #-} 354 355 ------------------------------------------------------------------------------ 356 snapToStateT :: Snap a -> StateT SnapState IO (SnapResult a) 357 snapToStateT m = StateT $ \st -> do 358 unSnap m (\a st' -> return (SnapValue a, st')) 359 (\z st' -> return (Zero z, st')) st 360 {-# INLINE snapToStateT #-} 361 362 363 ------------------------------------------------------------------------------ 364 {-# INLINE stateTToSnap #-} 365 stateTToSnap :: StateT SnapState IO (SnapResult a) -> Snap a 366 stateTToSnap m = Snap $ \sk fk st -> do 367 (a, st') <- runStateT m st 368 case a of 369 SnapValue x -> sk x st' 370 Zero z -> fk z st' 371 372 373 ------------------------------------------------------------------------------ 374 instance MonadPlus Snap where 375 mzero = Snap $ \_ fk st -> fk PassOnProcessing st 376 377 a `mplus` b = 378 Snap $ \sk fk st -> 379 let fk' z st' = case z of 380 PassOnProcessing -> unSnap b sk fk st' 381 _ -> fk z st' 382 in unSnap a sk fk' st 383 384 385 ------------------------------------------------------------------------------ 386 instance Functor Snap where 387 fmap f m = Snap $ \sk fk st -> unSnap m (sk . f) fk st 388 389 ------------------------------------------------------------------------------ 390 instance Applicative Snap where 391 pure x = Snap $ \sk _ st -> sk x st 392 (<*>) = ap 393 394 395 ------------------------------------------------------------------------------ 396 instance Alternative Snap where 397 empty = mzero 398 (<|>) = mplus 399 400 401 ------------------------------------------------------------------------------ 402 instance MonadSnap Snap where 403 liftSnap = id 404 405 406 ------------------------------------------------------------------------------ 407 -- | The Typeable instance is here so Snap can be dynamically executed with 408 -- Hint. 409 #if __GLASGOW_HASKELL__ < 708 410 snapTyCon :: TyCon 411 #if MIN_VERSION_base(4,4,0) 412 snapTyCon = mkTyCon3 "snap-core" "Snap.Core" "Snap" 413 #else 414 snapTyCon = mkTyCon "Snap.Core.Snap" 415 #endif 416 {-# NOINLINE snapTyCon #-} 417 418 instance Typeable1 Snap where 419 typeOf1 _ = mkTyConApp snapTyCon [] 420 #else 421 deriving instance Typeable Snap 422 #endif 423 424 ------------------------------------------------------------------------------ 425 -- | Pass the request body stream to a consuming procedure, returning the 426 -- result. 427 -- 428 -- If the consuming procedure you pass in here throws an exception, Snap will 429 -- attempt to clear the rest of the unread request body (using 430 -- 'System.IO.Streams.Combinators.skipToEof') before rethrowing the 431 -- exception. If you used 'terminateConnection', however, Snap will give up and 432 -- immediately close the socket. 433 -- 434 -- To prevent slowloris attacks, the connection will be also terminated if the 435 -- input socket produces data too slowly (500 bytes per second is the default 436 -- limit). 437 -- 438 -- Example: 439 -- 440 -- @ 441 -- ghci> :set -XOverloadedStrings 442 -- ghci> import qualified "Data.ByteString.Char8" as B8 443 -- ghci> import qualified "Data.ByteString.Lazy" as L 444 -- ghci> import "Data.Char" (toUpper) 445 -- ghci> import qualified "Data.Map" as M 446 -- ghci> import qualified "Snap.Test" as T 447 -- ghci> import qualified "System.IO.Streams" as Streams 448 -- ghci> let r = T.put \"\/foo\" \"text\/plain\" \"some text\" 449 -- ghci> :{ 450 -- ghci| let f s = do u \<- Streams.map (B8.map toUpper) s 451 -- ghci| l \<- Streams.toList u 452 -- ghci| return $ L.fromChunks l 453 -- ghci| :} 454 -- ghci> T.runHandler r ('runRequestBody' f >>= 'writeLBS') 455 -- HTTP/1.1 200 OK 456 -- server: Snap/test 457 -- date: Thu, 07 Aug 2014 20:48:40 GMT 458 -- 459 -- SOME TEXT 460 -- @ 461 runRequestBody :: MonadSnap m => 462 (InputStream ByteString -> IO a) 463 -> m a 464 runRequestBody proc = do 465 bumpTimeout <- liftM ($ max 5) getTimeoutModifier 466 req <- getRequest 467 body <- liftIO $ Streams.throwIfTooSlow bumpTimeout 500 5 $ 468 rqBody req 469 run body 470 471 where 472 skip body = liftIO (Streams.skipToEof body) `catch` tooSlow 473 474 tooSlow (e :: Streams.RateTooSlowException) = 475 terminateConnection e 476 477 run body = (liftIO $ do 478 x <- proc body 479 Streams.skipToEof body 480 return x) `catches` handlers 481 where 482 handlers = [ Handler tooSlow, Handler other ] 483 other (e :: SomeException) = skip body >> throwIO e 484 485 486 ------------------------------------------------------------------------------ 487 -- | Returns the request body as a lazy bytestring. /Note that the request is 488 -- not actually provided lazily!/ 489 -- 490 -- Example: 491 -- 492 -- @ 493 -- ghci> :set -XOverloadedStrings 494 -- ghci> import qualified "Data.Map" as M 495 -- ghci> import qualified "Snap.Test" as T 496 -- ghci> let r = T.put \"\/foo\" \"text\/plain\" \"some text\" 497 -- ghci> T.runHandler r ('readRequestBody' 2048 >>= 'writeLBS') 498 -- HTTP\/1.1 200 OK 499 -- server: Snap\/test 500 -- date: Thu, 07 Aug 2014 20:08:44 GMT 501 -- 502 -- some text 503 -- @ 504 -- 505 -- /Since: 0.6/ 506 readRequestBody :: MonadSnap m => 507 Word64 -- ^ size of the largest request body we're willing 508 -- to accept. If a request body longer than this is 509 -- received, a 'TooManyBytesReadException' is 510 -- thrown. See 'takeNoMoreThan'. 511 -> m L.ByteString 512 readRequestBody sz = liftM L.fromChunks $ runRequestBody f 513 where 514 f str = Streams.throwIfProducesMoreThan (fromIntegral sz) str >>= 515 Streams.toList 516 517 518 ------------------------------------------------------------------------------ 519 -- | Normally Snap is careful to ensure that the request body is fully 520 -- consumed after your web handler runs, but before the 'Response' body 521 -- is streamed out the socket. If you want to transform the request body into 522 -- some output in O(1) space, you should use this function. 523 -- 524 -- Take care: in order for this to work, the HTTP client must be written with 525 -- input-to-output streaming in mind. 526 -- 527 -- Note that upon calling this function, response processing finishes early as 528 -- if you called 'finishWith'. Make sure you set any content types, headers, 529 -- cookies, etc. before you call this function. 530 -- 531 -- Example: 532 -- 533 -- @ 534 -- ghci> :set -XOverloadedStrings 535 -- ghci> import qualified "Data.ByteString.Char8" as B8 536 -- ghci> import "Data.Char" (toUpper) 537 -- ghci> import qualified "Data.Map" as M 538 -- ghci> import qualified "Snap.Test" as T 539 -- ghci> import qualified "System.IO.Streams" as Streams 540 -- ghci> let r = T.put \"\/foo\" \"text\/plain\" \"some text\" 541 -- ghci> let f = Streams.map (B8.map toUpper) 542 -- ghci> T.runHandler r ('transformRequestBody' f >> 'readRequestBody' 2048 >>= 'writeLBS') 543 -- HTTP\/1.1 200 OK 544 -- server: Snap\/test 545 -- date: Thu, 07 Aug 2014 20:30:15 GMT 546 -- 547 -- SOME TEXT 548 -- @ 549 transformRequestBody :: (InputStream ByteString -> IO (InputStream ByteString)) 550 -- ^ the 'InputStream' from the 'Request' is passed to 551 -- this function, and then the resulting 'InputStream' 552 -- is fed to the output. 553 -> Snap () 554 transformRequestBody trans = do 555 req <- getRequest 556 is <- liftIO ((trans $ rqBody req) >>= 557 Streams.mapM (return . byteString)) 558 origRsp <- getResponse 559 let rsp = setResponseBody (\out -> Streams.connect is out >> return out) $ 560 origRsp { rspTransformingRqBody = True } 561 finishWith rsp 562 563 564 ------------------------------------------------------------------------------ 565 -- | Short-circuits a 'Snap' monad action early, storing the given 566 -- 'Response' value in its state. 567 -- 568 -- IMPORTANT: Be vary careful when using this with things like a DB library's 569 -- `withTransaction` function or any other kind of setup/teardown block, as it 570 -- can prevent the cleanup from being called and result in resource leaks. 571 -- 572 -- Example: 573 -- 574 -- @ 575 -- ghci> :set -XOverloadedStrings 576 -- ghci> import qualified "Data.Map" as M 577 -- ghci> import qualified "Snap.Test" as T 578 -- ghci> import "Control.Applicative" 579 -- ghci> let r = T.get \"\/\" M.empty 580 -- ghci> T.runHandler r (('ifTop' $ 'writeBS' \"TOP\") \<|> 'finishWith' 'emptyResponse') 581 -- HTTP\/1.1 200 OK 582 -- server: Snap\/test 583 -- date: Thu, 07 Aug 2014 16:58:57 GMT 584 -- 585 -- TOP 586 -- ghci> let r\' = T.get \"\/foo\/bar\" M.empty 587 -- ghci> T.runHandler r\' (('ifTop' $ 'writeBS' \"TOP\") \<|> 'finishWith' 'emptyResponse') 588 -- HTTP\/1.1 200 OK 589 -- server: Snap\/test 590 -- date: Thu, 07 Aug 2014 17:50:50 GMT 591 -- 592 -- 593 -- @ 594 finishWith :: MonadSnap m => Response -> m a 595 finishWith r = liftSnap $ Snap $ \_ fk st -> fk (EarlyTermination r) st 596 {-# INLINE finishWith #-} 597 598 599 ------------------------------------------------------------------------------ 600 -- | Capture the flow of control in case a handler calls 'finishWith'. 601 -- 602 -- /WARNING/: in the event of a call to 'transformRequestBody' it is possible 603 -- to violate HTTP protocol safety when using this function. If you call 604 -- 'catchFinishWith' it is suggested that you do not modify the body of the 605 -- 'Response' which was passed to the 'finishWith' call. 606 -- 607 -- Example: 608 -- 609 -- @ 610 -- ghci> :set -XOverloadedStrings 611 -- ghci> import qualified "Data.ByteString.Char8" as B8 612 -- ghci> import qualified "Data.Map" as M 613 -- ghci> import qualified "Snap.Test" as T 614 -- ghci> import "Control.Applicative" 615 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 616 -- ghci> let h = ('ifTop' $ 'writeBS' \"TOP\") \<|> 'finishWith' 'emptyResponse' 617 -- ghci> T.runHandler r ('catchFinishWith' h >>= 'writeBS' . B8.pack . show) 618 -- HTTP\/1.1 200 OK 619 -- server: Snap\/test 620 -- date: Thu, 07 Aug 2014 18:35:42 GMT 621 -- 622 -- Left HTTP\/1.1 200 OK 623 -- 624 -- 625 -- @ 626 catchFinishWith :: Snap a -> Snap (Either Response a) 627 catchFinishWith (Snap m) = Snap $ \sk fk st -> do 628 let sk' v s = sk (Right v) s 629 let fk' z s = case z of 630 (EarlyTermination resp) -> sk (Left resp) s 631 _ -> fk z s 632 m sk' fk' st 633 {-# INLINE catchFinishWith #-} 634 635 636 ------------------------------------------------------------------------------ 637 -- | Fails out of a 'Snap' monad action. This is used to indicate 638 -- that you choose not to handle the given request within the given 639 -- handler. 640 -- 641 -- Example: 642 -- 643 -- @ 644 -- ghci> :set -XOverloadedStrings 645 -- ghci> import qualified "Data.Map" as M 646 -- ghci> import qualified "Snap.Test" as T 647 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 648 -- ghci> T.runHandler r 'pass' 649 -- HTTP\/1.1 404 Not Found 650 -- server: Snap\/test 651 -- date: Thu, 07 Aug 2014 13:35:42 GMT 652 -- 653 -- \<!DOCTYPE html> 654 -- \<html> 655 -- \<head> 656 -- \<title>Not found\<\/title> 657 -- \<\/head> 658 -- \<body> 659 -- \<code>No handler accepted \"\/foo\/bar\"<\/code> 660 -- \<\/body>\<\/html> 661 -- @ 662 pass :: MonadSnap m => m a 663 pass = empty 664 665 666 ------------------------------------------------------------------------------ 667 -- | Runs a 'Snap' monad action only if the request's HTTP method matches 668 -- the given method. 669 -- 670 -- Example: 671 -- 672 -- @ 673 -- ghci> :set -XOverloadedStrings 674 -- ghci> import qualified "Data.Map" as M 675 -- ghci> import qualified "Snap.Test" as T 676 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 677 -- ghci> T.runHandler r ('method' 'GET' $ 'writeBS' \"OK\") 678 -- HTTP\/1.1 200 OK 679 -- server: Snap\/test 680 -- date: Thu, 07 Aug 2014 13:38:48 GMT 681 -- 682 -- OK 683 -- ghci> T.runHandler r ('method' 'POST' $ 'writeBS' \"OK\") 684 -- HTTP\/1.1 404 Not Found 685 -- ... 686 -- @ 687 method :: MonadSnap m => Method -> m a -> m a 688 method m action = do 689 req <- getRequest 690 unless (rqMethod req == m) pass 691 action 692 {-# INLINE method #-} 693 694 695 ------------------------------------------------------------------------------ 696 -- | Runs a 'Snap' monad action only if the request's HTTP method matches 697 -- one of the given methods. 698 -- 699 -- Example: 700 -- 701 -- @ 702 -- ghci> :set -XOverloadedStrings 703 -- ghci> import qualified "Data.Map" as M 704 -- ghci> import qualified "Snap.Test" as T 705 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 706 -- ghci> T.runHandler r ('methods' ['GET', 'POST'] $ 'writeBS' \"OK\") 707 -- HTTP\/1.1 200 OK 708 -- server: Snap\/test 709 -- date: Thu, 07 Aug 2014 13:38:48 GMT 710 -- 711 -- OK 712 -- ghci> T.runHandler r ('methods' ['POST'] $ 'writeBS' \"OK\") 713 -- HTTP\/1.1 404 Not Found 714 -- ... 715 -- @ 716 methods :: MonadSnap m => [Method] -> m a -> m a 717 methods ms action = do 718 req <- getRequest 719 unless (rqMethod req `elem` ms) pass 720 action 721 {-# INLINE methods #-} 722 723 724 ------------------------------------------------------------------------------ 725 -- Appends n bytes of the path info to the context path with a 726 -- trailing slash. 727 updateContextPath :: Int -> Request -> Request 728 updateContextPath n req | n > 0 = req { rqContextPath = ctx 729 , rqPathInfo = pinfo } 730 | otherwise = req 731 where 732 ctx' = S.take n (rqPathInfo req) 733 ctx = S.concat [rqContextPath req, ctx', "/"] 734 pinfo = S.drop (n+1) (rqPathInfo req) 735 736 737 ------------------------------------------------------------------------------ 738 -- Runs a 'Snap' monad action only if the 'rqPathInfo' matches the given 739 -- predicate. 740 pathWith :: MonadSnap m 741 => (ByteString -> ByteString -> Bool) 742 -> ByteString 743 -> m a 744 -> m a 745 pathWith c p action = do 746 req <- getRequest 747 unless (c p (rqPathInfo req)) pass 748 localRequest (updateContextPath $ S.length p) action 749 750 751 ------------------------------------------------------------------------------ 752 -- | Runs a 'Snap' monad action only when the 'rqPathInfo' of the request 753 -- starts with the given path. For example, 754 -- 755 -- > dir "foo" handler 756 -- 757 -- Will fail if 'rqPathInfo' is not \"@\/foo@\" or \"@\/foo\/...@\", and will 758 -- add @\"foo\/\"@ to the handler's local 'rqContextPath'. 759 -- 760 -- Example: 761 -- 762 -- @ 763 -- ghci> :set -XOverloadedStrings 764 -- ghci> import qualified "Data.Map" as M 765 -- ghci> import qualified "Snap.Test" as T 766 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 767 -- ghci> T.runHandler r ('dir' \"foo\" $ 'writeBS' \"OK\") 768 -- HTTP\/1.1 200 OK 769 -- server: Snap\/test 770 -- date: Thu, 07 Aug 2014 14:52:24 GMT 771 -- 772 -- OK 773 -- ghci> T.runHandler r ('dir' \"baz\" $ 'writeBS' \"OK\") 774 -- HTTP\/1.1 404 Not Found 775 -- ... 776 -- @ 777 dir :: MonadSnap m 778 => ByteString -- ^ path component to match 779 -> m a -- ^ handler to run 780 -> m a 781 dir = pathWith f 782 where 783 f dr pinfo = dr == x 784 where 785 (x,_) = S.break (=='/') pinfo 786 {-# INLINE dir #-} 787 788 789 ------------------------------------------------------------------------------ 790 -- | Runs a 'Snap' monad action only for requests where 'rqPathInfo' is 791 -- exactly equal to the given string. If the path matches, locally sets 792 -- 'rqContextPath' to the old value of 'rqPathInfo', sets 'rqPathInfo'=\"\", 793 -- and runs the given handler. 794 -- 795 -- Example: 796 -- 797 -- @ 798 -- ghci> :set -XOverloadedStrings 799 -- ghci> import qualified "Data.Map" as M 800 -- ghci> import qualified "Snap.Test" as T 801 -- ghci> T.runHandler (T.get \"\/foo\" M.empty) ('path' \"foo\" $ 'writeBS' \"bar\") 802 -- HTTP\/1.1 200 OK 803 -- server: Snap\/test 804 -- date: Thu, 07 Aug 2014 14:15:42 GMT 805 -- 806 -- bar 807 -- ghci> T.runHandler (T.get \"\/foo\" M.empty) ('path' \"bar\" $ 'writeBS' \"baz\") 808 -- HTTP\/1.1 404 Not Found 809 -- ... 810 -- @ 811 path :: MonadSnap m 812 => ByteString -- ^ path to match against 813 -> m a -- ^ handler to run 814 -> m a 815 path = pathWith (==) 816 {-# INLINE path #-} 817 818 819 ------------------------------------------------------------------------------ 820 -- | Runs a 'Snap' monad action only when the first path component is 821 -- successfully parsed as the argument to the supplied handler function. 822 -- 823 -- Note that the path segment is url-decoded prior to being passed to 'fromBS'; 824 -- this is new as of snap-core 0.10. 825 -- 826 -- Example: 827 -- 828 -- @ 829 -- ghci> :set -XOverloadedStrings 830 -- ghci> import qualified "Data.Map" as M 831 -- ghci> import qualified "Snap.Test" as T 832 -- ghci> let r = T.get \"\/11\/foo\/bar\" M.empty 833 -- ghci> let f = (\\i -> if i == 11 then 'writeBS' \"11\" else 'writeBS' \"???\") 834 -- ghci> T.runHandler r ('pathArg' f) 835 -- HTTP\/1.1 200 OK 836 -- server: Snap\/test 837 -- date: Thu, 07 Aug 2014 14:27:10 GMT 838 -- 839 -- 11 840 -- ghci> let r\' = T.get \"\/foo\/11\/bar\" M.empty 841 -- ghci> T.runHandler r\' ('pathArg' f) 842 -- HTTP\/1.1 404 Not Found 843 -- ... 844 -- @ 845 pathArg :: (R.Readable a, MonadSnap m) 846 => (a -> m b) 847 -> m b 848 pathArg f = do 849 req <- getRequest 850 let (p,_) = S.break (=='/') (rqPathInfo req) 851 p' <- maybe mzero return $ urlDecode p 852 a <- R.fromBS p' 853 localRequest (updateContextPath $ S.length p) (f a) 854 855 856 ------------------------------------------------------------------------------ 857 -- | Runs a 'Snap' monad action only when 'rqPathInfo' is empty. 858 -- 859 -- Example: 860 -- 861 -- @ 862 -- ghci> :set -XOverloadedStrings 863 -- ghci> import qualified "Data.Map" as M 864 -- ghci> import qualified "Snap.Test" as T 865 -- ghci> let r = T.get \"\/\" M.empty 866 -- ghci> T.runHandler r ('ifTop' $ 'writeBS' "OK") 867 -- HTTP\/1.1 200 OK 868 -- server: Snap\/test 869 -- date: Thu, 07 Aug 2014 14:56:39 GMT 870 -- 871 -- OK 872 -- ghci> let r\' = T.get \"\/foo\" M.empty 873 -- ghci> T.runHandler r\' ('ifTop' $ 'writeBS' \"OK\") 874 -- HTTP\/1.1 404 Not Found 875 -- ... 876 -- @ 877 ifTop :: MonadSnap m => m a -> m a 878 ifTop = path "" 879 {-# INLINE ifTop #-} 880 881 882 ------------------------------------------------------------------------------ 883 -- | Local Snap version of 'get'. 884 sget :: Snap SnapState 885 sget = Snap $ \sk _ st -> sk st st 886 {-# INLINE sget #-} 887 888 889 ------------------------------------------------------------------------------ 890 -- | Local Snap monad version of 'modify'. 891 smodify :: (SnapState -> SnapState) -> Snap () 892 smodify f = Snap $ \sk _ st -> sk () (f st) 893 {-# INLINE smodify #-} 894 895 896 ------------------------------------------------------------------------------ 897 -- | Grabs the 'Request' object out of the 'Snap' monad. 898 -- 899 -- Example: 900 -- 901 -- @ 902 -- ghci> :set -XOverloadedStrings 903 -- ghci> import qualified "Data.Map" as M 904 -- ghci> import qualified "Snap.Test" as T 905 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 906 -- ghci> T.runHandler r ('writeBS' . 'rqURI' =\<\< 'getRequest') 907 -- HTTP\/1.1 200 OK 908 -- server: Snap\/test 909 -- date: Sat, 02 Aug 2014 07:51:54 GMT 910 -- 911 -- \/foo\/bar 912 -- @ 913 getRequest :: MonadSnap m => m Request 914 getRequest = liftSnap $ liftM _snapRequest sget 915 {-# INLINE getRequest #-} 916 917 918 ------------------------------------------------------------------------------ 919 -- | Grabs something out of the 'Request' object, using the given projection 920 -- function. See 'gets'. 921 -- 922 -- Example: 923 -- 924 -- @ 925 -- ghci> :set -XOverloadedStrings 926 -- ghci> import qualified "Data.Map" as M 927 -- ghci> import qualified "Snap.Test" as T 928 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 929 -- ghci> T.runHandler r ('writeBS' =\<\< 'getsRequest' 'rqURI') 930 -- HTTP\/1.1 200 OK 931 -- server: Snap\/test 932 -- date: Sat, 02 Aug 2014 07:51:54 GMT 933 -- 934 -- \/foo\/bar 935 -- @ 936 getsRequest :: MonadSnap m => (Request -> a) -> m a 937 getsRequest f = liftSnap $ liftM (f . _snapRequest) sget 938 {-# INLINE getsRequest #-} 939 940 941 ------------------------------------------------------------------------------ 942 -- | Grabs the 'Response' object out of the 'Snap' monad. 943 -- 944 -- Example: 945 -- 946 -- @ 947 -- ghci> :set -XOverloadedStrings 948 -- ghci> import qualified "Data.Map" as M 949 -- ghci> import qualified "Snap.Test" as T 950 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 951 -- ghci> T.runHandler r ('writeBS' . 'rspStatusReason' =\<\< 'getResponse') 952 -- HTTP\/1.1 200 OK 953 -- server: Snap\/test 954 -- date: Sat, 02 Aug 2014 15:06:00 GMT 955 -- 956 -- OK 957 -- @ 958 getResponse :: MonadSnap m => m Response 959 getResponse = liftSnap $ liftM _snapResponse sget 960 {-# INLINE getResponse #-} 961 962 963 ------------------------------------------------------------------------------ 964 -- | Grabs something out of the 'Response' object, using the given projection 965 -- function. See 'gets'. 966 -- 967 -- Example: 968 -- 969 -- @ 970 -- ghci> :set -XOverloadedStrings 971 -- ghci> import qualified "Data.Map" as M 972 -- ghci> import qualified "Snap.Test" as T 973 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 974 -- ghci> T.runHandler r ('writeBS' =\<\< 'getsResponse' 'rspStatusReason') 975 -- HTTP\/1.1 200 OK 976 -- server: Snap\/test 977 -- date: Wed, 06 Aug 2014 13:35:45 GMT 978 -- 979 -- OK 980 -- @ 981 getsResponse :: MonadSnap m => (Response -> a) -> m a 982 getsResponse f = liftSnap $ liftM (f . _snapResponse) sget 983 {-# INLINE getsResponse #-} 984 985 986 ------------------------------------------------------------------------------ 987 -- | Puts a new 'Response' object into the 'Snap' monad. 988 -- 989 -- Example: 990 -- 991 -- @ 992 -- ghci> :set -XOverloadedStrings 993 -- ghci> import qualified "Data.Map" as M 994 -- ghci> import qualified "Snap.Test" as T 995 -- ghci> let rsp = 'setResponseCode' 404 'emptyResponse' 996 -- ghci> let req = T.get \"\/foo\/bar\" M.empty 997 -- ghci> T.runHandler req ('putResponse' rsp) 998 -- HTTP\/1.1 404 Not Found 999 -- server: Snap\/test 1000 -- date: Wed, 06 Aug 2014 13:59:58 GMT 1001 -- 1002 -- 1003 -- @ 1004 putResponse :: MonadSnap m => Response -> m () 1005 putResponse r = liftSnap $ smodify $ \ss -> ss { _snapResponse = r } 1006 {-# INLINE putResponse #-} 1007 1008 1009 ------------------------------------------------------------------------------ 1010 -- | Puts a new 'Request' object into the 'Snap' monad. 1011 -- Example: 1012 -- 1013 -- @ 1014 -- ghci> :set -XOverloadedStrings 1015 -- ghci> import qualified "Data.Map" as M 1016 -- ghci> import qualified "Snap.Test" as T 1017 -- ghci> :{ 1018 -- ghci| let hndlr = do rq \<- T.buildRequest (T.get \"\/bar\/foo\" M.empty) 1019 -- ghci| 'putRequest' rq 1020 -- ghci| uri\' \<- 'getsRequest' 'rqURI' 1021 -- ghci| 'writeBS' uri\' 1022 -- ghci| :} 1023 -- ghci> T.runHandler (T.get \"\/foo\/bar\" M.empty) hndlr 1024 -- HTTP\/1.1 200 OK 1025 -- server: Snap\/test 1026 -- date: Wed, 06 Aug 2014 15:13:46 GMT 1027 -- 1028 -- \/bar\/foo 1029 -- @ 1030 putRequest :: MonadSnap m => Request -> m () 1031 putRequest r = liftSnap $ smodify $ \ss -> ss { _snapRequest = r } 1032 {-# INLINE putRequest #-} 1033 1034 1035 ------------------------------------------------------------------------------ 1036 -- | Modifies the 'Request' object stored in a 'Snap' monad. 1037 -- Example: 1038 -- 1039 -- @ 1040 -- ghci> :set -XOverloadedStrings 1041 -- ghci> import qualified "Data.Map" as M 1042 -- ghci> import qualified "Snap.Test" as T 1043 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1044 -- ghci> r\' \<- T.buildRequest $ T.get \"\/bar\/foo\" M.empty 1045 -- ghci> T.runHandler r ('modifyRequest' (const r\') >> 'getsRequest' 'rqURI' >>= 'writeBS') 1046 -- HTTP\/1.1 200 OK 1047 -- server: Snap\/test 1048 -- date: Wed, 06 Aug 2014 15:24:25 GMT 1049 -- 1050 -- \/bar\/foo 1051 -- @ 1052 modifyRequest :: MonadSnap m => (Request -> Request) -> m () 1053 modifyRequest f = liftSnap $ 1054 smodify $ \ss -> ss { _snapRequest = f $ _snapRequest ss } 1055 {-# INLINE modifyRequest #-} 1056 1057 1058 ------------------------------------------------------------------------------ 1059 -- | Modifes the 'Response' object stored in a 'Snap' monad. 1060 -- Example: 1061 -- 1062 -- @ 1063 -- ghci> :set -XOverloadedStrings 1064 -- ghci> import qualified "Data.Map" as M 1065 -- ghci> import qualified "Snap.Test" as T 1066 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1067 -- ghci> T.runHandler r ('modifyResponse' $ 'setResponseCode' 404) 1068 -- HTTP\/1.1 404 Not Found 1069 -- server: Snap\/test 1070 -- date: Wed, 06 Aug 2014 15:27:11 GMT 1071 -- 1072 -- 1073 -- @ 1074 modifyResponse :: MonadSnap m => (Response -> Response) -> m () 1075 modifyResponse f = liftSnap $ 1076 smodify $ \ss -> ss { _snapResponse = f $ _snapResponse ss } 1077 {-# INLINE modifyResponse #-} 1078 1079 1080 ------------------------------------------------------------------------------ 1081 -- | Performs a redirect by setting the @Location@ header to the given target 1082 -- URL/path and the status code to 302 in the 'Response' object stored in a 1083 -- 'Snap' monad. Note that the target URL is not validated in any way. 1084 -- Consider using 'redirect'' instead, which allows you to choose the correct 1085 -- status code. 1086 -- 1087 -- Example: 1088 -- 1089 -- @ 1090 -- ghci> :set -XOverloadedStrings 1091 -- ghci> import qualified "Data.Map" as M 1092 -- ghci> import qualified "Snap.Test" as T 1093 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1094 -- ghci> T.runHandler r ('redirect' \"http:\/\/snapframework.com\") 1095 -- HTTP\/1.1 302 Found 1096 -- content-length: 0 1097 -- location: http:\/\/snapframework.com 1098 -- server: Snap\/test 1099 -- date: Thu, 07 Aug 2014 08:52:11 GMT 1100 -- Content-Length: 0 1101 -- 1102 -- 1103 -- @ 1104 redirect :: MonadSnap m => ByteString -> m a 1105 redirect target = redirect' target 302 1106 {-# INLINE redirect #-} 1107 1108 1109 ------------------------------------------------------------------------------ 1110 -- | Performs a redirect by setting the @Location@ header to the given target 1111 -- URL/path and the status code (should be one of 301, 302, 303 or 307) in the 1112 -- 'Response' object stored in a 'Snap' monad. Note that the target URL is not 1113 -- validated in any way. 1114 -- 1115 -- Example: 1116 -- 1117 -- @ 1118 -- ghci> :set -XOverloadedStrings 1119 -- ghci> import qualified "Data.Map" as M 1120 -- ghci> import qualified "Snap.Test" as T 1121 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1122 -- ghci> T.runHandler r ('redirect'' \"http:\/\/snapframework.com\" 301) 1123 -- HTTP\/1.1 307 Temporary Redirect 1124 -- content-length: 0 1125 -- location: http:\/\/snapframework.com 1126 -- server: Snap\/test 1127 -- date: Thu, 07 Aug 2014 08:55:51 GMT 1128 -- Content-Length: 0 1129 -- 1130 -- 1131 -- @ 1132 redirect' :: MonadSnap m => ByteString -> Int -> m a 1133 redirect' target status = do 1134 r <- getResponse 1135 1136 finishWith 1137 $ setResponseCode status 1138 $ setContentLength 0 1139 $ modifyResponseBody (const $ return . id) 1140 $ setHeader "Location" target r 1141 1142 {-# INLINE redirect' #-} 1143 1144 1145 ------------------------------------------------------------------------------ 1146 -- | Log an error message in the 'Snap' monad. 1147 -- 1148 -- Example: 1149 -- 1150 -- @ 1151 -- ghci> import qualified "Data.ByteString.Char8" as B8 1152 -- ghci> 'runSnap' ('logError' \"fatal error!\") ('error' . B8.unpack) undefined undefined 1153 -- *** Exception: fatal error! 1154 -- @ 1155 logError :: MonadSnap m => ByteString -> m () 1156 logError s = liftSnap $ Snap $ \sk _ st -> do 1157 _snapLogError st s 1158 sk () st 1159 {-# INLINE logError #-} 1160 1161 1162 ------------------------------------------------------------------------------ 1163 -- | Run the given stream procedure, adding its output to the 'Response' stored 1164 -- in the 'Snap' monad state. 1165 -- 1166 -- Example: 1167 -- 1168 -- @ 1169 -- ghci> :set -XOverloadedStrings 1170 -- ghci> import qualified "Data.Map" as M 1171 -- ghci> import qualified "Snap.Test" as T 1172 -- ghci> import qualified "Data.ByteString.Builder" as B 1173 -- ghci> import qualified "System.IO.Streams" as Streams 1174 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1175 -- ghci> :{ 1176 -- ghci| let f str = do { 1177 -- ghci| Streams.write (Just $ B.byteString \"Hello, streams world\") str; 1178 -- ghci| return str } 1179 -- ghci| :} 1180 -- ghci> T.runHandler r ('addToOutput' f) 1181 -- HTTP\/1.1 200 OK 1182 -- server: Snap\/test 1183 -- date: Wed, 06 Aug 2014 17:55:47 GMT 1184 -- 1185 -- Hello, streams world 1186 -- @ 1187 addToOutput :: MonadSnap m 1188 => (OutputStream Builder -> IO (OutputStream Builder)) 1189 -- ^ output to add 1190 -> m () 1191 addToOutput enum = modifyResponse $ modifyResponseBody (c enum) 1192 where 1193 c a b = \out -> b out >>= a 1194 1195 ------------------------------------------------------------------------------ 1196 -- | Adds the given 'Builder' to the body of the 'Response' stored in the 1197 -- | 'Snap' monad state. 1198 -- 1199 -- Example: 1200 -- 1201 -- @ 1202 -- ghci> :set -XOverloadedStrings 1203 -- ghci> import qualified "Data.Map" as M 1204 -- ghci> import qualified "Snap.Test" as T 1205 -- ghci> import qualified "Data.ByteString.Builder" as B 1206 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1207 -- ghci> T.runHandler r ('writeBuilder' $ B.byteString \"Hello, world\") 1208 -- HTTP\/1.1 200 OK 1209 -- server: Snap\/test 1210 -- date: Wed, 06 Aug 2014 17:33:33 GMT 1211 -- 1212 -- Hello, world 1213 -- @ 1214 writeBuilder :: MonadSnap m => Builder -> m () 1215 writeBuilder b = addToOutput f 1216 where 1217 f str = Streams.write (Just b) str >> return str 1218 {-# INLINE writeBuilder #-} 1219 1220 1221 ------------------------------------------------------------------------------ 1222 -- | Adds the given strict 'ByteString' to the body of the 'Response' stored 1223 -- in the 'Snap' monad state. 1224 -- 1225 -- Warning: This function is intentionally non-strict. If any pure 1226 -- exceptions are raised by the expression creating the 'ByteString', 1227 -- the exception won't actually be raised within the Snap handler. 1228 -- 1229 -- Example: 1230 -- 1231 -- @ 1232 -- ghci> :set -XOverloadedStrings 1233 -- ghci> import qualified "Data.Map" as M 1234 -- ghci> import qualified "Snap.Test" as T 1235 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1236 -- ghci> T.runHandler r ('writeBS' \"Hello, bytestring world\") 1237 -- HTTP\/1.1 200 OK 1238 -- server: Snap\/test 1239 -- date: Wed, 06 Aug 2014 17:34:27 GMT 1240 -- 1241 -- Hello, bytestring world 1242 -- @ 1243 writeBS :: MonadSnap m => ByteString -> m () 1244 writeBS = writeBuilder . byteString 1245 {-# INLINE writeBS #-} 1246 1247 1248 ------------------------------------------------------------------------------ 1249 -- | Adds the given lazy 'L.ByteString' to the body of the 'Response' stored 1250 -- in the 'Snap' monad state. 1251 -- 1252 -- Warning: This function is intentionally non-strict. If any pure 1253 -- exceptions are raised by the expression creating the 'ByteString', 1254 -- the exception won't actually be raised within the Snap handler. 1255 -- 1256 -- Example: 1257 -- 1258 -- @ 1259 -- ghci> :set -XOverloadedStrings 1260 -- ghci> import qualified "Data.Map" as M 1261 -- ghci> import qualified "Snap.Test" as T 1262 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1263 -- ghci> T.runHandler r ('writeLBS' \"Hello, lazy bytestring world\") 1264 -- HTTP\/1.1 200 OK 1265 -- server: Snap\/test 1266 -- date: Wed, 06 Aug 2014 17:35:15 GMT 1267 -- 1268 -- Hello, lazy bytestring world 1269 -- @ 1270 writeLBS :: MonadSnap m => L.ByteString -> m () 1271 writeLBS = writeBuilder . lazyByteString 1272 {-# INLINE writeLBS #-} 1273 1274 1275 ------------------------------------------------------------------------------ 1276 -- | Adds the given strict 'T.Text' to the body of the 'Response' stored in 1277 -- the 'Snap' monad state. 1278 -- 1279 -- Warning: This function is intentionally non-strict. If any pure 1280 -- exceptions are raised by the expression creating the 'ByteString', 1281 -- the exception won't actually be raised within the Snap handler. 1282 -- 1283 -- Example: 1284 -- 1285 -- @ 1286 -- ghci> :set -XOverloadedStrings 1287 -- ghci> import qualified "Data.Map" as M 1288 -- ghci> import qualified "Snap.Test" as T 1289 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1290 -- ghci> T.runHandler r ('writeText' \"Hello, text world\") 1291 -- HTTP\/1.1 200 OK 1292 -- server: Snap\/test 1293 -- date: Wed, 06 Aug 2014 17:36:38 GMT 1294 -- 1295 -- Hello, text world 1296 -- @ 1297 writeText :: MonadSnap m => T.Text -> m () 1298 writeText = writeBS . T.encodeUtf8 1299 -- it's inefficient, but we don't have bytestring builder text functions for 1300 -- 0.9-era bytestring 1301 {-# INLINE writeText #-} 1302 1303 1304 ------------------------------------------------------------------------------ 1305 -- | Adds the given lazy 'LT.Text' to the body of the 'Response' stored in the 1306 -- 'Snap' monad state. 1307 -- 1308 -- Warning: This function is intentionally non-strict. If any pure 1309 -- exceptions are raised by the expression creating the 'ByteString', 1310 -- the exception won't actually be raised within the Snap handler. 1311 -- 1312 -- Example: 1313 -- 1314 -- @ 1315 -- ghci> :set -XOverloadedStrings 1316 -- ghci> import qualified "Data.Map" as M 1317 -- ghci> import qualified "Snap.Test" as T 1318 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1319 -- ghci> T.runHandler r ('writeLazyText' \"Hello, lazy text world\") 1320 -- HTTP\/1.1 200 OK 1321 -- server: Snap\/test 1322 -- date: Wed, 06 Aug 2014 17:37:41 GMT 1323 -- 1324 -- Hello, lazy text world 1325 -- @ 1326 writeLazyText :: MonadSnap m => LT.Text -> m () 1327 writeLazyText = writeLBS . LT.encodeUtf8 1328 {-# INLINE writeLazyText #-} 1329 1330 1331 ------------------------------------------------------------------------------ 1332 -- | Sets the output to be the contents of the specified file. 1333 -- 1334 -- Calling 'sendFile' will overwrite any output queued to be sent in the 1335 -- 'Response'. If the response body is not modified after the call to 1336 -- 'sendFile', Snap will use the efficient @sendfile()@ system call on 1337 -- platforms that support it. 1338 -- 1339 -- If the response body is modified (using 'modifyResponseBody'), the file 1340 -- will be read using @mmap()@. 1341 -- 1342 -- Example: 1343 -- 1344 -- @ 1345 -- ghci> :set -XOverloadedStrings 1346 -- ghci> import qualified "Data.Map" as M 1347 -- ghci> import qualified "Snap.Test" as T 1348 -- ghci> 'writeFile' \"\/tmp\/snap-file\" \"Hello, sendFile world\" 1349 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1350 -- ghci> T.runHandler r ('sendFile' \"\/tmp\/snap-file\") 1351 -- HTTP\/1.1 200 OK 1352 -- content-length: 21 1353 -- server: Snap\/test 1354 -- date: Wed, 06 Aug 2014 17:45:10 GMT 1355 -- Content-Length: 21 1356 -- 1357 -- Hello, sendFile world 1358 -- @ 1359 sendFile :: (MonadSnap m) => FilePath -> m () 1360 sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f Nothing } 1361 1362 1363 ------------------------------------------------------------------------------ 1364 -- | Sets the output to be the contents of the specified file, within the 1365 -- given (start,end) range. 1366 -- 1367 -- Calling 'sendFilePartial' will overwrite any output queued to be sent in 1368 -- the 'Response'. If the response body is not modified after the call to 1369 -- 'sendFilePartial', Snap will use the efficient @sendfile()@ system call on 1370 -- platforms that support it. 1371 -- 1372 -- If the response body is modified (using 'modifyResponseBody'), the file 1373 -- will be read using @mmap()@. 1374 -- 1375 -- Example: 1376 -- 1377 -- @ 1378 -- ghci> :set -XOverloadedStrings 1379 -- ghci> import qualified "Data.Map" as M 1380 -- ghci> import qualified "Snap.Test" as T 1381 -- ghci> 'writeFile' \"\/tmp\/snap-file\" \"Hello, sendFilePartial world\" 1382 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1383 -- ghci> T.runHandler r ('sendFilePartial' \"\/tmp\/snap-file\" (7, 28)) 1384 -- HTTP\/1.1 200 OK 1385 -- content-length: 21 1386 -- server: Snap\/test 1387 -- date: Wed, 06 Aug 2014 17:47:20 GMT 1388 -- Content-Length: 21 1389 -- 1390 -- sendFilePartial world 1391 -- @ 1392 sendFilePartial :: (MonadSnap m) => FilePath -> (Word64, Word64) -> m () 1393 sendFilePartial f rng = modifyResponse $ \r -> 1394 r { rspBody = SendFile f (Just rng) } 1395 1396 1397 ------------------------------------------------------------------------------ 1398 -- | Runs a 'Snap' action with a locally-modified 'Request' state 1399 -- object. The 'Request' object in the Snap monad state after the call 1400 -- to localRequest will be unchanged. 1401 -- Example: 1402 -- 1403 -- @ 1404 -- ghci> :set -XOverloadedStrings 1405 -- ghci> import qualified "Data.Map" as M 1406 -- ghci> import qualified "Snap.Test" as T 1407 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1408 -- ghci> r\' \<- T.buildRequest $ T.get \"\/bar\/foo\" M.empty 1409 -- ghci> let printRqURI = 'getsRequest' 'rqURI' >>= 'writeBS' >> 'writeBS' \"\\n\" 1410 -- ghci> T.runHandler r (printRqURI >> 'localRequest' (const r\') printRqURI) 1411 -- HTTP\/1.1 200 OK 1412 -- server: Snap\/test 1413 -- date: Wed, 06 Aug 2014 15:34:12 GMT 1414 -- 1415 -- \/foo\/bar 1416 -- \/bar\/foo 1417 -- 1418 -- @ 1419 localRequest :: MonadSnap m => (Request -> Request) -> m a -> m a 1420 localRequest f m = do 1421 req <- getRequest 1422 1423 runAct req <|> (putRequest req >> pass) 1424 1425 where 1426 runAct req = do 1427 modifyRequest f 1428 result <- m 1429 putRequest req 1430 return result 1431 {-# INLINE localRequest #-} 1432 1433 1434 ------------------------------------------------------------------------------ 1435 -- | Fetches the 'Request' from state and hands it to the given action. 1436 -- Example: 1437 -- 1438 -- @ 1439 -- ghci> :set -XOverloadedStrings 1440 -- ghci> import qualified "Data.Map" as M 1441 -- ghci> import qualified "Snap.Test" as T 1442 -- ghci> import "Control.Monad.IO.Class" 1443 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1444 -- ghci> let h = 'withRequest' (\\rq -> 'liftIO' (T.requestToString rq) >>= 'writeBS') 1445 -- ghci> T.runHandler r h 1446 -- HTTP\/1.1 200 OK 1447 -- server: Snap\/test 1448 -- date: Wed, 06 Aug 2014 15:44:24 GMT 1449 -- 1450 -- GET \/foo\/bar HTTP\/1.1 1451 -- host: localhost 1452 -- 1453 -- 1454 -- @ 1455 withRequest :: MonadSnap m => (Request -> m a) -> m a 1456 withRequest = (getRequest >>=) 1457 {-# INLINE withRequest #-} 1458 1459 1460 ------------------------------------------------------------------------------ 1461 -- | Fetches the 'Response' from state and hands it to the given action. 1462 -- Example: 1463 -- 1464 -- @ 1465 -- ghci> :set -XOverloadedStrings 1466 -- ghci> import qualified "Data.Map" as M 1467 -- ghci> import qualified "Snap.Test" as T 1468 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1469 -- ghci> T.runHandler r ('withResponse' $ 'writeBS' . 'rspStatusReason') 1470 -- HTTP\/1.1 200 OK 1471 -- server: Snap\/test 1472 -- date: Wed, 06 Aug 2014 15:48:45 GMT 1473 -- 1474 -- OK 1475 -- @ 1476 withResponse :: MonadSnap m => (Response -> m a) -> m a 1477 withResponse = (getResponse >>=) 1478 {-# INLINE withResponse #-} 1479 1480 1481 ------------------------------------------------------------------------------ 1482 -- | Modifies the 'Request' in the state to set the 'rqRemoteAddr' 1483 -- field to the value in the X-Forwarded-For header. If the header is 1484 -- not present, this action has no effect. 1485 -- 1486 -- This action should be used only when working behind a reverse http 1487 -- proxy that sets the X-Forwarded-For header. This is the only way to 1488 -- ensure the value in the X-Forwarded-For header can be trusted. 1489 -- 1490 -- This is provided as a filter so actions that require the remote 1491 -- address can get it in a uniform manner. It has specifically limited 1492 -- functionality to ensure that its transformation can be trusted, 1493 -- when used correctly. 1494 ipHeaderFilter :: MonadSnap m => m () 1495 ipHeaderFilter = ipHeaderFilter' "x-forwarded-for" 1496 1497 1498 ------------------------------------------------------------------------------ 1499 -- | Modifies the 'Request' in the state to set the 'rqRemoteAddr' 1500 -- field to the value from the header specified. If the header 1501 -- specified is not present, this action has no effect. 1502 -- 1503 -- This action should be used only when working behind a reverse http 1504 -- proxy that sets the header being looked at. This is the only way to 1505 -- ensure the value in the header can be trusted. 1506 -- 1507 -- This is provided as a filter so actions that require the remote 1508 -- address can get it in a uniform manner. It has specifically limited 1509 -- functionality to ensure that its transformation can be trusted, 1510 -- when used correctly. 1511 ipHeaderFilter' :: MonadSnap m => CI ByteString -> m () 1512 ipHeaderFilter' header = do 1513 headerContents <- getHeader header <$> getRequest 1514 1515 let whitespace = [ ' ', '\t', '\r', '\n' ] 1516 ipChrs = '.' : "0123456789" 1517 trim f s = f (`elem` s) 1518 1519 clean = trim S.takeWhile ipChrs . trim S.dropWhile whitespace 1520 setIP ip = modifyRequest $ \rq -> rq { rqClientAddr = clean ip } 1521 maybe (return $! ()) setIP headerContents 1522 1523 1524 ------------------------------------------------------------------------------ 1525 -- | This function brackets a Snap action in resource acquisition and 1526 -- release. This is provided because MonadCatchIO's 'bracket' function 1527 -- doesn't work properly in the case of a short-circuit return from 1528 -- the action being bracketed. 1529 -- 1530 -- In order to prevent confusion regarding the effects of the 1531 -- aquisition and release actions on the Snap state, this function 1532 -- doesn't accept Snap actions for the acquire or release actions. 1533 -- 1534 -- This function will run the release action in all cases where the 1535 -- acquire action succeeded. This includes the following behaviors 1536 -- from the bracketed Snap action. 1537 -- 1538 -- 1. Normal completion 1539 -- 1540 -- 2. Short-circuit completion, either from calling 'fail' or 'finishWith' 1541 -- 1542 -- 3. An exception being thrown. 1543 -- 1544 -- Example: 1545 -- 1546 -- @ 1547 -- ghci> :set -XOverloadedStrings 1548 -- ghci> import qualified "Data.Map" as M 1549 -- ghci> import qualified "Snap.Test" as T 1550 -- ghci> let br = 'bracketSnap' (putStrLn \"before\") (const $ putStrLn \"after\") 1551 -- ghci> T.runHandler (T.get \"/\" M.empty) (br $ const $ writeBS \"OK\") 1552 -- before 1553 -- after 1554 -- HTTP\/1.1 200 OK 1555 -- server: Snap\/test 1556 -- date: Thu, 07 Aug 2014 18:41:50 GMT 1557 -- 1558 -- OK 1559 -- @ 1560 bracketSnap :: IO a -> (a -> IO b) -> (a -> Snap c) -> Snap c 1561 bracketSnap before after thing = mask $ \restore -> 1562 stateTToSnap $ do 1563 a <- liftIO before 1564 let after' = liftIO $ after a 1565 r <- snapToStateT (restore $ thing a) `onException` after' 1566 _ <- after' 1567 return r 1568 1569 1570 ------------------------------------------------------------------------------ 1571 -- | This exception is thrown if the handler you supply to 'runSnap' fails. 1572 data NoHandlerException = NoHandlerException String 1573 deriving (Eq, Typeable) 1574 1575 1576 ------------------------------------------------------------------------------ 1577 instance Show NoHandlerException where 1578 show (NoHandlerException e) = "No handler for request: failure was " ++ e 1579 1580 1581 ------------------------------------------------------------------------------ 1582 instance Exception NoHandlerException 1583 1584 1585 ------------------------------------------------------------------------------ 1586 -- | Terminate the HTTP session with the given exception. 1587 -- 1588 -- Example: 1589 -- 1590 -- @ 1591 -- ghci> :set -XOverloadedStrings 1592 -- ghci> import qualified "Data.Map" as M 1593 -- ghci> import qualified "Snap.Test" as T 1594 -- ghci> import qualified "Control.Exception" as E 1595 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 1596 -- ghci> T.runHandler r (terminateConnection $ E.AssertionFailed \"Assertion failed!\") 1597 -- *** Exception: \<terminated: Assertion failed!> 1598 -- @ 1599 terminateConnection :: (Exception e, MonadSnap m) => e -> m a 1600 terminateConnection e = 1601 liftSnap $ Snap $ \_ fk -> fk $ EscapeSnap $ TerminateConnection 1602 $ SomeException e 1603 1604 1605 ------------------------------------------------------------------------------ 1606 -- | Terminate the HTTP session and hand control to some external handler, 1607 -- escaping all further HTTP traffic. 1608 -- 1609 -- The external handler takes three arguments: a function to modify the thread's 1610 -- timeout, and a read and a write ends to the socket. 1611 escapeHttp :: MonadSnap m => 1612 EscapeHttpHandler 1613 -> m () 1614 escapeHttp h = liftSnap $ Snap $ \_ fk st -> fk (EscapeSnap $ EscapeHttp h) st 1615 1616 1617 ------------------------------------------------------------------------------ 1618 -- | Runs a 'Snap' monad action. 1619 -- 1620 -- This function is mostly intended for library writers; instead of invoking 1621 -- 'runSnap' directly, use 'Snap.Http.Server.httpServe' or 1622 -- 'Snap.Test.runHandler' (for testing). 1623 runSnap :: Snap a -- ^ Action to run. 1624 -> (ByteString -> IO ()) -- ^ Error logging action. 1625 -> ((Int -> Int) -> IO ()) -- ^ Timeout action. 1626 -> Request -- ^ HTTP request. 1627 -> IO (Request, Response) 1628 runSnap (Snap m) logerr timeoutAction req = 1629 m ok diediedie ss 1630 where 1631 ok _ st = return (_snapRequest st, _snapResponse st) 1632 1633 diediedie z !st = do 1634 resp <- case z of 1635 PassOnProcessing -> return fourohfour 1636 (EarlyTermination x) -> return x 1637 (EscapeSnap e) -> throwIO e 1638 return (_snapRequest st, resp) 1639 1640 -------------------------------------------------------------------------- 1641 fourohfour = do 1642 clearContentLength $ 1643 setResponseStatus 404 "Not Found" $ 1644 setResponseBody enum404 $ 1645 emptyResponse 1646 1647 -------------------------------------------------------------------------- 1648 enum404 out = do 1649 is <- Streams.fromList html 1650 Streams.connect is out 1651 return out 1652 1653 -------------------------------------------------------------------------- 1654 html = map byteString [ "<!DOCTYPE html>\n" 1655 , "<html>\n" 1656 , "<head>\n" 1657 , "<title>Not found</title>\n" 1658 , "</head>\n" 1659 , "<body>\n" 1660 , "<code>No handler accepted \"" 1661 , rqURI req 1662 , "\"</code>\n</body></html>" 1663 ] 1664 1665 -------------------------------------------------------------------------- 1666 dresp = emptyResponse 1667 1668 -------------------------------------------------------------------------- 1669 ss = SnapState req dresp logerr timeoutAction 1670 {-# INLINE runSnap #-} 1671 1672 1673 1674 -------------------------------------------------------------------------- 1675 -- | Post-process a finalized HTTP response: 1676 -- 1677 -- * fixup content-length header 1678 -- * properly handle 204/304 responses 1679 -- * if request was HEAD, remove response body 1680 -- 1681 -- Note that we do NOT deal with transfer-encoding: chunked or "connection: 1682 -- close" here. 1683 -- 1684 {-# INLINE fixupResponse #-} 1685 fixupResponse :: Request -> Response -> IO Response 1686 fixupResponse req rsp = {-# SCC "fixupResponse" #-} do 1687 rsp' <- case rspBody rsp of 1688 (Stream _) -> return rsp 1689 (SendFile f Nothing) -> setFileSize f rsp 1690 (SendFile _ (Just (s,e))) -> return $! setContentLength (e-s) rsp 1691 let !cl = if noBody then Nothing else rspContentLength rsp' 1692 let rsp'' = if noBody 1693 then rsp' { rspBody = Stream $ return . id 1694 , rspContentLength = Nothing 1695 } 1696 else rsp' 1697 return $! updateHeaders (H.fromList . addCL cl . fixup . H.toList) rsp'' 1698 1699 where 1700 -------------------------------------------------------------------------- 1701 addCL Nothing xs = xs 1702 addCL (Just cl) xs = ("content-length", word64ToByteString cl):xs 1703 1704 -------------------------------------------------------------------------- 1705 setFileSize :: FilePath -> Response -> IO Response 1706 setFileSize fp r = {-# SCC "setFileSize" #-} do 1707 fs <- liftM fromIntegral $ getFileSize fp 1708 return $! r { rspContentLength = Just fs } 1709 1710 ------------------------------------------------------------------------------ 1711 getFileSize :: FilePath -> IO FileOffset 1712 getFileSize fp = liftM fileSize $ getFileStatus fp 1713 1714 code = rspStatus rsp 1715 noBody = code == 204 || code == 304 || rqMethod req == HEAD 1716 1717 ------------------------------------------------------------------------------ 1718 fixup [] = [] 1719 fixup (("date",_):xs) = fixup xs 1720 fixup (("content-length",_):xs) = fixup xs 1721 fixup (x@("transfer-encoding",_):xs) = if noBody 1722 then fixup xs 1723 else x : fixup xs 1724 fixup (x:xs) = x : fixup xs 1725 1726 1727 ------------------------------------------------------------------------------ 1728 -- This number code stolen and massaged from Bryan's blog post: 1729 -- http://www.serpentine.com/blog/2013/03/20/whats-good-for-c-is-good-for-haskell/ 1730 1731 {-# INLINE countDigits #-} 1732 countDigits :: Word64 -> Int 1733 countDigits v0 = go 1 v0 1734 where go !k v 1735 | v < 10 = k 1736 | v < 100 = k + 1 1737 | v < 1000 = k + 2 1738 | v < 10000 = k + 3 1739 | otherwise = go (k+4) (v `quot` 10000) 1740 1741 1742 ------------------------------------------------------------------------------ 1743 {-# INLINE word64ToByteString #-} 1744 word64ToByteString :: Word64 -> ByteString 1745 word64ToByteString d = 1746 #if !MIN_VERSION_bytestring(0,10,6) 1747 S.inlinePerformIO $ 1748 #else 1749 S.accursedUnutterablePerformIO $ 1750 #endif 1751 if d < 10 1752 then S.create 1 $ \p -> poke p (i2w d) 1753 else let !n = countDigits d 1754 in S.create n $ posDecimal n d 1755 1756 1757 {-# INLINE posDecimal #-} 1758 posDecimal :: Int -> Word64 -> Ptr Word8 -> IO () 1759 posDecimal !n0 !v0 !op0 = go n0 (plusPtr op0 (n0-1)) v0 1760 where go !n !op !v 1761 | n == 1 = poke op $! i2w v 1762 | otherwise = do 1763 let (!v', !d) = divMod v 10 1764 poke op $! i2w d 1765 go (n-1) (plusPtr op (-1)) v' 1766 1767 1768 {-# INLINE i2w #-} 1769 i2w :: Word64 -> Word8 1770 i2w v = 48 + fromIntegral v 1771 1772 1773 ------------------------------------------------------------------------------ 1774 evalSnap :: Snap a 1775 -> (ByteString -> IO ()) 1776 -> ((Int -> Int) -> IO ()) 1777 -> Request 1778 -> IO a 1779 evalSnap (Snap m) logerr timeoutAction req = 1780 m (\v _ -> return v) diediedie ss 1781 where 1782 diediedie z _ = case z of 1783 PassOnProcessing -> throwIO $ NoHandlerException "pass" 1784 (EarlyTermination _) -> throwIO $ ErrorCall "no value" 1785 (EscapeSnap e) -> throwIO e 1786 1787 dresp = emptyResponse 1788 ss = SnapState req dresp logerr timeoutAction 1789 {-# INLINE evalSnap #-} 1790 1791 1792 ------------------------------------------------------------------------------ 1793 getParamFrom :: MonadSnap m => 1794 (ByteString -> Request -> Maybe [ByteString]) 1795 -> ByteString 1796 -> m (Maybe ByteString) 1797 getParamFrom f k = do 1798 rq <- getRequest 1799 return $! liftM (S.intercalate " ") $ f k rq 1800 {-# INLINE getParamFrom #-} 1801 1802 1803 ------------------------------------------------------------------------------ 1804 -- | See 'rqParam'. Looks up a value for the given named parameter in the 1805 -- 'Request'. If more than one value was entered for the given parameter name, 1806 -- 'getParam' gloms the values together with @'S.intercalate' \" \"@. 1807 -- 1808 -- Example: 1809 -- 1810 -- @ 1811 -- ghci> :set -XOverloadedStrings 1812 -- ghci> import qualified "Data.Map" as M 1813 -- ghci> import qualified "Snap.Test" as T 1814 -- ghci> import qualified "Data.ByteString.Char8" as B8 1815 -- ghci> let r = T.get \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])] 1816 -- ghci> T.runHandler r ('getParam' \"foo\" >>= 'writeBS' . B8.pack . show) 1817 -- HTTP\/1.1 200 OK 1818 -- server: Snap\/test 1819 -- date: Mon, 11 Aug 2014 12:57:20 GMT 1820 -- 1821 -- Just \"bar\" 1822 -- @ 1823 getParam :: MonadSnap m 1824 => ByteString -- ^ parameter name to look up 1825 -> m (Maybe ByteString) 1826 getParam = getParamFrom rqParam 1827 {-# INLINE getParam #-} 1828 1829 1830 ------------------------------------------------------------------------------ 1831 -- | See 'rqPostParam'. Looks up a value for the given named parameter in the 1832 -- POST form parameters mapping in 'Request'. If more than one value was 1833 -- entered for the given parameter name, 'getPostParam' gloms the values 1834 -- together with: @'S.intercalate' \" \"@. 1835 -- 1836 -- Example: 1837 -- 1838 -- @ 1839 -- ghci> :set -XOverloadedStrings 1840 -- ghci> import qualified "Data.Map" as M 1841 -- ghci> import qualified "Snap.Test" as T 1842 -- ghci> import qualified "Data.ByteString.Char8" as B8 1843 -- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])] 1844 -- ghci> T.runHandler r ('getPostParam' \"foo\" >>= 'writeBS' . B8.pack . show) 1845 -- HTTP\/1.1 200 OK 1846 -- server: Snap\/test 1847 -- date: Mon, 11 Aug 2014 13:01:04 GMT 1848 -- 1849 -- Just \"bar\" 1850 -- @ 1851 getPostParam :: MonadSnap m 1852 => ByteString -- ^ parameter name to look up 1853 -> m (Maybe ByteString) 1854 getPostParam = getParamFrom rqPostParam 1855 {-# INLINE getPostParam #-} 1856 1857 1858 ------------------------------------------------------------------------------ 1859 -- | See 'rqQueryParam'. Looks up a value for the given named parameter in the 1860 -- query string parameters mapping in 'Request'. If more than one value was 1861 -- entered for the given parameter name, 'getQueryParam' gloms the values 1862 -- together with @'S.intercalate' \" \"@. 1863 -- 1864 -- Example: 1865 -- 1866 -- @ 1867 -- ghci> :set -XOverloadedStrings 1868 -- ghci> import qualified "Data.Map" as M 1869 -- ghci> import qualified "Snap.Test" as T 1870 -- ghci> import qualified "Data.ByteString.Char8" as B8 1871 -- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" M.empty >> T.setQueryStringRaw \"foo=bar&foo=baz\" 1872 -- ghci> T.runHandler r ('getQueryParam' \"foo\" >>= 'writeBS' . B8.pack . show) 1873 -- HTTP\/1.1 200 OK 1874 -- server: Snap\/test 1875 -- date: Mon, 11 Aug 2014 13:06:50 GMT 1876 -- 1877 -- Just \"bar baz\" 1878 -- @ 1879 getQueryParam :: MonadSnap m 1880 => ByteString -- ^ parameter name to look up 1881 -> m (Maybe ByteString) 1882 getQueryParam = getParamFrom rqQueryParam 1883 {-# INLINE getQueryParam #-} 1884 1885 1886 ------------------------------------------------------------------------------ 1887 -- | See 'rqParams'. Convenience function to return 'Params' from the 1888 -- 'Request' inside of a 'MonadSnap' instance. 1889 -- 1890 -- Example: 1891 -- 1892 -- @ 1893 -- ghci> :set -XOverloadedStrings 1894 -- ghci> import qualified "Data.Map" as M 1895 -- ghci> import qualified "Snap.Test" as T 1896 -- ghci> import qualified "Data.ByteString.Char8" as B8 1897 -- ghci> let r = T.get \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])] 1898 -- ghci> T.runHandler r ('getParams' >>= 'writeBS' . B8.pack . show) 1899 -- HTTP\/1.1 200 OK 1900 -- server: Snap\/test 1901 -- date: Mon, 11 Aug 2014 13:02:54 GMT 1902 -- 1903 -- fromList [(\"foo\",[\"bar\"])] 1904 -- @ 1905 getParams :: MonadSnap m => m Params 1906 getParams = getRequest >>= return . rqParams 1907 1908 1909 ------------------------------------------------------------------------------ 1910 -- | See 'rqParams'. Convenience function to return 'Params' from the 1911 -- 'Request' inside of a 'MonadSnap' instance. 1912 -- 1913 -- Example: 1914 -- 1915 -- @ 1916 -- ghci> :set -XOverloadedStrings 1917 -- ghci> import qualified "Data.Map" as M 1918 -- ghci> import qualified "Snap.Test" as T 1919 -- ghci> import qualified "Data.ByteString.Char8" as B8 1920 -- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" $ M.fromList [(\"foo\", [\"bar\"])] 1921 -- ghci> T.runHandler r ('getPostParams' >>= 'writeBS' . B8.pack . show) 1922 -- HTTP/1.1 200 OK 1923 -- server: Snap/test 1924 -- date: Mon, 11 Aug 2014 13:04:34 GMT 1925 -- 1926 -- fromList [("foo",["bar"])] 1927 -- @ 1928 getPostParams :: MonadSnap m => m Params 1929 getPostParams = getRequest >>= return . rqPostParams 1930 1931 1932 ------------------------------------------------------------------------------ 1933 -- | See 'rqParams'. Convenience function to return 'Params' from the 1934 -- 'Request' inside of a 'MonadSnap' instance. 1935 -- 1936 -- Example: 1937 -- 1938 -- @ 1939 -- ghci> :set -XOverloadedStrings 1940 -- ghci> import qualified "Data.Map" as M 1941 -- ghci> import qualified "Snap.Test" as T 1942 -- ghci> import qualified "Data.ByteString.Char8" as B8 1943 -- ghci> let r = T.postUrlEncoded \"\/foo\/bar\" M.empty >> T.setQueryStringRaw \"foo=bar&foo=baz\" 1944 -- ghci> T.runHandler r ('getQueryParams' >>= 'writeBS' . B8.pack . show) 1945 -- HTTP\/1.1 200 OK 1946 -- server: Snap\/test 1947 -- date: Mon, 11 Aug 2014 13:10:17 GMT 1948 -- 1949 -- fromList [(\"foo\",[\"bar\",\"baz\"])] 1950 -- @ 1951 getQueryParams :: MonadSnap m => m Params 1952 getQueryParams = getRequest >>= return . rqQueryParams 1953 1954 1955 ------------------------------------------------------------------------------ 1956 -- | Gets the HTTP 'Cookie' with the specified name. 1957 -- 1958 -- Example: 1959 -- 1960 -- @ 1961 -- ghci> :set -XOverloadedStrings 1962 -- ghci> import qualified "Data.Map" as M 1963 -- ghci> import qualified "Snap.Test" as T 1964 -- ghci> import qualified "Data.ByteString.Char8" as B8 1965 -- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False 1966 -- ghci> let r = T.get \"\/foo\/bar\" M.empty >> T.addCookies [cookie] 1967 -- ghci> T.runHandler r ('getCookie' \"name\" >>= 'writeBS' . B8.pack . show) 1968 -- HTTP/1.1 200 OK 1969 -- server: Snap/test 1970 -- date: Thu, 07 Aug 2014 12:16:58 GMT 1971 -- 1972 -- Just (Cookie {cookieName = "name", cookieValue = "value", ...}) 1973 -- @ 1974 getCookie :: MonadSnap m 1975 => ByteString 1976 -> m (Maybe Cookie) 1977 getCookie name = withRequest $ 1978 return . listToMaybe . filter (\c -> cookieName c == name) . rqCookies 1979 1980 1981 ------------------------------------------------------------------------------ 1982 -- | Gets the HTTP 'Cookie' with the specified name and decodes it. If the 1983 -- decoding fails, the handler calls pass. 1984 -- 1985 -- Example: 1986 -- 1987 -- @ 1988 -- ghci> :set -XOverloadedStrings 1989 -- ghci> import qualified "Data.Map" as M 1990 -- ghci> import qualified "Snap.Test" as T 1991 -- ghci> let cookie = 'Cookie' \"name\" \"value\" Nothing Nothing Nothing False False 1992 -- ghci> let r = T.get \"\/foo\/bar\" M.empty >> T.addCookies [cookie] 1993 -- ghci> T.runHandler r ('readCookie' \"name\" >>= 'writeBS') 1994 -- HTTP/1.1 200 OK 1995 -- server: Snap/test 1996 -- date: Thu, 07 Aug 2014 12:20:09 GMT 1997 -- 1998 -- value 1999 -- @ 2000 readCookie :: (MonadSnap m, R.Readable a) 2001 => ByteString 2002 -> m a 2003 readCookie name = maybe pass (R.fromBS . cookieValue) =<< getCookie name 2004 2005 2006 ------------------------------------------------------------------------------ 2007 -- | Expire given 'Cookie' in client's browser. 2008 -- 2009 -- Example: 2010 -- 2011 -- @ 2012 -- ghci> :set -XOverloadedStrings 2013 -- ghci> import qualified "Data.Map" as M 2014 -- ghci> import qualified "Snap.Test" as T 2015 -- ghci> let r = T.get \"\/foo\/bar\" M.empty 2016 -- ghci> let cookie = Cookie "name" "" Nothing (Just "/subsite") Nothing True False 2017 -- ghci> T.runHandler r ('expireCookie' cookie) 2018 -- HTTP/1.1 200 OK 2019 -- set-cookie: name=; path=/subsite; expires=Sat, 24 Dec 1994 06:28:16 GMT; Secure 2020 -- server: Snap/test 2021 -- 2022 -- date: Thu, 07 Aug 2014 12:21:27 GMT 2023 -- ghci> let cookie = Cookie "name" "value" Nothing Nothing Nothing False False 2024 -- ghci> let r2 = T.get \"\/foo\/bar\" M.empty >> T.addCookies [cookie] 2025 -- ghci> T.runHandler r ('getCookie' "name" >>= maybe (return ()) 'expireCookie') 2026 -- HTTP/1.1 200 OK 2027 -- set-cookie: name=; expires=Sat, 24 Dec 1994 06:28:16 GMT 2028 -- server: Snap/test 2029 -- 2030 -- 2031 -- @ 2032 expireCookie :: (MonadSnap m) => Cookie -> m () 2033 expireCookie cookie = do 2034 let old = UTCTime (ModifiedJulianDay 0) 0 2035 modifyResponse $ addResponseCookie 2036 $ cookie { cookieValue = "" 2037 , cookieExpires = (Just old) } 2038 2039 ------------------------------------------------------------------------------ 2040 -- | Causes the handler thread to be killed @n@ seconds from now. 2041 setTimeout :: MonadSnap m => Int -> m () 2042 setTimeout = modifyTimeout . const 2043 2044 2045 ------------------------------------------------------------------------------ 2046 -- | Causes the handler thread to be killed at least @n@ seconds from now. 2047 extendTimeout :: MonadSnap m => Int -> m () 2048 extendTimeout = modifyTimeout . max 2049 2050 2051 ------------------------------------------------------------------------------ 2052 -- | Modifies the amount of time remaining before the request times out. 2053 modifyTimeout :: MonadSnap m => (Int -> Int) -> m () 2054 modifyTimeout f = do 2055 m <- getTimeoutModifier 2056 liftIO $ m f 2057 2058 2059 ------------------------------------------------------------------------------ 2060 -- | Returns an 'IO' action which you can use to modify the timeout value. 2061 getTimeoutModifier :: MonadSnap m => m ((Int -> Int) -> IO ()) 2062 getTimeoutModifier = liftSnap $ liftM _snapModifyTimeout sget