From 29261490e7b8a2f7227705202a422a16a8e5e274 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
Date: Thu, 19 May 2011 13:29:53 +0200
Subject: [PATCH] Add preServeHook to DirectoryConfig

---
 src/Snap/Util/FileServe.hs              | 29 ++++++++++++++++---------
 test/suite/Snap/Util/FileServe/Tests.hs | 12 ++++++----
 2 files changed, 27 insertions(+), 14 deletions(-)

diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs
index f0f45719..123f9abc 100644
--- a/src/Snap/Util/FileServe.hs
+++ b/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,13 +332,14 @@ 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 ()
     }
 
 
@@ -342,13 +347,15 @@ simpleDirectoryConfig = DirectoryConfig {
 -- | 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 @@ defaultDirectoryConfig = DirectoryConfig {
 -- | 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,
diff --git a/test/suite/Snap/Util/FileServe/Tests.hs b/test/suite/Snap/Util/FileServe/Tests.hs
index 6ce0db1e..1e138cfe 100644
--- a/test/suite/Snap/Util/FileServe/Tests.hs
+++ b/test/suite/Snap/Util/FileServe/Tests.hs
@@ -224,7 +224,8 @@ testFsCfg = testCase "fileServe/Cfg" $ do
         indexFiles      = [],
         indexGenerator  = const pass,
         dynamicHandlers = Map.empty,
-        mimeTypes       = defaultMimeTypes
+        mimeTypes       = defaultMimeTypes,
+        preServeHook    = const $ return ()
         }
 
     -- Named file in the root directory
@@ -266,7 +267,8 @@ testFsCfg = testCase "fileServe/Cfg" $ do
         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 @@ testFsCfg = testCase "fileServe/Cfg" $ do
         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 @@ testFsCfg = testCase "fileServe/Cfg" $ do
         indexFiles      = [],
         indexGenerator  = const pass,
         dynamicHandlers = Map.fromList [ (".txt", printName) ],
-        mimeTypes       = defaultMimeTypes
+        mimeTypes       = defaultMimeTypes,
+        preServeHook    = const $ return ()
         }
 
     -- Request for file with dynamic handler