Permalink
Browse files

Add environment support to the snaplet infrastructure. This allows yo…

…u to switch between different config file sets with a -e option on the command line. The new default config filename is now devel.cfg instead of snaplet.cfg.
  • Loading branch information...
1 parent a3c197a commit fd794635a84a80c292a3caa3c9ff6a385dc0e332 @mightybyte mightybyte committed Apr 19, 2012
View
12 project_template/default/src/Main.hs
@@ -8,6 +8,7 @@ import Control.Exception (SomeException, try)
import qualified Data.Text as T
import Snap.Http.Server
import Snap.Snaplet
+import Snap.Snaplet.Config
import Snap.Core
import System.IO
import Site
@@ -77,8 +78,8 @@ main = do
--
-- This action is only run once, regardless of whether development or
-- production mode is in use.
-getConf :: IO (Config Snap ())
-getConf = commandLineConfig defaultConfig
+getConf :: IO (Config Snap AppConfig)
+getConf = commandLineAppConfig defaultConfig
------------------------------------------------------------------------------
@@ -93,8 +94,9 @@ getConf = commandLineConfig defaultConfig
--
-- This sample doesn't actually use the config passed in, but more
-- sophisticated code might.
-getActions :: Config Snap () -> IO (Snap (), IO ())
-getActions _ = do
- (msgs, site, cleanup) <- runSnaplet app
+getActions :: Config Snap AppConfig -> IO (Snap (), IO ())
+getActions conf = do
+ (msgs, site, cleanup) <- runSnaplet
+ (appEnvironment =<< getOther conf) app
hPutStrLn stderr $ T.unpack msgs
return (site, cleanup)
View
3 snap.cabal
@@ -88,6 +88,7 @@ Library
Snap.Snaplet.Heist,
Snap.Snaplet.Auth,
Snap.Snaplet.Auth.Backends.JsonFile,
+ Snap.Snaplet.Config,
Snap.Snaplet.Session,
Snap.Snaplet.Session.Common,
Snap.Snaplet.Session.Backends.CookieSession
@@ -204,7 +205,7 @@ Executable snap
directory-tree >= 0.10 && < 0.11,
filepath >= 1.1 && < 1.4,
old-time >= 1.0 && < 1.2,
- snap-server >= 0.8 && < 0.9,
+ snap-server >= 0.9 && < 0.10,
template-haskell >= 2.2 && < 2.8,
text >= 0.11 && < 0.12
View
48 src/Snap/Snaplet/Config.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Snap.Snaplet.Config where
+
+import Data.Function
+import Data.Maybe
+import Data.Monoid
+import Snap.Core
+import Snap.Http.Server.Config
+import System.Console.GetOpt
+
+------------------------------------------------------------------------------
+-- | AppConfig contains the config options for command line arguments in
+-- snaplet-based apps.
+newtype AppConfig = AppConfig { appEnvironment :: Maybe String }
+
+
+------------------------------------------------------------------------------
+instance Monoid AppConfig where
+ mempty = AppConfig Nothing
+ mappend a b = AppConfig
+ { appEnvironment = ov appEnvironment a b
+ }
+ where
+ ov f x y = getLast $! (mappend `on` (Last . f)) x y
+
+
+appOpts :: AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
+appOpts defaults = map (fmapOpt $ fmap (flip setOther mempty))
+ [ Option ['e'] ["environment"]
+ (ReqArg (\s -> Just $ mempty { appEnvironment = Just s}) "ENVIRONMENT")
+ $ "runtime environment to use" ++ defaultC appEnvironment
+ ]
+ where
+ defaultC f = maybe "" ((", default " ++) . show) $ f defaults
+
+
+commandLineAppConfig :: MonadSnap m
+ => Config m AppConfig
+ -> IO (Config m AppConfig)
+commandLineAppConfig defaults =
+ extendedCommandLineConfig (appOpts appDefaults ++ optDescrs defaults)
+ combine defaults
+ where
+ appDefaults = fromMaybe (AppConfig Nothing) $ getOther defaults
+ combine :: AppConfig -> AppConfig -> AppConfig
+ combine a b = AppConfig $ (mappend `on` appEnvironment) a b
+
View
42 src/Snap/Snaplet/Internal/Initializer.hs
@@ -46,6 +46,7 @@ import System.Directory.Tree
import System.FilePath.Posix
import System.IO
+import Snap.Snaplet.Config
import qualified Snap.Snaplet.Internal.LensT as LT
import qualified Snap.Snaplet.Internal.Lensed as L
import Snap.Snaplet.Internal.Types
@@ -209,10 +210,11 @@ makeSnaplet snapletId desc getSnapletDataDir m = SnapletInit $ do
]
-- This has to happen here because it needs to be after scFilePath is set
- -- up but before snaplet.cfg is read.
+ -- up but before the config file is read.
setupFilesystem getSnapletDataDir (_scFilePath cfg)
- let configLocation = _scFilePath cfg </> "snaplet.cfg"
+ env <- iGets _environment
+ let configLocation = _scFilePath cfg </> (env ++ ".cfg")
liftIO $ addToConfig [Optional configLocation]
(_scUserConfig cfg)
mkSnaplet m
@@ -414,11 +416,12 @@ printInfo msg = do
------------------------------------------------------------------------------
-- | Builds an IO reload action for storage in the SnapletState.
mkReloader :: FilePath
+ -> String
-> MVar (Snaplet b)
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
-mkReloader cwd mvar i = do
- !res <- runInitializer' mvar i cwd
+mkReloader cwd env mvar i = do
+ !res <- runInitializer' mvar env i cwd
either (return . Left) good res
where
good (b,is) = do
@@ -445,26 +448,30 @@ runBase (Handler m) mvar = do
-- containing the exception details as well as all messages generated by the
-- initializer before the exception was thrown.
runInitializer :: MVar (Snaplet b)
+ -> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
-runInitializer mvar b = getCurrentDirectory >>= runInitializer' mvar b
+runInitializer mvar env b =
+ getCurrentDirectory >>= runInitializer' mvar env b
------------------------------------------------------------------------------
runInitializer' :: MVar (Snaplet b)
+ -> String
-> Initializer b b (Snaplet b)
-> FilePath
-> IO (Either Text (Snaplet b, InitializerState b))
-runInitializer' mvar b@(Initializer i) cwd = do
+runInitializer' mvar env b@(Initializer i) cwd = do
let builtinHandlers = [("/admin/reload", reloadSite)]
let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing
- (mkReloader cwd mvar b)
+ (mkReloader cwd env mvar b)
logRef <- newIORef ""
cleanupRef <- newIORef (return ())
let body = do
((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $
InitializerState True cleanupRef builtinHandlers id cfg logRef
+ env
res' <- hook res
return $ Right (res', s)
@@ -484,12 +491,16 @@ runInitializer' mvar b@(Initializer i) cwd = do
------------------------------------------------------------------------------
--- | Given a Snaplet initializer, produce the set of messages generated during
--- initialization, a snap handler, and a cleanup action.
-runSnaplet :: SnapletInit b b -> IO (Text, Snap (), IO ())
-runSnaplet (SnapletInit b) = do
+-- | Given an envirnoment and a Snaplet initializer, produce the set of
+-- messages generated during initialization, a snap handler, and a cleanup
+-- action. The environment is an arbitrary string such as "devel" or
+-- "production". This string is used to determine the name of the config
+-- files used each snaplet. If an environment of Nothing is used, then
+-- runSnaplet defaults to "devel".
+runSnaplet :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
+runSnaplet env (SnapletInit b) = do
snapletMVar <- newEmptyMVar
- eRes <- runInitializer snapletMVar b
+ eRes <- runInitializer snapletMVar (fromMaybe "devel" env) b
let go (siteSnaplet,is) = do
putMVar snapletMVar siteSnaplet
msgs <- liftIO $ readIORef $ _initMessages is
@@ -518,11 +529,12 @@ combineConfig config handler = do
------------------------------------------------------------------------------
-- | Serves a top-level snaplet as a web application. Reads command-line
-- arguments. FIXME: document this.
-serveSnaplet :: Config Snap a -> SnapletInit b b -> IO ()
+serveSnaplet :: Config Snap AppConfig -> SnapletInit b b -> IO ()
serveSnaplet startConfig initializer = do
- (msgs, handler, doCleanup) <- runSnaplet initializer
+ config <- commandLineAppConfig startConfig
+ let env = appEnvironment =<< getOther config
+ (msgs, handler, doCleanup) <- runSnaplet env initializer
- config <- commandLineConfig startConfig
(conf, site) <- combineConfig config handler
createDirectoryIfMissing False "log"
let serve = simpleHttpServe conf
View
1 src/Snap/Snaplet/Internal/Types.hs
@@ -332,6 +332,7 @@ data InitializerState b = InitializerState
-- ^ This snaplet config is the incrementally built config for whatever
-- snaplet is currently being constructed.
, _initMessages :: IORef Text
+ , _environment :: String
}

0 comments on commit fd79463

Please sign in to comment.