This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-website".
The branch, master has been updated
via 04eeb6bb76eaa935252be9946a1732d9e65c10a3 (commit)
from 301c59b738bcd338c79eade6754f77744425ce36 (commit)
Summary of changes:
snap-website.cabal | 1 +
src/Main.hs | 21 +++++++++++++++++++--
2 files changed, 20 insertions(+), 2 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 04eeb6bb76eaa935252be9946a1732d9e65c10a3
Author: Gregory Collins <[email protected]>
Date: Tue Sep 14 22:18:03 2010 -0400
Set cache headers on media resources
diff --git a/snap-website.cabal b/snap-website.cabal
index f38c7a9..2be88d1 100644
--- a/snap-website.cabal
+++ b/snap-website.cabal
@@ -31,6 +31,7 @@ Executable snap-website
snap-server >= 0.2.12 && <0.3,
snap-static-pages >= 0.0.1 && <0.1,
text,
+ time,
transformers,
unix,
utf8-string,
diff --git a/src/Main.hs b/src/Main.hs
index 342bf0b..2bf6635 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,6 +10,7 @@ import qualified Data.ByteString.Char8 as B
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Text as T
+import Data.Time.Clock.POSIX
import Data.Typeable
import Control.Applicative
import Control.Concurrent
@@ -18,6 +19,7 @@ import Control.Monad
import Control.Monad.CatchIO
import "monads-fd" Control.Monad.Trans
import "monads-fd" Control.Monad.Reader
+import Foreign.C.Types
import Prelude hiding (catch)
import Snap.Http.Server
import Snap.StaticPages
@@ -47,6 +49,12 @@ data SiteState = SiteState {
type Site a = ReaderT SiteState Snap a
+epochTime :: IO CTime
+epochTime = do
+ t <- getPOSIXTime
+ return $ fromInteger $ truncate t
+
+
initSiteState :: IO SiteState
initSiteState = do
setLocaleToUTF8
@@ -124,9 +132,18 @@ site ss =
, ("admin/reload", runReaderT reload ss)
, ("blog/", serveStaticPages (_blogState ss)) ] <|>
templateServe (_currentTs ss) <|>
- fileServe "static"
-
+ (setCache $ fileServe "static")
+ where
+ setCache act = do
+ pi <- liftM rqPathInfo getRequest
+ act
+ when ("media" `B.isPrefixOf` pi) $ do
+ expTime <- liftM (+604800) $ liftIO epochTime
+ s <- liftIO $ formatHttpTime expTime
+ modifyResponse $
+ setHeader "Cache-Control" "public, max-age=604800" .
+ setHeader "Expires" s
catch500 :: Snap a -> Snap ()
catch500 m = (m >> return ()) `catch` \(e::SomeException) -> do
-----------------------------------------------------------------------
hooks/post-receive
--
snap-website
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
