diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 0.4.2 +version: 0.4.3 synopsis: Snap: A Haskell Web Framework (Core) description: diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs --- a/src/Snap/Internal/Types.hs +++ b/src/Snap/Internal/Types.hs @@ -112,10 +112,14 @@ ------------------------------------------------------------------------------ +data SnapResult a = PassOnProcessing + | EarlyTermination Response + | SnapValue a + +------------------------------------------------------------------------------ newtype Snap a = Snap { - unSnap :: StateT SnapState (Iteratee ByteString IO) - (Maybe (Either Response a)) -} + unSnap :: StateT SnapState (Iteratee ByteString IO) (SnapResult a) + } ------------------------------------------------------------------------------ @@ -128,6 +132,10 @@ ------------------------------------------------------------------------------ instance Monad Snap where + (>>=) = snapBind + return = snapReturn + fail = snapFail +{- (Snap m) >>= f = Snap $ do eth <- m @@ -138,11 +146,33 @@ return = Snap . return . Just . Right fail = const $ Snap $ return Nothing +-} +------------------------------------------------------------------------------ +snapBind :: Snap a -> (a -> Snap b) -> Snap b +snapBind (Snap m) f = Snap $ do + res <- m + case res of + SnapValue a -> unSnap $ f a + PassOnProcessing -> return PassOnProcessing + EarlyTermination r -> return $! EarlyTermination r +{-# INLINE snapBind #-} + + +snapReturn :: a -> Snap a +snapReturn = Snap . return . SnapValue +{-# INLINE snapReturn #-} + + +snapFail :: String -> Snap a +snapFail _ = Snap $ return PassOnProcessing +{-# INLINE snapFail #-} + + ------------------------------------------------------------------------------ instance MonadIO Snap where - liftIO m = Snap $ liftM (Just . Right) $ liftIO m + liftIO m = Snap $ liftM SnapValue $ liftIO m ------------------------------------------------------------------------------ @@ -159,12 +189,14 @@ ------------------------------------------------------------------------------ instance MonadPlus Snap where - mzero = Snap $ return Nothing + mzero = Snap $ return PassOnProcessing a `mplus` b = Snap $ do - mb <- unSnap a - if isJust mb then return mb else unSnap b + r <- unSnap a + case r of + PassOnProcessing -> unSnap b + _ -> return r ------------------------------------------------------------------------------ @@ -203,7 +235,7 @@ ------------------------------------------------------------------------------ liftIter :: MonadSnap m => Iteratee ByteString IO a -> m a -liftIter i = liftSnap $ Snap (lift i >>= return . Just . Right) +liftIter i = liftSnap $ Snap (lift i >>= return . SnapValue) ------------------------------------------------------------------------------ @@ -278,7 +310,7 @@ -- | Short-circuits a 'Snap' monad action early, storing the given -- 'Response' value in its state. finishWith :: MonadSnap m => Response -> m a -finishWith = liftSnap . Snap . return . Just . Left +finishWith = liftSnap . Snap . return . EarlyTermination {-# INLINE finishWith #-} @@ -291,11 +323,11 @@ -- 'Response' which was passed to the 'finishWith' call. catchFinishWith :: Snap a -> Snap (Either Response a) catchFinishWith (Snap m) = Snap $ do - eth <- m - maybe (return Nothing) - (either (\resp -> return $ Just $ Right $ Left resp) - (\a -> return $ Just $ Right $ Right a)) - eth + r <- m + case r of + PassOnProcessing -> return PassOnProcessing + EarlyTermination resp -> return $! SnapValue $! Left resp + SnapValue a -> return $! SnapValue $! Right a {-# INLINE catchFinishWith #-} @@ -399,14 +431,14 @@ ------------------------------------------------------------------------------ -- | Local Snap version of 'get'. sget :: Snap SnapState -sget = Snap $ liftM (Just . Right) get +sget = Snap $ liftM SnapValue get {-# INLINE sget #-} ------------------------------------------------------------------------------ -- | Local Snap monad version of 'modify'. smodify :: (SnapState -> SnapState) -> Snap () -smodify f = Snap $ modify f >> return (Just $ Right ()) +smodify f = Snap $ modify f >> return (SnapValue ()) {-# INLINE smodify #-} @@ -487,7 +519,7 @@ -- | Log an error message in the 'Snap' monad logError :: MonadSnap m => ByteString -> m () logError s = liftSnap $ Snap $ gets _snapLogError >>= (\l -> liftIO $ l s) - >> return (Just $ Right ()) + >> return (SnapValue ()) {-# INLINE logError #-} @@ -712,14 +744,10 @@ runSnap (Snap m) logerr timeoutAction req = do (r, ss') <- runStateT m ss - e <- maybe (return $ Left fourohfour) - return - r - - -- is this a case of early termination? - let resp = case e of - Left x -> x - Right _ -> _snapResponse ss' + let resp = case r of + PassOnProcessing -> fourohfour + EarlyTermination x -> x + SnapValue _ -> _snapResponse ss' return (_snapRequest ss', resp) @@ -745,14 +773,11 @@ evalSnap (Snap m) logerr timeoutAction req = do (r, _) <- runStateT m ss - e <- maybe (liftIO $ throwIO NoHandlerException) - return - r + case r of + PassOnProcessing -> liftIO $ throwIO NoHandlerException + EarlyTermination _ -> liftIO $ throwIO $ ErrorCall "no value" + SnapValue x -> return x - -- is this a case of early termination? - case e of - Left _ -> liftIO $ throwIO $ ErrorCall "no value" - Right x -> return x where dresp = emptyResponse { rspHttpVersion = rqVersion req } ss = SnapState req dresp logerr timeoutAction diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs --- a/src/Snap/Iteratee.hs +++ b/src/Snap/Iteratee.hs @@ -85,7 +85,7 @@ , concatEnums -- *** Enumeratees , checkDone - , Data.Enumerator.map + , Data.Enumerator.List.map , Data.Enumerator.sequence , joinI @@ -113,6 +113,7 @@ import qualified Data.Enumerator as I import Data.Enumerator.Binary (enumHandle) import Data.Enumerator.List hiding (take, drop) +import qualified Data.Enumerator.List as IL import qualified Data.List as List import Data.Monoid (mappend) import Data.Time.Clock.POSIX (getPOSIXTime) @@ -137,7 +138,7 @@ where insideCatch !mm = Iteratee $ do ee <- try $ runIteratee mm - case ee of + case ee of (Left e) -> runIteratee $ handler e (Right v) -> step v @@ -643,10 +644,10 @@ -> Enumerator aIn m a -> Enumerator aOut m a mapEnum f g enum outStep = do - let z = I.map g outStep + let z = IL.map g outStep let p = joinI z let q = enum $$ p - (I.joinI . I.map f) $$ q + (I.joinI . IL.map f) $$ q ------------------------------------------------------------------------------ diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs --- a/src/Snap/Util/FileServe.hs +++ b/src/Snap/Util/FileServe.hs @@ -221,7 +221,11 @@ dynamicHandlers :: HandlerMap m, -- | MIME type map to look up content types. - mimeTypes :: MimeMap + mimeTypes :: MimeMap, + + -- | Handler that is called before a file is served. It will only be + -- called when a file is actually found, not for generated index pages. + preServeHook :: FilePath -> m () } @@ -328,13 +332,14 @@ ------------------------------------------------------------------------------ -- | A very simple configuration for directory serving. This configuration -- uses built-in MIME types from 'defaultMimeTypes', and has no index files, --- index generator, or dynamic file handlers. +-- index generator, dynamic file handlers, or 'preServeHook'. simpleDirectoryConfig :: MonadSnap m => DirectoryConfig m simpleDirectoryConfig = DirectoryConfig { indexFiles = [], indexGenerator = const pass, dynamicHandlers = Map.empty, - mimeTypes = defaultMimeTypes + mimeTypes = defaultMimeTypes, + preServeHook = const $ return () } @@ -342,13 +347,15 @@ -- | A reasonable default configuration for directory serving. This -- configuration uses built-in MIME types from 'defaultMimeTypes', serves -- common index files @index.html@ and @index.htm@, but does not autogenerate --- directory indexes, nor have any dynamic file handlers. +-- directory indexes, nor have any dynamic file handlers. The 'preServeHook' +-- will not do anything. defaultDirectoryConfig :: MonadSnap m => DirectoryConfig m defaultDirectoryConfig = DirectoryConfig { indexFiles = ["index.html", "index.htm"], indexGenerator = const pass, dynamicHandlers = Map.empty, - mimeTypes = defaultMimeTypes + mimeTypes = defaultMimeTypes, + preServeHook = const $ return () } @@ -356,8 +363,8 @@ -- | A more elaborate configuration for file serving. This configuration -- uses built-in MIME types from 'defaultMimeTypes', serves common index files -- @index.html@ and @index.htm@, and autogenerates directory indexes with a --- Snap-like feel. It still has no dynamic file handlers, which should be --- added as needed. +-- Snap-like feel. It still has no dynamic file handlers, nor 'preServeHook', +-- which should be added as needed. -- -- Files recognized as indexes include @index.html@, @index.htm@, -- @default.html@, @default.htm@, @home.html@ @@ -366,7 +373,8 @@ indexFiles = ["index.html", "index.htm"], indexGenerator = defaultIndexGenerator defaultMimeTypes snapIndexStyles, dynamicHandlers = Map.empty, - mimeTypes = defaultMimeTypes + mimeTypes = defaultMimeTypes, + preServeHook = const $ return () } @@ -401,12 +409,13 @@ generate = indexGenerator cfg mimes = mimeTypes cfg dyns = dynamicHandlers cfg + pshook = preServeHook cfg -- Serves a file if it exists; passes if not serve f = do liftIO (doesFileExist f) >>= flip unless pass - let fname = takeFileName f - let staticServe = do serveFileAs (fileType mimes fname) + let fname = takeFileName f + let staticServe f' = pshook f >> serveFileAs (fileType mimes fname) f' lookupExt staticServe dyns fname f >> return True <|> return False -- Serves a directory via indices if available. Returns True on success, diff --git a/test/suite/Snap/Util/FileServe/Tests.hs b/test/suite/Snap/Util/FileServe/Tests.hs --- a/test/suite/Snap/Util/FileServe/Tests.hs +++ b/test/suite/Snap/Util/FileServe/Tests.hs @@ -224,7 +224,8 @@ indexFiles = [], indexGenerator = const pass, dynamicHandlers = Map.empty, - mimeTypes = defaultMimeTypes + mimeTypes = defaultMimeTypes, + preServeHook = const $ return () } -- Named file in the root directory @@ -266,7 +267,8 @@ indexFiles = ["index.txt", "altindex.html"], indexGenerator = const pass, dynamicHandlers = Map.empty, - mimeTypes = defaultMimeTypes + mimeTypes = defaultMimeTypes, + preServeHook = const $ return () } -- Request for root directory with index @@ -296,7 +298,8 @@ indexFiles = ["index.txt", "altindex.html"], indexGenerator = printName, dynamicHandlers = Map.empty, - mimeTypes = defaultMimeTypes + mimeTypes = defaultMimeTypes, + preServeHook = const $ return () } -- Request for root directory with index @@ -318,7 +321,8 @@ indexFiles = [], indexGenerator = const pass, dynamicHandlers = Map.fromList [ (".txt", printName) ], - mimeTypes = defaultMimeTypes + mimeTypes = defaultMimeTypes, + preServeHook = const $ return () } -- Request for file with dynamic handler