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 1f9a875a834039f185e4b89ff941d90c4519a599 (commit)
from 788253e8fc9d29049e057d31bffba9ab477ee556 (commit)
Summary of changes:
.../default/src/Snap/Extension/Timer.hs | 53 +++++
.../default/src/Snap/Extension/Timer/Timer.hs | 67 ++++++
src/Snap/Extension.hs | 219 ++++++++++++++++++++
src/Snap/Extension/Heist.hs | 53 +++++
src/Snap/Extension/Heist/Heist.hs | 162 +++++++++++++++
src/Snap/Extension/Server.hs | 167 +++++++++++++++
src/Snap/Extension/Server/Hint.hs | 5 +
7 files changed, 726 insertions(+), 0 deletions(-)
create mode 100644 project_template/default/src/Snap/Extension/Timer.hs
create mode 100644 project_template/default/src/Snap/Extension/Timer/Timer.hs
create mode 100644 src/Snap/Extension.hs
create mode 100644 src/Snap/Extension/Heist.hs
create mode 100644 src/Snap/Extension/Heist/Heist.hs
create mode 100644 src/Snap/Extension/Server.hs
create mode 100644 src/Snap/Extension/Server/Hint.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 1f9a875a834039f185e4b89ff941d90c4519a599
Author: Gregory Collins <[email protected]>
Date: Sun Dec 5 22:58:50 2010 +0100
Add missing files (oops)
diff --git a/project_template/default/src/Snap/Extension/Timer.hs
b/project_template/default/src/Snap/Extension/Timer.hs
new file mode 100644
index 0000000..0c699ce
--- /dev/null
+++ b/project_template/default/src/Snap/Extension/Timer.hs
@@ -0,0 +1,53 @@
+{-|
+
+'Snap.Extension.Timer' exports the 'MonadTimer' interface which allows you to
+keep track of the time at which your application was started. The interface's
+only operation is 'startTime'.
+
+Two splices, 'startTimeSplice' and 'currentTimeSplice' are also provided, for
+your convenience.
+
+'Snap.Extension.Timer.Timer' contains the only implementation of this
+interface and can be used to turn your application's monad into a
+'MonadTimer'.
+
+More than anything else, this is intended to serve as an example Snap
+Extension to any developer wishing to write their own Snap Extension.
+
+-}
+
+module Snap.Extension.Timer
+ ( MonadTimer(..)
+ , startTimeSplice
+ , currentTimeSplice
+ ) where
+
+import Control.Monad.Trans
+import qualified Data.ByteString.UTF8 as U
+import Data.Time.Clock
+import Snap.Types
+import Text.Templating.Heist
+import Text.XML.Expat.Tree hiding (Node)
+
+
+------------------------------------------------------------------------------
+-- | The 'MonadTimer' type class. Minimal complete definition: 'startTime'.
+class MonadSnap m => MonadTimer m where
+ -- | The time at which your application was last loaded.
+ startTime :: m UTCTime
+
+
+------------------------------------------------------------------------------
+-- | For your convenience, a splice which shows the start time.
+startTimeSplice :: MonadTimer m => Splice m
+startTimeSplice = do
+ time <- lift startTime
+ return $ [mkText $ U.fromString $ show $ time]
+
+
+------------------------------------------------------------------------------
+-- | For your convenience, a splice which shows the current time.
+currentTimeSplice :: MonadTimer m => Splice m
+currentTimeSplice = do
+ time <- lift $ liftIO getCurrentTime
+ return $ [mkText $ U.fromString $ show $ time]
diff --git a/project_template/default/src/Snap/Extension/Timer/Timer.hs
b/project_template/default/src/Snap/Extension/Timer/Timer.hs
new file mode 100644
index 0000000..3222a41
--- /dev/null
+++ b/project_template/default/src/Snap/Extension/Timer/Timer.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{-|
+
+'Snap.Extension.Timer.Timer' is an implementation of the 'MonadTimer'
+interface defined in 'Snap.Extension.Timer'.
+
+As always, to use, add 'TimerState' to your application's state, along with an
+instance of 'HasTimerState' for your application's state, making sure to use a
+'timerInitializer' in your application's 'Initializer', and then you're ready
to go.
+
+This implementation does not require that your application's monad implement
+interfaces from any other Snap Extension.
+
+-}
+
+module Snap.Extension.Timer.Timer
+ ( TimerState
+ , HasTimerState(..)
+ , timerInitializer
+ ) where
+
+import Control.Monad.Reader
+import Control.Monad.Trans
+import Data.Time.Clock
+import Snap.Extension
+import Snap.Extension.Timer
+import Snap.Types
+
+------------------------------------------------------------------------------
+-- | Your application's state must include a 'TimerState' in order for your
+-- application to be a 'MonadTimer'.
+newtype TimerState = TimerState
+ { _startTime :: UTCTime
+ }
+
+
+------------------------------------------------------------------------------
+-- | For you appliaction's monad to be a 'MonadTimer', your application's
+-- state needs to be an instance of 'HasTimerState'. Minimal complete
+-- definition: 'getTimerState', 'setTimerState'.
+class HasTimerState s where
+ getTimerState :: s -> TimerState
+ setTimerState :: TimerState -> s -> s
+
+
+------------------------------------------------------------------------------
+-- | The Initializer for 'TimerState'. No arguments are required.
+timerInitializer :: Initializer TimerState
+timerInitializer = liftIO getCurrentTime >>= mkInitializer . TimerState
+
+
+------------------------------------------------------------------------------
+instance InitializerState TimerState where
+ extensionId = const "Timer/Timer"
+ mkCleanup = const $ return ()
+ mkReload = const $ return ()
+
+
+------------------------------------------------------------------------------
+instance HasTimerState s => MonadTimer (SnapExtend s) where
+ startTime = fmap _startTime $ asks getTimerState
+
+
+------------------------------------------------------------------------------
+instance (MonadSnap m, HasTimerState s) => MonadTimer (ReaderT s m) where
+ startTime = fmap _startTime $ asks getTimerState
diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs
new file mode 100644
index 0000000..3d19fdf
--- /dev/null
+++ b/src/Snap/Extension.hs
@@ -0,0 +1,219 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Snap.Extension
+ ( SnapExtend
+ , Initializer
+ , InitializerState(..)
+ , runInitializer
+ , runInitializerHint
+ , mkInitializer
+ , defaultReloadHandler
+ , nullReloadHandler
+ ) where
+
+import Control.Applicative
+import Control.Exception (SomeException)
+import Control.Monad
+import Control.Monad.CatchIO
+import Control.Monad.Reader
+import Control.Monad.Trans
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Monoid
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Prelude hiding (catch)
+import Snap.Iteratee (enumBS, (>==>))
+import Snap.Types
+import System.IO
+
+
+------------------------------------------------------------------------------
+-- | A 'SnapExtend' is a 'MonadReader' and a 'MonadSnap' whose environment is
+-- the application state for a given progam. You would usually type alias
+-- @SnapExtend AppState@ to something like @App@ to form the monad in which
+-- you write your application.
+newtype SnapExtend s a = SnapExtend (ReaderT s Snap a)
+ deriving
+ ( Functor
+ , Applicative
+ , Alternative
+ , Monad
+ , MonadPlus
+ , MonadIO
+ , MonadCatchIO
+ , MonadSnap
+ , MonadReader s
+ )
+
+
+------------------------------------------------------------------------------
+-- | The 'SCR' datatype is used internally by the 'Initializer' monad to store
+-- the application's state, cleanup actions and reload actions.
+data SCR s = SCR
+ { _state :: s
+ -- ^ The internal state of the application's Snap Extensions.
+ , _cleanup :: IO ()
+ -- ^ IO action which when run will cleanup the application's state,
+ -- e.g., closing open connections.
+ , _reload :: IO [(ByteString, Maybe ByteString)]
+ -- ^ IO action which when run will reload the application's state, e.g.,
+ -- refreshing any cached values stored in the state.
+ --
+ -- It returns a list of tuples whose \"keys\" are the names of the Snap
+ -- Extensions which were reloaded and whose \"values\" are @Nothing@
+ -- when run successfully and @Just x@ on failure, where @x@ is an error
+ -- message.
+ }
+
+
+------------------------------------------------------------------------------
+-- | The 'Initializer' monad. The code that initialises your application's
+-- state is written in the 'Initializer' monad. It's used for constructing
+-- values which have cleanup\/destroy and reload actions associated with them.
+newtype Initializer s = Initializer (Bool -> IO (Either s (SCR s)))
+
+
+------------------------------------------------------------------------------
+-- | Values of types which are instances of 'InitializerState' have
+-- cleanup\/destroy and reload actions associated with them.
+class InitializerState s where
+ extensionId :: s -> ByteString
+ mkCleanup :: s -> IO ()
+ mkReload :: s -> IO ()
+
+
+------------------------------------------------------------------------------
+-- | Although it has the same type signature, this is not the same as 'return'
+-- in the 'Initializer' monad. Return simply lifts a value into the
+-- 'Initializer' monad, but this lifts the value and its destroy\/reload
+-- actions. Use this when making your own 'Initializer' actions.
+mkInitializer :: InitializerState s => s -> Initializer s
+mkInitializer s = Initializer $ \v -> setup v $ Right $ mkSCR v
+ where
+ handler :: SomeException -> IO (Maybe ByteString)
+ handler e = return $ Just $ toUTF8 $ show e
+ maybeCatch m = (m >> return Nothing) `catch` handler
+ maybeToMsg = maybe " done." $ const " failed."
+ name = fromUTF8 $ extensionId s
+ mkSCR v = SCR s (cleanup v) (reload v)
+ cleanup v = do
+ when v $ hPutStr stderr $ "Cleaning up " ++ name ++ "..."
+ m <- maybeCatch $ mkCleanup s
+ when v $ hPutStrLn stderr $ maybeToMsg m
+ reload v = do
+ when v $ hPutStr stderr $ "Reloading " ++ name ++ "..."
+ m <- maybeCatch $ mkReload s
+ when v $ hPutStrLn stderr $ maybeToMsg m
+ return [(extensionId s, m)]
+ setup v r = do
+ when v $ hPutStrLn stderr $ "Initializing " ++ name ++ "... done."
+ return r
+
+
+------------------------------------------------------------------------------
+-- | 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)
+
+
+------------------------------------------------------------------------------
+-- | 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')
+
+
+------------------------------------------------------------------------------
+instance Functor Initializer where
+ fmap f (Initializer r) = Initializer $ \v -> r v >>= \e -> return $ case e
of
+ Left s -> Left $ f s
+ Right (SCR s a b) -> Right $ SCR (f s) a b
+
+
+------------------------------------------------------------------------------
+instance Applicative Initializer where
+ pure = return
+ (<*>) = ap
+
+
+------------------------------------------------------------------------------
+instance Monad Initializer where
+ return = Initializer . const . return . Left
+ a >>= f = join' $ fmap f a
+
+
+------------------------------------------------------------------------------
+instance MonadIO Initializer where
+ liftIO = Initializer . const . fmap Left
+
+
+------------------------------------------------------------------------------
+-- | Join for the 'Initializer' monad. This is used in the definition of bind
+-- for the 'Initializer' monad.
+join' :: Initializer (Initializer s) -> Initializer s
+join' (Initializer r) = Initializer $ \v -> r v >>= \e -> case e of
+ Left (Initializer r') -> r' v
+ Right (SCR (Initializer r') a b) -> r' v >>= \e' -> return $ Right $ case
e' of
+ Left s -> SCR s a b
+ Right (SCR s a' b') -> SCR s (a' >> a) (liftM2 (++) b b')
+
+
+------------------------------------------------------------------------------
+-- | This takes the last value of the tuple returned by 'runInitializer',
+-- which is a list representing the results of an attempt to reload the
+-- application's Snap Extensions, and turns it into a Snap action which
+-- displays the these results.
+defaultReloadHandler :: MonadSnap m
+ => IO [(ByteString, Maybe ByteString)]
+ -> m ()
+defaultReloadHandler ioms = do
+ ms <- liftIO $ ioms
+ let showE e = mappend "Error: " $ toUTF8 $ show e
+ format (n, m) = mconcat [n, ": ", maybe "Sucess" showE m, "\n"]
+ msg = mconcat $ map format ms
+ finishWith $ setContentType "text/plain; charset=utf-8"
+ $ setContentLength (fromIntegral $ B.length msg)
+ $ modifyResponseBody (>==> enumBS msg) emptyResponse
+
+
+------------------------------------------------------------------------------
+-- | Use this reload handler to disable the ability to have a web handler
+-- which reloads Snap extensions.
+nullReloadHandler :: MonadSnap m
+ => IO [(ByteString, Maybe ByteString)]
+ -> m ()
+nullReloadHandler = const pass
+
+
+------------------------------------------------------------------------------
+fromUTF8 :: ByteString -> String
+fromUTF8 = T.unpack . T.decodeUtf8
+
+toUTF8 :: String -> ByteString
+toUTF8 = T.encodeUtf8 . T.pack
diff --git a/src/Snap/Extension/Heist.hs b/src/Snap/Extension/Heist.hs
new file mode 100644
index 0000000..db7e8c7
--- /dev/null
+++ b/src/Snap/Extension/Heist.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+{-|
+
+'Snap.Extension.Heist' exports the 'MonadHeist' interface which allows you to
+integrate Heist templates into your Snap application. The interface's
+operations are 'heistServe', 'heistServeSingle', 'heistLocal' and 'render'.
+
+'Snap.Extension.Heist.Heist' contains the only implementation of this
+interface and can be used to turn your application's monad into a
+'MonadHeist'.
+
+'MonadHeist' is unusual among Snap extensions in that it's a multi-parameter
+typeclass. The last parameter is your application's monad, and the first is
+the monad you want the 'TemplateState' to use. This is usually, but not
+always, also your application's monad.
+
+-}
+
+module Snap.Extension.Heist (MonadHeist(..)) where
+
+import Control.Applicative
+import Data.ByteString (ByteString)
+import Snap.Types
+import Text.Templating.Heist
+
+
+------------------------------------------------------------------------------
+-- | The 'MonadHeist' type class. Minimal complete definition: 'render',
+-- 'heistLocal'.
+class (Monad n, MonadSnap m) => MonadHeist n m | m -> n where
+ -- | Renders a template as text\/html. If the given template is not found,
+ -- this returns 'empty'.
+ render :: ByteString -> m ()
+
+ -- | Runs an action with a modified 'TemplateState'. You might want to use
+ -- this if you had a set of splices which were customised for a specific
+ -- action. To do that you would do:
+ --
+ -- > heistLocal (bindSplices mySplices) $ render "myTemplate"
+ heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a
+
+ -- | Analogous to 'fileServe'. If the template specified in the request
+ -- path is not found, it returns 'empty'.
+ heistServe :: m ()
+ heistServe = fmap rqPathInfo getRequest >>= render
+
+ -- | Analogous to 'fileServeSingle'. If the given template is not found,
+ -- this throws an error.
+ heistServeSingle :: ByteString -> m ()
+ heistServeSingle t = render t
+ <|> error ("Template " ++ show t ++ " not found.")
diff --git a/src/Snap/Extension/Heist/Heist.hs
b/src/Snap/Extension/Heist/Heist.hs
new file mode 100644
index 0000000..b177661
--- /dev/null
+++ b/src/Snap/Extension/Heist/Heist.hs
@@ -0,0 +1,162 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-|
+
+'Snap.Extension.Heist.Heist' is an implementation of the 'MonadHeist'
+interface defined in 'Snap.Extension.Heist'.
+
+As always, to use, add 'HeistState' to your application's state, along with an
+instance of 'HasHeistState' for your application's state, making sure to
+use a 'heistInitializer' in your application's 'Initializer', and then you're
+ready to go.
+
+'Snap.Extension.Heist.Heist' is a little different to other Snap Extensions,
+which is unfortunate as it is probably the most widely useful one. As
+explained below, 'HeistState' takes your application's monad as a type
+argument, and 'HasHeistState' is a multi-parameter type class, the additional
+first parameter also being your application's monad.
+
+Two instances of 'MonadHeist' are provided with this module. One is designed
+for users wanting to use Heist templates with their application, the other is
+designed for users writing Snap Extensions which use their own Heist templates
+internally.
+
+The first one of these instances is
+...@hasheiststate (SnapExtend s) s => MonadHeist (SnapExtend s) (SnapExtend
s)@.
+This means that any type @s@ which has a 'HeistState', whose
+'TemplateState'\'s monad is @SnapExtend s@ forms a 'MonadHeist' whose
+'TemplateState'\'s monad is @SnapExtend s@ and whose monad itself is
+...@snapextend s...@. The @s@ here is your application's state, and
@SnapExtend s@
+is your application's monad.
+
+The second one of these instances is
+...@hasheiststate m s => MonadHeist m (ReaderT s m)@. This means that any type
+...@s@ which has, for any m, a @HeistState m@, forms a 'MonadHeist', whose
+'TemplateState'\'s monad is @m@, when made the environment of
+a 'ReaderT' wrapped around @m...@. The @s@ here would be the Snap Extension's
+internal state, and the @m@ would be 'SnapExtend' wrapped around any @s'@
+which was an instance of the Snap Extension's @HasState@ class.
+
+This implementation does not require that your application's monad implement
+interfaces from any other Snap Extension.
+
+-}
+
+module Snap.Extension.Heist.Heist
+ ( HeistState
+ , HasHeistState(..)
+ , heistInitializer
+ ) where
+
+import Control.Applicative
+import Control.Concurrent.MVar
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Trans
+import qualified Data.ByteString as B
+import Snap.Extension
+import Snap.Extension.Heist
+import Snap.Types
+import Text.Templating.Heist
+import Text.Templating.Heist.Splices.Static
+
+
+------------------------------------------------------------------------------
+-- | Your application's state must include a 'HeistState' in order for your
+-- application to be a 'MonadHeist'.
+--
+-- Unlike other @-State@ types, this is of kind @(* -> *) -> *...@. Unless
you're
+-- developing your own Snap Extension which has its own internal 'HeistState',
+-- the type argument you want to pass to 'HeistState' is your application's
+-- monad, which should be 'SnapExtend' wrapped around your application's
+-- state.
+data MonadSnap m => HeistState m = HeistState
+ { _path :: FilePath
+ , _origTs :: TemplateState m
+ , _tsMVar :: MVar (TemplateState m)
+ , _sts :: StaticTagState
+ , _modifier :: TemplateState m -> TemplateState m
+ }
+
+
+------------------------------------------------------------------------------
+-- | For you appliaction's monad to be a 'MonadHeist', your application's
+-- state needs to be an instance of 'HasHeistState'. Minimal complete
+-- definition: 'getHeistState', 'setHeistState'.
+--
+-- Unlike other @HasState@ type classes, this is a type class has two
+-- parameters. Among other things, this means that you will need to enable the
+-- @FlexibleInstances@ and @MultiParameterTypeClasses@ language extensions to
+-- be able to create an instance of @hasheistst...@. In most cases, the last
+-- parameter will as usual be your application's state, and the additional
+-- first one will be the monad formed by wrapping 'SnapExtend' around your
+-- application's state.
+--
+-- However, if you are developing your own Snap Extension which uses its own
+-- internal 'HeistState', the last parameter will be your Snap Extension's
+-- internal state, and the additional first parameter will be any monad formed
+-- by wrapping @SnapExtend@ around a type which has an instance of the
+-- @HasState@ class for your monad. These two use cases are subtly different,
+-- which is why 'HasHeistState' needs two type parameters.
+class MonadSnap m => HasHeistState m s | s -> m where
+ getHeistState :: s -> HeistState m
+ setHeistState :: HeistState m -> s -> s
+
+ modifyHeistState :: (HeistState m -> HeistState m) -> s -> s
+ modifyHeistState f s = setHeistState (f $ getHeistState s) s
+
+
+------------------------------------------------------------------------------
+-- | The 'Initializer' for 'HeistState'. It takes one argument, a path to a
+-- template directory containing @.tpl@ files.
+heistInitializer :: MonadSnap m => FilePath -> Initializer (HeistState m)
+heistInitializer path = do
+ heistState <- liftIO $ do
+ (origTs,sts) <- bindStaticTag emptyTemplateState
+ loadTemplates path origTs >>= either error (\ts -> do
+ tsMVar <- newMVar ts
+ return $ HeistState path origTs tsMVar sts id)
+ mkInitializer heistState
+
+
+------------------------------------------------------------------------------
+instance MonadSnap m => InitializerState (HeistState m) where
+ extensionId = const "Heist/Heist"
+ mkCleanup = const $ return ()
+ mkReload (HeistState path origTs tsMVar sts _) = do
+ clearStaticTagCache $ sts
+ either error (modifyMVar_ tsMVar . const . return) =<<
+ loadTemplates path origTs
+
+
+------------------------------------------------------------------------------
+instance HasHeistState (SnapExtend s) s => MonadHeist (SnapExtend s)
(SnapExtend s) where
+ render t = do
+ (HeistState _ _ tsMVar _ modifier) <- asks getHeistState
+ ts <- liftIO $ fmap modifier $ readMVar tsMVar
+ renderTemplate ts t >>= maybe pass (\html -> do
+ modifyResponse $ setContentType "text/html; charset=utf-8"
+ modifyResponse $ setContentLength (fromIntegral $ B.length html)
+ writeBS html)
+
+ heistLocal f = local $ modifyHeistState $ \s ->
+ s { _modifier = f . _modifier s }
+
+
+------------------------------------------------------------------------------
+instance HasHeistState m s => MonadHeist m (ReaderT s m) where
+ render t = ReaderT $ \s -> do
+ let (HeistState _ _ tsMVar _ modifier) = getHeistState s
+ ts <- liftIO $ fmap modifier $ readMVar tsMVar
+ mt <- renderTemplate ts t
+ renderTemplate ts t >>= maybe pass (\html -> do
+ modifyResponse $ setContentType "text/html; charset=utf-8"
+ modifyResponse $ setContentLength (fromIntegral $ B.length html)
+ writeBS html)
+
+ heistLocal f = local $ modifyHeistState $ \s ->
+ s { _modifier = f . _modifier s }
diff --git a/src/Snap/Extension/Server.hs b/src/Snap/Extension/Server.hs
new file mode 100644
index 0000000..ea642c3
--- /dev/null
+++ b/src/Snap/Extension/Server.hs
@@ -0,0 +1,167 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+{-|
+
+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.
+
+-}
+
+-- 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
+ , defaultConfig
+ , getReloadHandler
+ , setReloadHandler
+ , module Snap.Http.Server.Config
+ ) where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Exception (SomeException)
+import Control.Monad
+import Control.Monad.CatchIO
+import Data.ByteString (ByteString)
+import Data.Maybe
+import Data.Monoid
+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, setUnicodeLocale)
+import qualified Snap.Http.Server.Config as C
+import Snap.Http.Server.Config hiding ( defaultConfig
+ , completeConfig
+ , getOther
+ , setOther
+ )
+import Snap.Util.GZip
+import Snap.Types
+import System.IO
+
+
+------------------------------------------------------------------------------
+-- | 'ConfigExtend' is similar to the 'Config' exported by 'Snap.Http.Server',
+-- but is augmented with a @reloadHandler@ field which can be accessed using
+-- 'getReloadHandler' and 'setReloadHandler'.
+type ConfigExtend s = Config
+ (SnapExtend s) (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())
+
+
+------------------------------------------------------------------------------
+getReloadHandler :: ConfigExtend s -> Maybe
+ (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())
+getReloadHandler = C.getOther
+
+
+------------------------------------------------------------------------------
+setReloadHandler :: (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())
+ -> ConfigExtend s
+ -> ConfigExtend s
+setReloadHandler = C.setOther
+
+
+
+
+------------------------------------------------------------------------------
+-- | These are the default values for all the fields in 'ConfigExtend'.
+--
+-- > hostname = "localhost"
+-- > address = "0.0.0.0"
+-- > port = 8000
+-- > accessLog = "log/access.log"
+-- > errorLog = "log/error.log"
+-- > locale = "en_US"
+-- > compression = True
+-- > verbose = True
+-- > errorHandler = prints the error message
+-- > reloadHandler = prints the result of each reload handler (error/success)
+--
+defaultConfig :: ConfigExtend s
+defaultConfig = setReloadHandler handler C.defaultConfig
+ where
+ handler = path "admin/reload" . defaultReloadHandler
+
+
+------------------------------------------------------------------------------
+-- | Completes a partial 'Config' by filling in the unspecified values with
+-- the default values from 'defaultConfig'.
+completeConfig :: ConfigExtend s -> ConfigExtend s
+completeConfig = mappend defaultConfig
+
+
+------------------------------------------------------------------------------
+-- | Starts serving HTTP requests using the given handler, with settings from
+-- the 'ConfigExtend' passed in. This function never returns; to shut down
+-- the HTTP server, kill the controlling thread.
+httpServe :: ConfigExtend s
+ -- ^ Any configuration options which override the defaults
+ -> Initializer s
+ -- ^ The 'Initializer' function for the application's monad
+ -> SnapExtend s ()
+ -- ^ The application to be served
+ -> IO ()
+httpServe config init handler = do
+ (state, mkCleanup, mkSnap) <-
+ runInitializerHint verbose init (catch500 handler) reloader
+#ifdef HINT
+ (cleanup, snap) <- $(loadSnapTH 'state 'mkCleanup 'mkSnap)
+#else
+ (cleanup, snap) <- fmap (mkCleanup &&& mkSnap) state
+#endif
+ let site = compress $ snap
+ mapM_ printListen $ C.getListen config
+ _ <- try $ serve $ site :: IO (Either SomeException ())
+ putStr "\n"
+ cleanup
+ output "Shutting down..."
+
+ where
+ handle :: SomeException -> IO ()
+ handle e = print e
+ conf = completeConfig config
+ verbose = fromJust $ getVerbose conf
+ output = when verbose . hPutStrLn stderr
+ reloader = fromJust $ getReloadHandler conf
+ compress = if fromJust $ getCompression conf then withCompression else id
+ catch500 = flip catch $ fromJust $ getErrorHandler conf
+ serve = simpleHttpServe config
+
+ listenToString (C.ListenHttp host port) =
+ concat ["http://";, fromUTF8 host, ":", show port, "/"]
+ listenToString (C.ListenHttps host port _ _) =
+ concat ["https://";, fromUTF8 host, ":", show port, "/"]
+
+ printListen l = output $ "Listening on " ++ listenToString l
+
+
+------------------------------------------------------------------------------
+-- | Starts serving HTTP using the given handler. The configuration is read
+-- from the options given on the command-line, as returned by
+-- 'commandLineConfig'.
+quickHttpServe :: Initializer s
+ -- ^ The 'Initializer' function for the application's monad
+ -> SnapExtend s ()
+ -- ^ The application to be served
+ -> IO ()
+quickHttpServe r m = commandLineConfig emptyConfig >>= \c -> httpServe c r m
+
+------------------------------------------------------------------------------
+fromUTF8 :: ByteString -> String
+fromUTF8 = T.unpack . T.decodeUtf8
diff --git a/src/Snap/Extension/Server/Hint.hs
b/src/Snap/Extension/Server/Hint.hs
new file mode 100644
index 0000000..54375d7
--- /dev/null
+++ b/src/Snap/Extension/Server/Hint.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+#define HINT
+#include "../Server.hs"
-----------------------------------------------------------------------
hooks/post-receive
--
snap
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
