Merge branch 'master' into 0.5

README.SNAP.md

@@ -9,7 +9,7 @@ the Snap project website at http://snapframework.com/.
 Snap Status and Features
 ------------------------
 
-This developer prerelease contains only the Snap core system, namely:
+The Snap core system consists of:
 
   * a high-speed HTTP server, with an optional high-concurrency backend using
     the [libev](http://software.schmorp.de/pkg/libev.html) library

snap-core.cabal

@@ -3,10 +3,9 @@ version:        0.5
 synopsis:       Snap: A Haskell Web Framework (Core)
 
 description:
-  This is the first developer prerelease of the Snap framework.  Snap is a
-  simple and fast web development framework and server written in Haskell. For
-  more information or to download the latest version, you can visit the Snap
-  project website at <http://snapframework.com/>.
+  Snap is a simple and fast web development framework and server written in
+  Haskell. For more information or to download the latest version, you can
+  visit the Snap project website at <http://snapframework.com/>.
   .
   This library contains the core definitions and types for the Snap framework,
   including:
@@ -106,7 +105,7 @@ Library
   else
     c-sources: cbits/timefuncs.c
     include-dirs: cbits
-    build-depends: bytestring-mmap >= 0.2.1 && <0.3
+    build-depends: bytestring-mmap >= 0.2.2 && <0.3
 
   exposed-modules:
     Snap.Types,
@@ -131,7 +130,7 @@ Library
     attoparsec >= 0.8.0.2 && < 0.9,
     attoparsec-enumerator >= 0.2.0.3,
     base >= 4 && < 5,
-    blaze-builder >= 0.2.1.4 && <0.3,
+    blaze-builder >= 0.2.1.4 && <0.4,
     bytestring,
     bytestring-nums,
     case-insensitive >= 0.2 && < 0.3,

src/Snap/Internal/Types.hs

@@ -112,11 +112,15 @@ class (Monad m, MonadIO m, MonadCatchIO m, MonadPlus m, Functor m,
     liftSnap :: Snap a -> m a
 
 
+------------------------------------------------------------------------------
+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)
+    }
 
 
 ------------------------------------------------------------------------------
@@ -129,6 +133,10 @@ data SnapState = SnapState
 
 ------------------------------------------------------------------------------
 instance Monad Snap where
+    (>>=)  = snapBind
+    return = snapReturn
+    fail   = snapFail
+{-
     (Snap m) >>= f =
         Snap $ do
             eth <- m
@@ -139,11 +147,33 @@ instance Monad Snap where
 
     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
 
 
 ------------------------------------------------------------------------------
@@ -160,12 +190,14 @@ instance MonadCatchIO Snap where
 
 ------------------------------------------------------------------------------
 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
 
 
 ------------------------------------------------------------------------------
@@ -204,7 +236,7 @@ instance Typeable1 Snap where
 
 ------------------------------------------------------------------------------
 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)
 
 
 ------------------------------------------------------------------------------
@@ -279,7 +311,7 @@ transformRequestBody trans = do
 -- | 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 #-}
 
 
@@ -292,11 +324,11 @@ finishWith = liftSnap . Snap . return . Just . Left
 -- '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 #-}
 
 
@@ -413,14 +445,14 @@ ifTop = path ""
 ------------------------------------------------------------------------------
 -- | 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 #-}
 
 
@@ -501,7 +533,7 @@ redirect' target status = do
 -- | 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 #-}
 
 
@@ -726,14 +758,10 @@ runSnap :: Snap a
 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)
 
@@ -759,14 +787,11 @@ evalSnap :: Snap a
 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

@@ -85,7 +85,7 @@ module Snap.Iteratee
   , concatEnums
     -- *** Enumeratees
   , checkDone
-  , Data.Enumerator.map
+  , Data.Enumerator.List.map
   , Data.Enumerator.sequence
   , joinI
 
@@ -113,6 +113,7 @@ import           Data.Enumerator hiding (consume, drop, head)
 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)
@@ -129,7 +130,6 @@ import           System.PosixCompat.Files
 import           System.PosixCompat.Types
 #endif
 
-
 ------------------------------------------------------------------------------
 instance (Functor m, MonadCatchIO m) =>
          MonadCatchIO (Iteratee s m) where
@@ -138,12 +138,8 @@ instance (Functor m, MonadCatchIO m) =>
       where
         insideCatch !mm = Iteratee $ do
             ee <- try $ runIteratee mm
-            case ee of 
-                -- if we got an async exception here then the iteratee workflow is
-                -- all messed up, we have no reasonable choice but to send EOF to the
-                -- handler, because the unparsed input got lost. If the enumerator
-                -- sends more chunks we can possibly recover later.
-                (Left e)  -> runIteratee (enumEOF $$ handler e)
+            case ee of
+                (Left e)  -> runIteratee $ handler e
                 (Right v) -> step v
 
         step (Continue !k)  = do
@@ -475,13 +471,6 @@ take' !n st@(Continue k) = do
 takeExactly :: (Monad m)
             => Int64
             -> Enumeratee ByteString ByteString m a
-takeExactly 0   s = do
-    s' <- lift $ runIteratee $ enumEOF s
-    case s' of
-      (Continue _) -> error "divergent iteratee"
-      (Error e)    -> throwError e
-      (Yield v _)  -> yield (Yield v EOF) EOF
-
 takeExactly !n  y@(Yield _ _ ) = drop' n >> return y
 takeExactly _     (Error e   ) = throwError e
 takeExactly !n st@(Continue !k) = do
@@ -655,10 +644,10 @@ mapEnum :: (Monad m) =>
         -> 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

@@ -221,7 +221,11 @@ data DirectoryConfig m = DirectoryConfig {
     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,36 +332,39 @@ defaultIndexGenerator mm styles d = do
 ------------------------------------------------------------------------------
 -- | 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 ()
     }
 
 
 ------------------------------------------------------------------------------
 -- | 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 ()
     }
 
 
 ------------------------------------------------------------------------------
 -- | 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 @@ fancyDirectoryConfig = DirectoryConfig {
     indexFiles = ["index.html", "index.htm"],
     indexGenerator = defaultIndexGenerator defaultMimeTypes snapIndexStyles,
     dynamicHandlers = Map.empty,
-    mimeTypes = defaultMimeTypes
+    mimeTypes = defaultMimeTypes,
+    preServeHook = const $ return ()
     }
 
 
@@ -401,12 +409,13 @@ serveDirectoryWith cfg base = do
     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/snap-core-testsuite.cabal

@@ -17,15 +17,15 @@ Executable testsuite
   else
     c-sources: ../cbits/timefuncs.c
     include-dirs: ../cbits
-    build-depends: bytestring-mmap >= 0.2.1 && <0.3
+    build-depends: bytestring-mmap >= 0.2.2 && <0.3
 
   build-depends:
     QuickCheck >= 2.3.0.2,
     attoparsec >= 0.8.1 && < 0.9,
     attoparsec-enumerator >= 0.2.0.3,
     base >= 4 && < 5,
     base16-bytestring == 0.1.*,
-    blaze-builder >= 0.2.1.4 && <0.3,
+    blaze-builder >= 0.2.1.4 && <0.4,
     bytestring,
     bytestring-nums,
     cereal == 0.3.*,