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, hint-fix has been created
at d0c359ff14fd6227189b1a0b1ecc1eed751ead3d (commit)
- Log -----------------------------------------------------------------
commit d0c359ff14fd6227189b1a0b1ecc1eed751ead3d
Author: Gregory Collins <[email protected]>
Date: Mon Dec 13 23:12:24 2010 +0100
Try to fix hint
diff --git a/project_template/default/foo.cabal
b/project_template/default/foo.cabal
index 4e27fe2..23f9e16 100644
--- a/project_template/default/foo.cabal
+++ b/project_template/default/foo.cabal
@@ -10,11 +10,18 @@ Category: Web
Build-type: Simple
Cabal-version: >=1.2
+Flag development
+ Description: Whether to build the server in development (interpreted) mode
+ Default: False
+
Executable projname
hs-source-dirs: src
main-is: Main.hs
- cpp-options: -DPRODUCTION
+ if !flag(development)
+ cpp-options: -DPRODUCTION
+ else
+ build-depends: hint >= 0.3.2 && < 0.4
Build-depends:
base >= 4 && < 5,
@@ -25,6 +32,7 @@ Executable projname
mtl >= 2 && < 3,
snap >= 0.3 && < 0.4,
snap-core >= 0.3 && < 0.4,
+ snap-server >= 0.3 && <0.4,
text >= 0.11 && < 0.12,
time >= 1.1 && < 1.2
diff --git a/project_template/default/src/Main.hs
b/project_template/default/src/Main.hs
index 8d3b1f9..104da6c 100644
--- a/project_template/default/src/Main.hs
+++ b/project_template/default/src/Main.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
{-|
@@ -45,11 +46,19 @@ module Main where
#ifdef PRODUCTION
import Snap.Extension.Server
#else
-import Snap.Extension.Server.Hint
+import Snap.Loader.Hint
+import Snap.Http.Server (quickHttpServe)
#endif
import Application
import Site
+-- FIXME: re-prettify this
main :: IO ()
+#ifdef PRODUCTION
main = quickHttpServe applicationInitializer site
+#else
+main = do
+ snap <- $(loadSnapTH 'applicationInitializer 'site)
+ quickHttpServe snap
+#endif
diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs
index 566df2e..44c03cd 100644
--- a/src/Snap/Extension.hs
+++ b/src/Snap/Extension.hs
@@ -25,7 +25,9 @@ module Snap.Extension
, Initializer
, InitializerState(..)
, runInitializer
+ -- FIXME: rename this
, runInitializerHint
+ , runInitializerHint2
, mkInitializer
, defaultReloadHandler
, nullReloadHandler
@@ -377,6 +379,7 @@ runInitializer v (Initializer r) (SnapExtend m) = r v >>=
\e -> case e of
Right (SCR s a b) -> return (runReaderT m s, a, b)
+-- FIXME: doesn't have anything to do with hint anymore
------------------------------------------------------------------------------
-- | Serves the same purpose as 'runInitializer', but can be used with Hint.
-- This is explained in the README.
@@ -396,6 +399,23 @@ runInitializerHint v (Initializer r) se@(SnapExtend m) f =
r v >>= \e -> case e
Right (SCR s a b) -> let (SnapExtend m') = f b <|> se
in return (return s, const a, runReaderT m')
+------------------------------------------------------------------------------
+-- | Runs an initializer, obtains state, runs the handler, and tears everything
+-- down all in one request. Used with the hint backend which reloads everything
+-- every time.
+runInitializerHint2 :: Initializer s
+ -- ^ The Initializer value
+ -> SnapExtend s ()
+ -- ^ An action in your application's monad.
+ -> Snap ()
+runInitializerHint2 (Initializer r) se@(SnapExtend m) = do
+ liftIO (r True) >>= either
+ -- Left s: no cleanup action
+ (\s -> runReaderT m s)
+ f
+ where
+ f (SCR s a _) = runReaderT m s `finally` liftIO a
+
------------------------------------------------------------------------------
instance Functor Initializer where
diff --git a/src/Snap/Extension/Server.hs b/src/Snap/Extension/Server.hs
index 42c865e..d89ecfe 100644
--- a/src/Snap/Extension/Server.hs
+++ b/src/Snap/Extension/Server.hs
@@ -5,21 +5,13 @@
{-|
This module provides replacements for the 'httpServe' and 'quickHttpServe'
-functions exported by 'Snap.Http.Server'. By taking a 'Initializer' as an
argument,
-these functions simplify the glue code that is needed to use Snap Extensions.
-In particular, 'Snap.Extension.Server.Hint' provides function with identical
-type signatures to the ones exported by this module, but which dynamically
-reload their code on each request. See the README for details.
+functions exported by 'Snap.Http.Server'. By taking a 'Initializer' as an
+argument, these functions simplify the glue code that is needed to use Snap
+Extensions.
-}
--- N.B.: the HINT cpp macro is defined by the file "Server/Hint.hs" and this
--- file is then included via cpp
-#ifdef HINT
-module Snap.Extension.Server.Hint
-#else
module Snap.Extension.Server
-#endif
( ConfigExtend
, httpServe
, quickHttpServe
@@ -29,10 +21,7 @@ module Snap.Extension.Server
, module Snap.Http.Server.Config
) where
-#ifndef HINT
import Control.Arrow
-#endif
-
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO
@@ -43,9 +32,6 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Prelude hiding (catch)
import Snap.Extension
-#ifdef HINT
-import Snap.Loader.Hint
-#endif
import Snap.Http.Server (simpleHttpServe)
import qualified Snap.Http.Server.Config as C
import Snap.Http.Server.Config hiding ( defaultConfig
@@ -125,11 +111,7 @@ httpServe :: ConfigExtend s
httpServe config i handler = do
(state, makeCleanup, mkSnap) <-
runInitializerHint verbose i (catch500 handler) reloader
-#ifdef HINT
- (cleanup, snap) <- $(loadSnapTH 'state 'makeCleanup 'mkSnap)
-#else
(cleanup, snap) <- fmap (makeCleanup &&& mkSnap) state
-#endif
let site = compress $ snap
mapM_ printListen $ C.getListen config
_ <- try $ serve $ site :: IO (Either SomeException ())
@@ -138,8 +120,6 @@ httpServe config i handler = do
output "Shutting down..."
where
--- handle :: SomeException -> IO ()
--- handle e = print e
conf = completeConfig config
verbose = fromJust $ getVerbose conf
output = when verbose . hPutStrLn stderr
diff --git a/src/Snap/Extension/Server/Hint.hs
b/src/Snap/Extension/Server/Hint.hs
index 54375d7..adf6200 100644
--- a/src/Snap/Extension/Server/Hint.hs
+++ b/src/Snap/Extension/Server/Hint.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-#define HINT
-#include "../Server.hs"
+
+module Snap.Extension.Server.Hint where
diff --git a/src/Snap/Loader/Hint.hs b/src/Snap/Loader/Hint.hs
index 0dd2d0f..b9b7824 100644
--- a/src/Snap/Loader/Hint.hs
+++ b/src/Snap/Loader/Hint.hs
@@ -51,28 +51,28 @@ import qualified Snap.Loader.Static as Static
-- The upshot is that you shouldn't need to recompile your server
-- during development unless your .cabal file changes, or the code
-- that uses this splice changes.
-loadSnapTH :: Name -> Name -> Name -> Q Exp
-loadSnapTH initialize cleanup action = do
+--
+-- FIXME: redo docs to match new reality of two arguments, the initializer and
+-- the action. Return type is also different now, should be just "Snap ()"
+loadSnapTH :: Name -> Name -> Q Exp
+loadSnapTH initializer action = do
args <- runIO getArgs
- let initMod = nameModule initialize
- initBase = nameBase initialize
- cleanMod = nameModule cleanup
- cleanBase = nameBase cleanup
+ let initMod = nameModule initializer
+ initBase = nameBase initializer
actMod = nameModule action
actBase = nameBase action
- modules = catMaybes [initMod, cleanMod, actMod]
+ modules = catMaybes [initMod, actMod]
opts = getHintOpts args
- let static = Static.loadSnapTH initialize cleanup action
+ let static = Static.loadSnapTH initializer action
-- The let in this block causes the static expression to be
-- pattern-matched, providing an extra check that the types were
-- correct at compile-time, at least.
- [| do let _ = $static :: IO (IO (), Snap ())
- hint <- hintSnap opts modules initBase cleanBase actBase
- return (return (), hint) |]
+ [| let _ = $static :: IO (Snap ())
+ in hintSnap opts modules initBase actBase |]
------------------------------------------------------------------------------
@@ -123,19 +123,17 @@ hintSnap :: [String] -- ^ A list of command-line options
for the interpreter
-- modules which contain the initialization,
-- cleanup, and handler actions. Everything else
-- they require will be loaded transitively.
- -> String -- ^ The name of the initialization action
- -> String -- ^ The name of the cleanup action
- -> String -- ^ The name of the handler action
+ -> String -- ^ The name of the initializer action
+ -> String -- ^ The name of the SnapExtend action
-> IO (Snap ())
-hintSnap opts modules initialization cleanup handler = do
- let action = intercalate " " [ "bracketSnap"
+hintSnap opts modules initialization handler = do
+ let action = intercalate " " [ "runInitializerHint2"
, initialization
- , cleanup
, handler
]
interpreter = do
loadModules . nub $ modules
- let imports = "Prelude" : "Snap.Types" : modules
+ let imports = ["Prelude", "Snap.Types", "Snap.Extension"] ++
modules
setImports . nub $ imports
interpret action (as :: Snap ())
@@ -146,11 +144,10 @@ hintSnap opts modules initialization cleanup handler = do
-- access.
loadAction <- protectedActionEvaluator 3 loadInterpreter
- return $ do
- interpreterResult <- liftIO loadAction
- case interpreterResult of
- Left err -> error $ format err
- Right handlerAction -> handlerAction
+ interpreterResult <- liftIO loadAction
+ case interpreterResult of
+ Left err -> error $ format err
+ Right handlerAction -> return handlerAction
------------------------------------------------------------------------------
diff --git a/src/Snap/Loader/Static.hs b/src/Snap/Loader/Static.hs
index 1524f09..ab3b148 100644
--- a/src/Snap/Loader/Static.hs
+++ b/src/Snap/Loader/Static.hs
@@ -13,6 +13,7 @@ module Snap.Loader.Static where
import Control.Arrow
import Language.Haskell.TH
+import Snap.Extension
------------------------------------------------------------------------------
-- | This function is a shim for source compatibility with loadSnapTH
@@ -23,8 +24,11 @@ import Language.Haskell.TH
-- > loadSnap initialize cleanup action = do
-- > i <- initialize
-- > return (cleanup i, action i)
-loadSnapTH :: Name -> Name -> Name -> Q Exp
-loadSnapTH initialize cleanup action = do
- let [initE, cleanE, actE] = map varE [initialize, cleanup, action]
- [| fmap ($cleanE &&& $actE) $initE |]
+-- FIXME: change docs to match two arguments. In particular "initializer" is
+-- now an "Initializer s" and "action" is a "SnapExtend s ()"
+loadSnapTH :: Name -> Name -> Q Exp
+loadSnapTH initializer action = do
+ let [initE, actE] = map varE [initializer, action]
+ -- FIXME: rename runInitializerHint2
+ [| return (runInitializerHint2 $initE $actE) |]
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
