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 fa9b9ad27a4a8d6512f11ecd58cfd6f1c886b846 (commit)
via dbf1eade901c372411ae222bd28309ee60d36b7c (commit)
via 188cee0547c0e93ceaed0f7c90210620dbaf1596 (commit)
via c7ee77706530c2dbc85362c4061abe67350c6bd2 (commit)
via d0c359ff14fd6227189b1a0b1ecc1eed751ead3d (commit)
from 54cc10e3753c15a38ae8fcf05039b895434ff598 (commit)
Summary of changes:
project_template/default/foo.cabal | 10 ++-
project_template/default/src/Main.hs | 11 ++-
snap.cabal | 13 ++-
src/Snap/Extension.hs | 146 ++++++++++++++++++-----------
src/Snap/{ => Extension}/Loader/Hint.hs | 51 +++++------
src/Snap/Extension/Loader/Hint/Helper.hs | 43 +++++++++
src/Snap/{ => Extension}/Loader/Static.hs | 15 ++-
src/Snap/Extension/Server.hs | 37 ++------
src/Snap/Extension/Server/Hint.hs | 4 +-
9 files changed, 205 insertions(+), 125 deletions(-)
rename src/Snap/{ => Extension}/Loader/Hint.hs (86%)
create mode 100644 src/Snap/Extension/Loader/Hint/Helper.hs
rename src/Snap/{ => Extension}/Loader/Static.hs (70%)
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 fa9b9ad27a4a8d6512f11ecd58cfd6f1c886b846
Author: Gregory Collins <[email protected]>
Date: Sun Dec 19 10:29:21 2010 +0100
Do some cleanup of the hint stuff
diff --git a/snap.cabal b/snap.cabal
index 8f5f2b4..80e447b 100644
--- a/snap.cabal
+++ b/snap.cabal
@@ -46,15 +46,15 @@ Library
exposed-modules:
Snap.Extension.Heist,
Snap.Extension.Heist.Impl,
+ Snap.Extension.Loader.Hint,
+ Snap.Extension.Loader.Static,
Snap.Extension.Server.Hint,
Snap.Extension.Server,
Snap.Extension,
- Snap.Heist,
- Snap.Loader.Hint,
- Snap.Loader.Static
+ Snap.Heist
other-modules:
- Snap.Loader.Hint.Helper
+ Snap.Extension.Loader.Hint.Helper
build-depends:
base >= 4 && < 5,
diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs
index 44c03cd..397fc42 100644
--- a/src/Snap/Extension.hs
+++ b/src/Snap/Extension.hs
@@ -25,9 +25,8 @@ module Snap.Extension
, Initializer
, InitializerState(..)
, runInitializer
- -- FIXME: rename this
+ , runInitializerWithReloadAction
, runInitializerHint
- , runInitializerHint2
, mkInitializer
, defaultReloadHandler
, nullReloadHandler
@@ -54,7 +53,7 @@ import System.IO
Snap Extensions is a library which makes it easy to create reusable plugins
that extend your Snap application with modular chunks of functionality such
- as session management, user authentication, templating and database
+ as session management, user authentication, templating, or database
connection pooling.
We achieve this by requiring that you create a datatype that holds an
@@ -62,6 +61,9 @@ import System.IO
construct becomes your application's handler monad and gives you access to
your application state throughout your handlers.
+ Warning: this interface is still EXPERIMENTAL and has a very high likelihood
+ of changing substantially in coming versions of Snap.
+
-}
{- $using
@@ -73,12 +75,12 @@ import System.IO
implementation of the interface. In these cases, both the interface and the
implementation are exported from the same module, Snap.Extension.Heist.Impl.
- For something like session management though, there could be multiple
- implementations, one using a HDBC backend, one using a MongoDB backend and
- one just using an encrypted cookie as backend. In these cases, the interface
- is exported from Snap.Extension.Session, and the implementations live in
- Snap.Extension.Session.HDBC, Snap.Extension.Session.MongoDB and
- Snap.Extension.Session.CookieStore.
+ Hypothetically, for something like session management though, there could be
+ multiple implementations, one using a HDBC backend, one using a MongoDB
+ backend and one just using an encrypted cookie as backend. In these cases,
+ the interface is exported from Snap.Extension.Session, and the
+ implementations live in Snap.Extension.Session.HDBC,
+ Snap.Extension.Session.MongoDB and Snap.Extension.Session.CookieStore.
Keeping this in mind, there are a number of things you need to do to use Snap
extensions in your application. Let's walk through how to set up a simple
@@ -196,41 +198,30 @@ appInitializer = do
important that you put the connectionPoolInitializer before the
sessionInitializer in your appInitializer.
- This Initializer AppState can then be passed to 'runInitializer', whose type
- signature is:
+ This Initializer AppState can then be passed to 'runInitializer', which
+ combines our initializer action with our application's handler to produce a
+ 'Snap' handler (which can be passed to 'httpServe'), a cleanup action (which
+ you can run after 'httpServe' finishes), and a reload action (which, for
+ example, you may want to use in your handler for the path \"admin/reload\".
- @Bool -> Initializer s -> SnapExtend s () -> IO (Snap (), IO (), IO
[(ByteString, Maybe ByteString)])@
-
- Essentially, this function takes an initializer action, our entire App () and
- returns the 'Snap' action (which can be passed to 'httpServe'), a cleanup
- action (which you run after 'httpServe') and a reload action (which you may
- want to use in your handler for the path \"admin/reload\". The list it
- returns is for error reporting - there is one tuple in the list for each Snap
- extension; the first element of the tuple is the name of the Snap extension
- and the second is a Maybe which contains Nothing if there was no error
- reloading that extension and a Just with the ByteString containing the error
- message if there was) and a cleanup action which you would run after
- 'httpServe'.
-
The following is an example of how you might use this in main:
@
main :: IO ()
-
main = do
- (snap,cleanup,reload) <- runInitializer appInitializer site
+ (snap,cleanup,reload) <- runInitializer appInitializer appSite
let site = snap
<|> path "admin/reload" $ defaultReloadHandler reload cleanup
- quickHttpServe site
+ quickHttpServe site `finally` cleanup
@
- You'll notice we're using defaultReloadHandler. This is a function exported
- by "Snap.Extension" with the type signature
+ You'll notice we're using 'defaultReloadHandler'. This is a function exported
+ by "Snap.Extension" with the type signature
- @MonadSnap m => IO [(ByteString, Maybe ByteString)] -> m ()@
-
- It takes the reload action returned by 'runInitializer' and returns a 'Snap'
- action which renders a simple page showing how the reload went.
+ @MonadSnap m => IO [(ByteString, Maybe ByteString)] -> m ()@ It takes the
+ reload action returned by 'runInitializer' and returns a 'Snap' action which
+ renders a simple page showing how the reload went. To avoid denial-of-service
+ attacks, the reload handler only works for requests made from the local host.
-}
@@ -366,49 +357,65 @@ mkInitializer s = Initializer $ \v -> setup v $ Right $
mkSCR v
-- | Given the Initializer for your application's state, and a value in the
-- monad formed by 'SnapExtend' wrapped it, this returns a 'Snap' action, a
-- cleanup action and a reload action.
-runInitializer :: Bool
- -- ^ Verbosity; info is printed to 'stderr' when this is 'True'
- -> Initializer s
- -- ^ The Initializer value
- -> SnapExtend s ()
- -- ^ An action in your application's monad
- -> IO (Snap (), IO (), IO [(ByteString, Maybe ByteString)])
- -- ^ This is documented thoroughly in the README
-runInitializer v (Initializer r) (SnapExtend m) = r v >>= \e -> case e of
- Left s -> return (runReaderT m s, return (), return [])
- Right (SCR s a b) -> return (runReaderT m s, a, b)
-
-
--- FIXME: doesn't have anything to do with hint anymore
+runInitializer
+ :: Bool
+ -- ^ Verbosity; info is printed to 'stderr' when this is 'True'
+ -> Initializer s
+ -- ^ The Initializer value
+ -> SnapExtend s ()
+ -- ^ An action in your application's monad
+ -> IO (Snap (), IO (), IO [(ByteString, Maybe ByteString)])
+ -- ^ Returns a 'Snap' handler, a cleanup action, and a reload action. The
+ -- list returned by the reload action is for error reporting. There is one
+ -- tuple in the list for each Snap extension; the first element of the
+ -- tuple is the name of the Snap extension, and the second is a Maybe
+ -- which contains Nothing if there was no error reloading that extension
+ -- and a Just with the ByteString containing the error message if there
+ -- was.
+runInitializer v (Initializer r) (SnapExtend m) =
+ r v >>= \e -> case e of
+ Left s -> return (runReaderT m s, return (), return [])
+ Right (SCR s a b) -> return (runReaderT m s, a, b)
+
+
------------------------------------------------------------------------------
-- | Serves the same purpose as 'runInitializer', but can be used with Hint.
-- This is explained in the README.
-runInitializerHint :: Bool
- -- ^ Verbosity; info is printed to 'stderr' when this is
- -- 'True'
- -> Initializer s
- -- ^ The Initializer value
- -> SnapExtend s ()
- -- ^ An action in your application's monad.
- -> (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())
- -- ^ See README and 'defaultReloadHandler'
- -> IO (IO s, s -> IO (), s -> Snap ())
- -- ^ A tuple of values which can be passed to @loadsna...@.
-runInitializerHint v (Initializer r) se@(SnapExtend m) f = r v >>= \e -> case
e of
- Left s -> return (return s, const $ return (), runReaderT m)
- Right (SCR s a b) -> let (SnapExtend m') = f b <|> se
- in return (return s, const a, runReaderT m')
+runInitializerWithReloadAction
+ :: Bool
+ -- ^ Verbosity; info is printed to 'stderr' when this is 'True'
+ -> Initializer s
+ -- ^ The Initializer value
+ -> SnapExtend s ()
+ -- ^ An action in your application's monad.
+ -> (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())
+ -- ^ Your desired \"reload\" handler; it gets passed the reload
+ -- action. This handler is always run, so you have to guard the path
+ -- yourself (with.
+ -> IO (Snap (), IO ())
+ -- ^ Your 'Snap' handler and a cleanup action.
+runInitializerWithReloadAction v (Initializer r) se f = do
+ (state, cleanup, reload) <- runInit
+
+ let (SnapExtend m') = f reload <|> se
+ return (runReaderT m' state, cleanup)
+
+ where
+ runInit = r v >>= \e ->
+ case e of
+ Left s -> return (s, return (), return [])
+ Right (SCR s a b) -> return (s, a, b)
------------------------------------------------------------------------------
-- | 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
+runInitializerHint :: Initializer s
+ -- ^ The Initializer value
+ -> SnapExtend s ()
+ -- ^ An action in your application's monad.
+ -> Snap ()
+runInitializerHint (Initializer r) (SnapExtend m) = do
liftIO (r True) >>= either
-- Left s: no cleanup action
(\s -> runReaderT m s)
@@ -460,7 +467,7 @@ join' (Initializer r) = Initializer $ \v -> r v >>= \e ->
case e of
defaultReloadHandler :: MonadSnap m
=> IO [(ByteString, Maybe ByteString)]
-> m ()
-defaultReloadHandler ioms = do
+defaultReloadHandler ioms = failIfNotLocal $ do
ms <- liftIO $ ioms
let showE e = mappend "Error: " $ toUTF8 $ show e
format (n, m) = mconcat [n, ": ", maybe "Sucess" showE m, "\n"]
@@ -468,7 +475,14 @@ defaultReloadHandler ioms = do
finishWith $ setContentType "text/plain; charset=utf-8"
$ setContentLength (fromIntegral $ B.length msg)
$ modifyResponseBody (>==> enumBS msg) emptyResponse
-
+ where
+ failIfNotLocal m = do
+ rip <- liftM rqRemoteAddr getRequest
+ if not $ elem rip [ "127.0.0.1"
+ , "localhost"
+ , "::1" ]
+ then pass
+ else m
------------------------------------------------------------------------------
-- | Use this reload handler to disable the ability to have a web handler
diff --git a/src/Snap/Loader/Hint.hs b/src/Snap/Extension/Loader/Hint.hs
similarity index 93%
rename from src/Snap/Loader/Hint.hs
rename to src/Snap/Extension/Loader/Hint.hs
index 71e1581..f0edd0b 100644
--- a/src/Snap/Loader/Hint.hs
+++ b/src/Snap/Extension/Loader/Hint.hs
@@ -5,7 +5,9 @@
-- to gather the necessary compile-time information about code
-- location, compiler arguments, etc, and bind that information into
-- the calls to the dynamic loader.
-module Snap.Loader.Hint where
+module Snap.Extension.Loader.Hint
+ ( loadSnapTH
+ ) where
import Data.List (groupBy, intercalate, isPrefixOf, nub)
@@ -29,8 +31,8 @@ import System.Environment (getArgs)
------------------------------------------------------------------------------
import Snap.Types
-import qualified Snap.Loader.Static as Static
-import Snap.Loader.Hint.Helper
+import qualified Snap.Extension.Loader.Static as Static
+import Snap.Extension.Loader.Hint.Helper
------------------------------------------------------------------------------
-- | This function derives all the information necessary to use the
@@ -39,22 +41,18 @@ import Snap.Loader.Hint.Helper
--
-- This could be considered a TH wrapper around a function
--
--- > loadSnap :: IO a -> (a -> IO ()) -> (a -> Snap ()) -> IO (IO (), Snap ())
+-- > loadSnap :: Initializer s -> SnapExtend s () -> IO (Snap ())
--
-- with a magical implementation.
--
--- The returned IO action does nothing. The returned Snap action does
--- initialization, runs the action, and does the cleanup. This means
--- that the whole application state will be loaded and unloaded for
--- each request. To make this worthwhile, those steps should be made
--- quite fast.
+-- The returned Snap action runs the 'Initializer', runs the 'Snap' handler,
+-- and does the cleanup. This means that the whole application state will be
+-- loaded and unloaded for each request. To make this worthwhile, those steps
+-- should be made quite fast.
--
-- 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.
---
--- 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
@@ -128,7 +126,7 @@ hintSnap :: [String] -- ^ A list of command-line options
for the interpreter
-> String -- ^ The name of the SnapExtend action
-> IO (Snap ())
hintSnap opts modules initialization handler = do
- let action = intercalate " " [ "runInitializerHint2"
+ let action = intercalate " " [ "runInitializerHint"
, initialization
, handler
]
diff --git a/src/Snap/Loader/Hint/Helper.hs
b/src/Snap/Extension/Loader/Hint/Helper.hs
similarity index 92%
rename from src/Snap/Loader/Hint/Helper.hs
rename to src/Snap/Extension/Loader/Hint/Helper.hs
index 361c2d4..7f1928b 100644
--- a/src/Snap/Loader/Hint/Helper.hs
+++ b/src/Snap/Extension/Loader/Hint/Helper.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE CPP #-}
-module Snap.Loader.Hint.Helper (protectHandlers) where
+module Snap.Extension.Loader.Hint.Helper (protectHandlers) where
import Control.Exception (bracket)
diff --git a/src/Snap/Loader/Static.hs b/src/Snap/Extension/Loader/Static.hs
similarity index 91%
rename from src/Snap/Loader/Static.hs
rename to src/Snap/Extension/Loader/Static.hs
index ab3b148..f9f9732 100644
--- a/src/Snap/Loader/Static.hs
+++ b/src/Snap/Extension/Loader/Static.hs
@@ -8,9 +8,8 @@
-- obvious, straight-forward manner. It is present *only* as a
-- source-level replacement for the Hint loader, to enable quickly
-- switching the Hint loader off with only a changed import.
-module Snap.Loader.Static where
+module Snap.Extension.Loader.Static where
-import Control.Arrow
import Language.Haskell.TH
import Snap.Extension
@@ -31,4 +30,4 @@ loadSnapTH :: Name -> Name -> Q Exp
loadSnapTH initializer action = do
let [initE, actE] = map varE [initializer, action]
-- FIXME: rename runInitializerHint2
- [| return (runInitializerHint2 $initE $actE) |]
+ [| return (runInitializerHint $initE $actE) |]
diff --git a/src/Snap/Extension/Server.hs b/src/Snap/Extension/Server.hs
index d89ecfe..07898c4 100644
--- a/src/Snap/Extension/Server.hs
+++ b/src/Snap/Extension/Server.hs
@@ -21,7 +21,6 @@ module Snap.Extension.Server
, module Snap.Http.Server.Config
) where
-import Control.Arrow
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO
@@ -108,10 +107,12 @@ httpServe :: ConfigExtend s
-> SnapExtend s ()
-- ^ The application to be served
-> IO ()
-httpServe config i handler = do
- (state, makeCleanup, mkSnap) <-
- runInitializerHint verbose i (catch500 handler) reloader
- (cleanup, snap) <- fmap (makeCleanup &&& mkSnap) state
+httpServe config initializer handler = do
+ (snap, cleanup) <- runInitializerWithReloadAction
+ verbose
+ initializer
+ (catch500 handler)
+ reloader
let site = compress $ snap
mapM_ printListen $ C.getListen config
_ <- try $ serve $ site :: IO (Either SomeException ())
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
