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".
The branch, master has been updated
via 5fa86788d67ff4caace8e892c3ac86532a2fd639 (commit)
from 73dc9738d41c0d6a67e9c7418b795a78211e5f91 (commit)
Summary of changes:
project_template/hint/foo.cabal | 1 +
project_template/hint/src/AppState.hs | 64 +++++++++++++++++++++++++++++++++
project_template/hint/src/Config.hs | 33 -----------------
project_template/hint/src/Main.hs | 14 ++++----
project_template/hint/src/Site.hs | 22 ++++++-----
snap.cabal | 2 +-
src/Snap/Error.hs | 6 ++--
src/Snap/Heist.hs | 5 ++-
src/Snap/Loader/Hint.hs | 3 +-
9 files changed, 93 insertions(+), 57 deletions(-)
create mode 100644 project_template/hint/src/AppState.hs
delete mode 100644 project_template/hint/src/Config.hs
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 5fa86788d67ff4caace8e892c3ac86532a2fd639
Author: Carl Howells <[email protected]>
Date: Wed Jun 30 21:44:12 2010 -0700
Make hint project use the MonadSnap interface
diff --git a/project_template/hint/foo.cabal b/project_template/hint/foo.cabal
index 315be9d..55fc85e 100644
--- a/project_template/hint/foo.cabal
+++ b/project_template/hint/foo.cabal
@@ -24,6 +24,7 @@ Executable projname
Build-depends:
base >= 4 && < 5,
bytestring >= 0.9.1 && < 0.10,
+ MonadCatchIO-transformers >= 0.2.1 && < 0.3,
monads-fd >= 0.1 && < 0.2,
snap >= 0.3 && < 0.4,
snap-core >= 0.3 && < 0.4,
diff --git a/project_template/hint/src/AppState.hs
b/project_template/hint/src/AppState.hs
new file mode 100644
index 0000000..09ec280
--- /dev/null
+++ b/project_template/hint/src/AppState.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- This module contains site-specific state information.
+module AppState (
+ AppState(..)
+ , loadAppState
+ , cleanupAppState
+ , StateSnap
+ , runStateSnap
+ , ask
+ , asks
+)
+where
+
+import Control.Applicative
+import Control.Monad.CatchIO
+import Control.Monad.Reader
+
+import Data.Time.Clock
+import Snap.Types
+import Text.Templating.Heist
+
+
+-- This contains the site configuration. Being a boring sample site,
+-- this is just a boring sample configuration. It has the load time
+-- (to help illustrate config loading differences between development
+-- and production modes) and the TemplateState used for rendering
+-- Heist templates.
+data AppState = AppState {
+ loadTime :: UTCTime
+ , templateState :: TemplateState StateSnap
+ }
+
+
+newtype StateSnap a = AS (ReaderT AppState Snap a)
+ deriving ( Monad
+ , MonadReader AppState
+ , MonadSnap
+ , MonadPlus
+ , MonadCatchIO
+ , MonadIO
+ , Applicative
+ , Alternative
+ , Functor
+ )
+
+
+runStateSnap :: StateSnap a -> AppState -> Snap a
+runStateSnap (AS rt) st = runReaderT rt st
+
+
+-- loads the heist TemplateState, and gets the current time.
+loadAppState :: IO AppState
+loadAppState = do
+ time <- getCurrentTime
+ let ets = loadTemplates "resources/templates" emptyTemplateState
+ either error (AppState time) <$> ets
+
+
+-- Doesn't actually do anything. This is a placeholder for tasks like
+-- releasing database connections, or cleaning up anything else that
+-- might have been included in the config.
+cleanupAppState :: AppState -> IO ()
+cleanupAppState _ = return ()
diff --git a/project_template/hint/src/Config.hs
b/project_template/hint/src/Config.hs
deleted file mode 100644
index ca6ed62..0000000
--- a/project_template/hint/src/Config.hs
+++ /dev/null
@@ -1,33 +0,0 @@
--- This module contains site-specific configuration information.
-module Config where
-
-import Control.Applicative ((<$>))
-import Data.Time.Clock
-import Snap.Types
-import Text.Templating.Heist
-
-
--- This contains the site configuration. Being a boring sample site,
--- this is just a boring sample configuration. It has the load time
--- (to help illustrate config loading differences between development
--- and production modes) and the TemplateState used for rendering
--- Heist templates.
-data Config = Config {
- loadTime :: UTCTime
- , templateState :: TemplateState Snap
- }
-
-
--- loads the heist TemplateState, and gets the current time.
-getConfig :: IO Config
-getConfig = do
- time <- getCurrentTime
- let ets = loadTemplates "resources/templates" emptyTemplateState
- either error (Config time) <$> ets
-
-
--- Doesn't actually do anything. This is a placeholder for tasks like
--- releasing database connections, or cleaning up anything else that
--- might have been included in the config.
-cleanupConfig :: Config -> IO ()
-cleanupConfig _ = return ()
diff --git a/project_template/hint/src/Main.hs
b/project_template/hint/src/Main.hs
index 9627727..a891683 100644
--- a/project_template/hint/src/Main.hs
+++ b/project_template/hint/src/Main.hs
@@ -3,7 +3,7 @@ module Main where
import Data.Monoid (mappend, mempty)
-import Config (getConfig, cleanupConfig)
+import AppState (cleanupAppState, loadAppState)
import Site (site)
import Snap.Http.Server
@@ -49,16 +49,16 @@ main = do
--
-- The most significant behavioral differences between the two
-- loaders are how the action is determined, and when the
- -- getConfig and cleanupConfig functions are killed.
+ -- loadAppState and cleanupAppState functions are executed.
--
-- The Hint loader uses the ghc api to interpret the sources when
- -- pages are loaded. It also runs getConfig and cleanupConfig for
- -- each request it handles.
+ -- pages are loaded. It also runs loadAppState and
+ -- cleanupAppState for each request it handles.
--
-- The Static loader compiles all the actions when the app is
- -- compiled. It runs getConfig once, at the start of the program,
- -- and cleanupConfig once, at the end of the program.
- (cleanup, snap) <- $(loadSnapTH 'getConfig 'cleanupConfig 'site)
+ -- compiled. It runs loadAppState once, at the start of the
+ -- program, and cleanupAppState once, at the end of the program.
+ (cleanup, snap) <- $(loadSnapTH 'loadAppState 'cleanupAppState 'site)
-- Run the server
httpServeConfig conf snap
diff --git a/project_template/hint/src/Site.hs
b/project_template/hint/src/Site.hs
index cc55423..1d143ba 100644
--- a/project_template/hint/src/Site.hs
+++ b/project_template/hint/src/Site.hs
@@ -1,8 +1,9 @@
{-# LANGUAGE OverloadedStrings #-}
module Site where
-import Config
+import AppState
+import Control.Arrow ((&&&))
import Control.Monad (msum)
import Control.Monad.Trans (liftIO)
@@ -17,23 +18,24 @@ import Snap.Types
import Text.Templating.Heist
-frontPage :: Config -> Snap ()
-frontPage config = ifTop $ do
+frontPage :: StateSnap ()
+frontPage = ifTop $ do
time <- liftIO getCurrentTime
+ (ts, lt) <- asks (templateState &&& loadTime)
- let [loadS, renderS] = map (S.pack . show) [loadTime config, time]
- ts = templateState config
+ let [loadS, renderS] = map (S.pack . show) [lt, time]
ts' = bindStrings [ ("loadTime", loadS)
, ("renderTime", renderS)
] ts
renderHtml ts' "index"
-staticResources :: Snap ()
+staticResources :: StateSnap ()
staticResources = fileServe "resources/static"
-site :: Config -> Snap ()
-site config = msum [ frontPage config
- , staticResources
- ]
+site :: AppState -> Snap ()
+site = runStateSnap $ do
+ msum [ frontPage
+ , staticResources
+ ]
diff --git a/snap.cabal b/snap.cabal
index 354185a..9bd337f 100644
--- a/snap.cabal
+++ b/snap.cabal
@@ -35,7 +35,7 @@ extra-source-files:
project_template/hint/log/error.log,
project_template/hint/resources/static/screen.css,
project_template/hint/resources/templates/index.tpl,
- project_template/hint/src/Config.hs,
+ project_template/hint/src/AppState.hs,
project_template/hint/src/Main.hs,
project_template/hint/src/Site.hs
diff --git a/src/Snap/Error.hs b/src/Snap/Error.hs
index e3a9d27..98bb463 100644
--- a/src/Snap/Error.hs
+++ b/src/Snap/Error.hs
@@ -15,7 +15,7 @@ import qualified Data.ByteString.Char8 as S
import Snap.Iteratee
import Snap.Types
-internalError :: S.ByteString -> Snap a
+internalError :: (MonadSnap m) => S.ByteString -> m a
internalError msg =
let rsp = setContentType "text/plain; charset=utf-8"
. setContentLength (fromIntegral $ S.length msg)
@@ -25,10 +25,10 @@ internalError msg =
in finishWith rsp
-catch500 :: Snap a -> Snap a
+catch500 :: (MonadSnap m) => m a -> m a
catch500 action = action `catch` handler
where
- handler :: SomeException -> Snap a'
+ handler :: (MonadSnap m) => SomeException -> m a'
handler = internalError
. S.append "Unhandled error:\r\n\r\n"
. S.pack
diff --git a/src/Snap/Heist.hs b/src/Snap/Heist.hs
index d629742..9325f49 100644
--- a/src/Snap/Heist.hs
+++ b/src/Snap/Heist.hs
@@ -9,11 +9,12 @@ import Snap.Types
import Text.Templating.Heist
-renderHtml :: TemplateState Snap -> S.ByteString -> Snap ()
+renderHtml :: (MonadSnap m) => TemplateState m -> S.ByteString -> m ()
renderHtml = render "text/html; charset=utf-8"
-render :: S.ByteString -> TemplateState Snap -> S.ByteString -> Snap ()
+render :: (MonadSnap m) =>
+ S.ByteString -> TemplateState m -> S.ByteString -> m ()
render contentType ts template = do
bytes <- renderTemplate ts template
flip (maybe missingTemplate) bytes $ \x -> do
diff --git a/src/Snap/Loader/Hint.hs b/src/Snap/Loader/Hint.hs
index 4cb7fa1..b0e5b5b 100644
--- a/src/Snap/Loader/Hint.hs
+++ b/src/Snap/Loader/Hint.hs
@@ -75,7 +75,8 @@ loadSnapTH initialize cleanup action = do
------------------------------------------------------------------------------
-- | XXX
getHintOpts :: [String] -> [String]
-getHintOpts args = "-hide-package=mtl" : filter (not . (`elem` bad)) opts
+getHintOpts args = "-hide-package=mtl" : "-hide-package=MonadCatchIO-mtl" :
+ filter (not . (`elem` bad)) opts
where
bad = ["-threaded"]
hideAll = filter (== "-hide-all-packages") args
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
