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