snap-core 0.4.2 → 0.4.3
raw patch · 5 files changed
+90/−51 lines, 5 files
Files
- snap-core.cabal +1/−1
- src/Snap/Internal/Types.hs +57/−32
- src/Snap/Iteratee.hs +5/−4
- src/Snap/Util/FileServe.hs +19/−10
- test/suite/Snap/Util/FileServe/Tests.hs +8/−4
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.4.2+version: 0.4.3 synopsis: Snap: A Haskell Web Framework (Core) description:
src/Snap/Internal/Types.hs view
@@ -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
src/Snap/Iteratee.hs view
@@ -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 ------------------------------------------------------------------------------
src/Snap/Util/FileServe.hs view
@@ -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,
test/suite/Snap/Util/FileServe/Tests.hs view
@@ -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