Permalink
Browse files

Renamed Runner to Initializer and made the type of Initializer a bit …

…cleaner
  • Loading branch information...
1 parent f67ef44 commit b036f7fc05ede0b99efe5df7d444131f46eb3e63 @duairc committed Nov 11, 2010
View
2 snap-extensions.cabal
@@ -47,7 +47,7 @@ Library
monads-fd,
HDBC >= 2,
heist >= 0.2,
- hexpat >= 0.16 && < 0.17,
+ hexpat >= 0.16,
process,
snap >= 0.3 && < 0.4,
snap-core >= 0.3 && < 0.4,
View
156 src/Snap/Extension.hs
@@ -3,11 +3,11 @@
module Snap.Extension
( SnapExtend
- , Runner
- , RunnerState(..)
- , runRunner
- , runRunnerHint
- , mkRunner
+ , Initializer
+ , InitializerState(..)
+ , runInitializer
+ , runInitializerHint
+ , mkInitializer
, defaultReloadHandler
, nullReloadHandler
) where
@@ -48,34 +48,55 @@ newtype SnapExtend s a = SnapExtend (ReaderT s Snap a)
------------------------------------------------------------------------------
--- | The 'Runner' monad. This can be used for constructing values which also
--- have cleanup\/destroy and reload functions.
-newtype Runner s = Runner
- (Bool -> IO (Either s (s, IO (), IO [(ByteString, Maybe ByteString)])))
+-- | 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.
+ }
------------------------------------------------------------------------------
--- | Values of types which are instances of 'RunnerState' have
+-- | 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 RunnerState s where
+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 'Runner' monad. Return simply lifts a value into the 'Runner' monad,
--- but this lifts the value and its destroy\/reload actions. Use this when
--- making your own 'Runner' actions.
-mkRunner :: RunnerState s => s -> Runner s
-mkRunner s = Runner $ \v -> setup v $ Right (s, cleanup v, reload v)
+-- 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 $ U.fromString $ show e
maybeCatch m = (m >> return Nothing) `catch` handler
maybeToMsg = maybe " done." $ const " failed."
name = U.toString $ extensionId s
+ mkSCR v = SCR s (cleanup v) (reload v)
cleanup v = do
when v $ hPutStr stderr $ "Cleaning up " ++ name ++ "..."
m <- maybeCatch $ mkCleanup s
@@ -91,81 +112,82 @@ mkRunner s = Runner $ \v -> setup v $ Right (s, cleanup v, reload v)
------------------------------------------------------------------------------
--- | Given the runner 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.
-runRunner :: Bool
- -- ^ Verbosity; info is printed to 'stderr' when this is 'True'
- -> Runner s
- -- ^ The Runner value
- -> SnapExtend s ()
- -- ^ An action in your application's monad
- -> IO (Snap (), IO (), IO [(ByteString, Maybe ByteString)])
- -- ^ This is documented thoroughly in the README
-runRunner v (Runner r) (SnapExtend m) = r v >>= \e -> case e of
- Left s -> return (runReaderT m s, return (), return [])
- Right (s, a, b) -> return (runReaderT m s, a, b)
+-- | 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 'runRunner', but can be used with Hint. This
--- is explained in the README.
-runRunnerHint :: Bool
- -- ^ Verbosity; info is printed to 'stderr' when this is 'True'
- -> Runner s
- -- ^ The Runner 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 @loadSnapTH@.
-runRunnerHint v (Runner r) se@(SnapExtend m) f = r v >>= \e -> case e of
- Left s -> return (return s, const $ return (), runReaderT m)
- Right (s, a, b) -> let (SnapExtend m') = f b <|> se
- in return (return s, const a, runReaderT m')
+-- | 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 @loadSnapTH@.
+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 Runner where
- fmap f (Runner r) = Runner $ \v -> r v >>= \e -> return $ case e of
- Left s -> Left $ f s
- Right (s, a, b) -> Right (f s, a, b)
+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 Runner where
+instance Applicative Initializer where
pure = return
(<*>) = ap
------------------------------------------------------------------------------
-instance Monad Runner where
- return = Runner . const . return . Left
+instance Monad Initializer where
+ return = Initializer . const . return . Left
a >>= f = join' $ fmap f a
------------------------------------------------------------------------------
-instance MonadIO Runner where
- liftIO = Runner . const . fmap Left
+instance MonadIO Initializer where
+ liftIO = Initializer . const . fmap Left
------------------------------------------------------------------------------
--- | Join for the 'Runner' monad. This is used in the definition of bind for
--- the 'Runner' monad.
-join' :: Runner (Runner s) -> Runner s
-join' (Runner r) = Runner $ \v -> r v >>= \e -> case e of
- Left (Runner r') -> r' v
- Right (Runner r', a, b) -> r' v >>= \e' -> return $ Right $ case e' of
- Left s -> (s, a, b)
- Right (s, a', b') -> (s, a' >> a, liftM2 (++) b b')
+-- | 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 'runRunner', 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.
+-- | 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 ()
View
12 src/Snap/Extension/ConnectionPool.hs
@@ -13,15 +13,23 @@ monad into a 'MonadConnectionPool'.
-}
-module Snap.Extension.ConnectionPool (MonadConnectionPool(..)) where
+module Snap.Extension.ConnectionPool
+ ( MonadConnectionPool(..)
+ , IsConnectionPoolState(..)) where
+import Control.Monad.Trans
import Database.HDBC
import Snap.Types
------------------------------------------------------------------------------
-- | The 'MonadConnectionPool' type class. Minimal complete definition:
-- 'withConnection'.
-class MonadSnap m => MonadConnectionPool m where
+class MonadIO m => MonadConnectionPool m where
-- | Given an action, wait for an available connection from the pool and
-- execute the action. Return the result.
withConnection :: (forall c. IConnection c => c -> IO a) -> m a
+
+
+------------------------------------------------------------------------------
+class IsConnectionPoolState a where
+ withConnectionFromPool :: MonadIO m => (forall c. IConnection c => c -> IO b) -> a -> m b
View
42 src/Snap/Extension/ConnectionPool/ConnectionPool.hs
@@ -8,12 +8,12 @@
As always, to use, add 'ConnectionPoolState' to your application's state,
along with an instance of 'HasConnectionPoolState' for your application's
-state, making sure to use a 'connectionPoolRunner' in your application's
-'Runner', and then you're ready to go.
+state, making sure to use a 'connectionPoolInitializer' in your application's
+'Initializer', and then you're ready to go.
The 'ConnectionPoolState' has a maximum size associated with it, but it won't
not get filled up until necessary. It will not create actual connections until
-requested, it will go round-robin through the connection pool to create them.
+requested, it will go round-robin through the connection pool to create them.
This should suffice for both production (one pool for all requests until
server shutdown) and development (one pool per request) cases.
@@ -25,7 +25,7 @@ interfaces from any other Snap Extension.
module Snap.Extension.ConnectionPool.ConnectionPool
( HasConnectionPoolState(..)
, ConnectionPoolState
- , connectionPoolRunner
+ , connectionPoolInitializer
  ) where
import Control.Concurrent.Chan
@@ -66,23 +66,22 @@ data ConnectionPoolState = ConnectionPoolState
class HasConnectionPoolState s where
getConnectionPoolState :: s -> ConnectionPoolState
setConnectionPoolState :: ConnectionPoolState -> s -> s
-
------------------------------------------------------------------------------
--- | The 'Runner' for 'ConnectionPoolState'. It takes two arguments, an 'IO'
--- action which creates an instance of 'IConnection', and the desired maximum
--- size of the pool.
-connectionPoolRunner :: IConnection a
- => IO a -> Int -> Runner ConnectionPoolState
-connectionPoolRunner mkConn size = do
+-- | The 'Initializer' for 'ConnectionPoolState'. It takes two arguments, an
+-- 'IO' action which creates an instance of 'IConnection', and the desired
+-- maximum size of the pool.
+connectionPoolInitializer :: IConnection a
+ => IO a -> Int -> Initializer ConnectionPoolState
+connectionPoolInitializer mkConn size = do
chan <- liftIO newChan
liftIO $ replicateM_ size $ writeChan chan Nothing
- mkRunner $ ConnectionPoolState (mkConn >>= return . Connection) chan size
+ mkInitializer $ ConnectionPoolState (mkConn >>= return . Connection) chan size
------------------------------------------------------------------------------
-instance RunnerState ConnectionPoolState where
+instance InitializerState ConnectionPoolState where
extensionId = const "ConnectionPool/ConnectionPool"
mkCleanup (ConnectionPoolState _ chan size) = replicateM_ size $ do
@@ -95,15 +94,16 @@ instance RunnerState ConnectionPoolState where
------------------------------------------------------------------------------
instance HasConnectionPoolState s => MonadConnectionPool (SnapExtend s) where
- withConnection f = do
- (ConnectionPoolState mkConn chan _) <- asks getConnectionPoolState
- conn@(Connection c) <- liftIO $ readChan chan >>= maybe mkConn return
-     liftIO $ f c `finally` (commit c >> writeChan chan (Just conn))
+ withConnection f = asks getConnectionPoolState >>= withConnectionFromPool f
------------------------------------------------------------------------------
instance (MonadSnap m, HasConnectionPoolState s) => MonadConnectionPool (ReaderT s m) where
- withConnection f = do
- (ConnectionPoolState mkConn chan _) <- asks getConnectionPoolState
- conn@(Connection c) <- liftIO $ readChan chan >>= maybe mkConn return
-     liftIO $ f c `finally` (commit c >> writeChan chan (Just conn))
+ withConnection f = asks getConnectionPoolState >>= withConnectionFromPool f
+
+
+------------------------------------------------------------------------------
+instance IsConnectionPoolState ConnectionPoolState where
+ withConnectionFromPool f (ConnectionPoolState mkConn chan _) = liftIO $ do
+ conn@(Connection c) <- readChan chan >>= maybe mkConn return
+     f c `finally` (commit c >> writeChan chan (Just conn))
View
16 src/Snap/Extension/Heist/Heist.hs
@@ -11,8 +11,8 @@ 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 'heistRunner' in your application's 'Runner', and then you're ready to
-go.
+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
@@ -49,7 +49,7 @@ interfaces from any other Snap Extension.
module Snap.Extension.Heist.Heist
( HeistState
, HasHeistState(..)
- , heistRunner
+ , heistInitializer
) where
import Control.Applicative
@@ -111,20 +111,20 @@ class MonadSnap m => HasHeistState m s | s -> m where
------------------------------------------------------------------------------
--- | The 'Runner' for 'HeistState'. It takes one argument, a path to a
+-- | The 'Initializer' for 'HeistState'. It takes one argument, a path to a
-- template directory containing @.tpl@ files.
-heistRunner :: MonadSnap m => FilePath -> Runner (HeistState m)
-heistRunner path = do
+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)
- mkRunner heistState
+ mkInitializer heistState
------------------------------------------------------------------------------
-instance MonadSnap m => RunnerState (HeistState m) where
+instance MonadSnap m => InitializerState (HeistState m) where
extensionId = const "Heist/Heist"
mkCleanup = const $ return ()
mkReload (HeistState path origTs tsMVar sts _) = do
View
12 src/Snap/Extension/Less/Less.hs
@@ -7,7 +7,7 @@ interface defined in 'Snap.Extension.Less'.
As always, to use, add 'LessState' to your application's state, along with an
instance of 'HasLessState' for your application's state, making sure to use a
-'lessRunner' in your application's 'Runner', and then you're ready to go.
+'lessInitializer' 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.
@@ -17,7 +17,7 @@ interfaces from any other Snap Extension.
module Snap.Extension.Less.Less
( HasLessState(..)
, LessState
- , lessRunner
+ , lessInitializer
) where
import Control.Concurrent
@@ -61,17 +61,17 @@ class HasLessState s where
------------------------------------------------------------------------------
-instance RunnerState LessState where
+instance InitializerState LessState where
extensionId = const "Less/Less"
mkCleanup = const $ return ()
mkReload (LessState d m) = modifyMVar_ m $ const $ loadStylesheets d
------------------------------------------------------------------------------
--- | The Runner for the Less extension. It takes a path to a stylesheet
+-- | The Initializer for the Less extension. It takes a path to a stylesheet
-- directory containing @.less@ files.
-lessRunner :: FilePath -> Runner LessState
-lessRunner path = mkRunner =<< (liftIO $
+lessInitializer :: FilePath -> Initializer LessState
+lessInitializer path = mkInitializer =<< (liftIO $
loadStylesheets path >>= newMVar >>= return . LessState path)
View
17 src/Snap/Extension/Server.hs
@@ -5,7 +5,7 @@
{-|
This module provides replacements for the 'httpServe' and 'quickHttpServe'
-functions exported by 'Snap.Http.Server'. By taking a 'Runner' as an argument,
+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
@@ -107,17 +107,16 @@ completeConfig = mappend defaultConfig
-- the HTTP server, kill the controlling thread.
httpServe :: ConfigExtend s
-- ^ Any configuration options which override the defaults
- -> Runner s
- -- ^ The 'Runner' function for the application's monad
+ -> Initializer s
+ -- ^ The 'Initializer' function for the application's monad
-> SnapExtend s ()
-- ^ The application to be served
-> IO ()
-httpServe config runner handler = do
+httpServe config init handler = do
(state, mkCleanup, mkSnap) <-
- runRunnerHint verbose runner (catch500 handler) reloader
+ runInitializerHint verbose init (catch500 handler) reloader
#ifdef HINT
- (cleanup, snap) <-
- $(loadSnapTH 'state 'mkCleanup 'mkSnap)
+ (cleanup, snap) <- $(loadSnapTH 'state 'mkCleanup 'mkSnap)
#else
(cleanup, snap) <- fmap (mkCleanup &&& mkSnap) state
#endif
@@ -145,8 +144,8 @@ httpServe config runner handler = do
-- | Starts serving HTTP using the given handler. The configuration is read
-- from the options given on the command-line, as returned by
-- 'commandLineConfig'.
-quickHttpServe :: Runner s
- -- ^ The 'Runner' function for the application's monad
+quickHttpServe :: Initializer s
+ -- ^ The 'Initializer' function for the application's monad
-> SnapExtend s ()
-- ^ The application to be served
-> IO ()
View
12 src/Snap/Extension/Timer/Timer.hs
@@ -7,7 +7,7 @@ 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
-'timerRunner' in your application's 'Runner', and then you're ready to go.
+'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.
@@ -17,7 +17,7 @@ interfaces from any other Snap Extension.
module Snap.Extension.Timer.Timer
( TimerState
, HasTimerState(..)
- , timerRunner
+ , timerInitializer
) where
import Control.Monad.Reader
@@ -45,13 +45,13 @@ class HasTimerState s where
------------------------------------------------------------------------------
--- | The runner for 'TimerState'. No arguments are required.
-timerRunner :: Runner TimerState
-timerRunner = liftIO getCurrentTime >>= mkRunner . TimerState
+-- | The Initializer for 'TimerState'. No arguments are required.
+timerInitializer :: Initializer TimerState
+timerInitializer = liftIO getCurrentTime >>= mkInitializer . TimerState
------------------------------------------------------------------------------
-instance RunnerState TimerState where
+instance InitializerState TimerState where
extensionId = const "Timer/Timer"
mkCleanup = const $ return ()
mkReload = const $ return ()

0 comments on commit b036f7f

Please sign in to comment.