snap 0.8.1 → 0.9.0
raw patch · 33 files changed
+303/−681 lines, 33 filesdep −hintdep ~snap-coredep ~snap-serverdep ~xmlhtmlPVP ok
version bump matches the API change (PVP)
Dependencies removed: hint
Dependency ranges changed: snap-core, snap-server, xmlhtml
API changes (from Hackage documentation)
- Snap.Loader.Devel: loadSnapTH :: Q Exp -> Name -> [String] -> Q Exp
- Snap.Loader.Prod: loadSnapTH :: Q Exp -> Name -> [String] -> Q Exp
+ Snap.Snaplet.Config: AppConfig :: Maybe String -> AppConfig
+ Snap.Snaplet.Config: appConfigTyCon :: TyCon
+ Snap.Snaplet.Config: appEnvironment :: AppConfig -> Maybe String
+ Snap.Snaplet.Config: appOpts :: AppConfig -> [OptDescr (Maybe (Config m AppConfig))]
+ Snap.Snaplet.Config: commandLineAppConfig :: MonadSnap m => Config m AppConfig -> IO (Config m AppConfig)
+ Snap.Snaplet.Config: instance Monoid AppConfig
+ Snap.Snaplet.Config: instance Typeable AppConfig
+ Snap.Snaplet.Config: newtype AppConfig
- Snap.Snaplet: runSnaplet :: SnapletInit b b -> IO (Text, Snap (), IO ())
+ Snap.Snaplet: runSnaplet :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
- Snap.Snaplet: serveSnaplet :: Config Snap a -> SnapletInit b b -> IO ()
+ Snap.Snaplet: serveSnaplet :: Config Snap AppConfig -> SnapletInit b b -> IO ()
Files
- project_template/barebones/foo.cabal +5/−5
- project_template/default/foo.cabal +7/−5
- project_template/default/snaplets/heist/templates/base.tpl +13/−0
- project_template/default/snaplets/heist/templates/echo.tpl +0/−13
- project_template/default/snaplets/heist/templates/index.tpl +19/−32
- project_template/default/snaplets/heist/templates/login.tpl +11/−0
- project_template/default/snaplets/heist/templates/new_user.tpl +9/−0
- project_template/default/snaplets/heist/templates/userform.tpl +14/−0
- project_template/default/src/Application.hs +5/−4
- project_template/default/src/Main.hs +9/−7
- project_template/default/src/Site.hs +40/−43
- project_template/tutorial/foo.cabal +6/−6
- snap.cabal +16/−29
- src/Snap/Loader/Devel.hs +0/−213
- src/Snap/Loader/Devel/Evaluator.hs +0/−140
- src/Snap/Loader/Devel/Signal.hs +0/−57
- src/Snap/Loader/Devel/TreeWatcher.hs +0/−40
- src/Snap/Loader/Prod.hs +0/−27
- src/Snap/Snaplet/Auth/Handlers.hs +2/−3
- src/Snap/Snaplet/Config.hs +65/−0
- src/Snap/Snaplet/Internal/Initializer.hs +27/−15
- src/Snap/Snaplet/Internal/Types.hs +1/−0
- test/foosnaplet/devel.cfg +2/−0
- test/foosnaplet/snaplet.cfg +0/−2
- test/non-cabal-appdir/devel.cfg +6/−0
- test/non-cabal-appdir/snaplet.cfg +0/−6
- test/non-cabal-appdir/snaplets/baz/devel.cfg +2/−0
- test/non-cabal-appdir/snaplets/baz/snaplet.cfg +0/−2
- test/snap-testsuite.cabal +8/−7
- test/suite/Blackbox/Tests.hs +18/−12
- test/suite/Snap/Snaplet/Internal/Tests.hs +1/−1
- test/suite/Snap/TestCommon.hs +13/−8
- test/suite/TestSuite.hs +4/−4
project_template/barebones/foo.cabal view
@@ -15,12 +15,12 @@ main-is: Main.hs Build-depends:- base >= 4 && < 5,- bytestring >= 0.9.1 && < 0.10,+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.10, MonadCatchIO-transformers >= 0.2.1 && < 0.4,- mtl >= 2 && < 3,- snap-core == 0.8.*,- snap-server == 0.8.*+ mtl >= 2 && < 3,+ snap-core >= 0.9 && < 0.10,+ snap-server >= 0.9 && < 0.10 if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
project_template/default/foo.cabal view
@@ -26,14 +26,17 @@ heist >= 0.8 && < 0.9, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3,- snap == 0.8.*,- snap-core == 0.8.*,- snap-server == 0.8.*,+ snap == 0.9.*,+ snap-core == 0.9.*,+ snap-server == 0.9.*,+ snap-loader-static == 0.9.*, text >= 0.11 && < 0.12, time >= 1.1 && < 1.5,- xmlhtml == 0.1.*+ xmlhtml >= 0.1 if flag(development)+ build-depends:+ snap-loader-dynamic == 0.9.* cpp-options: -DDEVELOPMENT -- In development mode, speed is already going to suffer, so skip -- the fancy optimization flags. Additionally, disable all@@ -48,4 +51,3 @@ else ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-orphans-
+ project_template/default/snaplets/heist/templates/base.tpl view
@@ -0,0 +1,13 @@+<html>+ <head>+ <title>Snap web server</title>+ <link rel="stylesheet" type="text/css" href="/screen.css"/>+ </head>+ <body>+ <div id="content">++ <content/>++ </div>+ </body>+</html>
− project_template/default/snaplets/heist/templates/echo.tpl
@@ -1,13 +0,0 @@-<html>- <head>- <title>Echo Page</title>- </head>- <body>- <div id="content">- <h1>Is there an echo in here?</h1>- </div>- <p>You wanted me to say this?</p>- <p>"<message/>"</p>- <p><a href="/">Return</a></p>- </body>-</html>
project_template/default/snaplets/heist/templates/index.tpl view
@@ -1,32 +1,19 @@-<html>- <head>- <title>Snap web server</title>- <link rel="stylesheet" type="text/css" href="/screen.css"/>- </head>- <body>- <div id="content">- <h1>It works!</h1>- <p>- This is a simple demo page served using- <a href="http://snapframework.com/docs/tutorials/heist">Heist</a>- and the <a href="http://snapframework.com/">Snap</a> web framework.- </p>- <p>- Echo test:- <a href="/echo/cats">cats</a>- <a href="/echo/dogs">dogs</a>- <a href="/echo/fish">fish</a>- </p>- <table id="info">- <tr>- <td>Config generated at:</td>- <td><start-time/></td>- </tr>- <tr>- <td>Page generated at:</td>- <td><current-time/></td>- </tr>- </table>- </div>- </body>-</html>+<apply template="base">++ <ifLoggedIn>+ <p>+ This is a simple demo page served using+ <a href="http://snapframework.com/docs/tutorials/heist">Heist</a>+ and the <a href="http://snapframework.com/">Snap</a> web framework.+ </p>++ <p>Congrats! You're logged in as '<loggedInUser/>'</p>++ <p><a href="/logout">Logout</a></p>+ </ifLoggedIn>++ <ifLoggedOut>+ <apply template="login"/>+ </ifLoggedOut>++</apply>
+ project_template/default/snaplets/heist/templates/login.tpl view
@@ -0,0 +1,11 @@+<apply template="base">+ <h1>Snap Example App Login</h1>++ <p><loginError/></p>++ <bind tag="postAction">/login</bind>+ <bind tag="submitText">Login</bind>+ <apply template="userform"/>++ <p>Don't have a login yet? <a href="/new_user">Create a new user</a></p>+</apply>
+ project_template/default/snaplets/heist/templates/new_user.tpl view
@@ -0,0 +1,9 @@+<apply template="base">++ <h1>Register a new user</h1>++ <bind tag="postAction">/new_user</bind>+ <bind tag="submitText">Add User</bind>+ <apply template="userform"/>++</apply>
+ project_template/default/snaplets/heist/templates/userform.tpl view
@@ -0,0 +1,14 @@+<form method="post" action="${postAction}">+ <table id="info">+ <tr>+ <td>Login:</td><td><input type="text" name="login" size="20" /></td>+ </tr>+ <tr>+ <td>Password:</td><td><input type="password" name="password" size="20" /></td>+ </tr>+ <tr>+ <td></td>+ <td><input type="submit" value="${submitText}" /></td>+ </tr>+ </table>+</form>
project_template/default/src/Application.hs view
@@ -2,20 +2,21 @@ ------------------------------------------------------------------------------ -- | This module defines our application's state type and an alias for its--- handler monad.---+-- handler monad. module Application where ------------------------------------------------------------------------------ import Data.Lens.Template-import Data.Time.Clock import Snap.Snaplet import Snap.Snaplet.Heist+import Snap.Snaplet.Auth+import Snap.Snaplet.Session ------------------------------------------------------------------------------ data App = App { _heist :: Snaplet (Heist App)- , _startTime :: UTCTime+ , _sess :: Snaplet SessionManager+ , _auth :: Snaplet (AuthManager App) } makeLens ''App
project_template/default/src/Main.hs view
@@ -8,14 +8,15 @@ 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 #ifdef DEVELOPMENT-import Snap.Loader.Devel+import Snap.Loader.Dynamic #else-import Snap.Loader.Prod+import Snap.Loader.Static #endif @@ -63,7 +64,7 @@ 'getActions ["snaplets/heist/templates"]) - _ <- try $ httpServe conf $ site :: IO (Either SomeException ())+ _ <- try $ httpServe conf site :: IO (Either SomeException ()) cleanup @@ -77,7 +78,7 @@ -- -- This action is only run once, regardless of whether development or -- production mode is in use.-getConf :: IO (Config Snap ())+getConf :: IO (Config Snap AppConfig) getConf = commandLineConfig defaultConfig @@ -93,8 +94,9 @@ -- -- 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)
project_template/default/src/Site.hs view
@@ -2,89 +2,86 @@ ------------------------------------------------------------------------------ -- | This module is where all the routes and handlers are defined for your--- site. The 'app' function is the initializer that combines everything--- together and is exported by this module.---+-- site. The 'app' function is the initializer that combines everything+-- together and is exported by this module. module Site ( app ) where ------------------------------------------------------------------------------ import Control.Applicative-import Control.Monad.Trans-import Control.Monad.State import Data.ByteString (ByteString) import Data.Maybe import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Time.Clock import Snap.Core import Snap.Snaplet+import Snap.Snaplet.Auth+import Snap.Snaplet.Auth.Backends.JsonFile import Snap.Snaplet.Heist+import Snap.Snaplet.Session.Backends.CookieSession import Snap.Util.FileServe import Text.Templating.Heist-import Text.XmlHtml hiding (render) ------------------------------------------------------------------------------ import Application --------------------------------------------------------------------------------- | Renders the front page of the sample site.------ The 'ifTop' is required to limit this to the top of a route.--- Otherwise, the way the route table is currently set up, this action--- would be given every request.-index :: Handler App App ()-index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"+-- | Render login form+handleLogin :: Maybe T.Text -> Handler App (AuthManager App) ()+handleLogin authError = heistLocal (bindSplices errs) $ render "login" where- indexSplices =- [ ("start-time", startTimeSplice)- , ("current-time", currentTimeSplice)- ]+ errs = [("loginError", textSplice c) | c <- maybeToList authError] --------------------------------------------------------------------------------- | For your convenience, a splice which shows the start time.-startTimeSplice :: Splice AppHandler-startTimeSplice = do- time <- lift $ gets _startTime- return $ [TextNode $ T.pack $ show $ time]+-- | Handle login submit+handleLoginSubmit :: Handler App (AuthManager App) ()+handleLoginSubmit =+ loginUser "login" "password" Nothing+ (\_ -> handleLogin err) (redirect "/")+ where+ err = Just "Unknown user or password" --------------------------------------------------------------------------------- | For your convenience, a splice which shows the current time.-currentTimeSplice :: Splice AppHandler-currentTimeSplice = do- time <- liftIO getCurrentTime- return $ [TextNode $ T.pack $ show $ time]+-- | Logs out and redirects the user to the site index.+handleLogout :: Handler App (AuthManager App) ()+handleLogout = logout >> redirect "/" --------------------------------------------------------------------------------- | Renders the echo page.-echo :: Handler App App ()-echo = do- message <- decodedParam "stuff"- heistLocal (bindString "message" (T.decodeUtf8 message)) $ render "echo"+-- | Handle new user form submit+handleNewUser :: Handler App (AuthManager App) ()+handleNewUser = method GET handleForm <|> method POST handleFormSubmit where- decodedParam p = fromMaybe "" <$> getParam p+ handleForm = render "new_user"+ handleFormSubmit = registerUser "login" "password" >> redirect "/" ------------------------------------------------------------------------------ -- | The application's routes. routes :: [(ByteString, Handler App App ())]-routes = [ ("/", index)- , ("/echo/:stuff", echo)- , ("", with heist heistServe)- , ("", serveDirectory "static")+routes = [ ("/login", with auth handleLoginSubmit)+ , ("/logout", with auth handleLogout)+ , ("/new_user", with auth handleNewUser)+ , ("", serveDirectory "static") ] + ------------------------------------------------------------------------------ -- | The application initializer. app :: SnapletInit App App app = makeSnaplet "app" "An snaplet example application." Nothing $ do- sTime <- liftIO getCurrentTime- h <- nestSnaplet "heist" heist $ heistInit "templates"- addRoutes routes- return $ App h sTime+ h <- nestSnaplet "" heist $ heistInit "templates"+ s <- nestSnaplet "sess" sess $+ initCookieSessionManager "site_key.txt" "sess" (Just 3600) + -- NOTE: We're using initJsonFileAuthManager here because it's easy and+ -- doesn't require any kind of database server to run. In practice,+ -- you'll probably want to change this to a more robust auth backend.+ a <- nestSnaplet "auth" auth $+ initJsonFileAuthManager defAuthSettings sess "users.json"+ addRoutes routes+ addAuthSplices auth+ return $ App h s a
project_template/tutorial/foo.cabal view
@@ -15,13 +15,13 @@ main-is: Tutorial.lhs Build-depends:- base >= 4 && < 5,- bytestring >= 0.9.1 && < 0.10,+ base >= 4 && < 5,+ bytestring >= 0.9.1 && < 0.10, MonadCatchIO-transformers >= 0.2.1 && < 0.4,- mtl >= 2 && < 3,- snap == 0.8.*,- snap-core == 0.8.*,- snap-server == 0.8.*+ mtl >= 2 && < 3,+ snap >= 0.9 && < 0.10,+ snap-core >= 0.9 && < 0.10,+ snap-server >= 0.9 && < 0.10 if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
snap.cabal view
@@ -1,5 +1,5 @@ name: snap-version: 0.8.1+version: 0.9.0 synopsis: Snap: A Haskell Web Framework: project starter executable and glue code library description: Snap Framework project starter executable and glue code library license: BSD3@@ -25,8 +25,11 @@ project_template/default/log/access.log, project_template/default/log/error.log, project_template/default/static/screen.css,- project_template/default/snaplets/heist/templates/echo.tpl,+ project_template/default/snaplets/heist/templates/base.tpl, project_template/default/snaplets/heist/templates/index.tpl,+ project_template/default/snaplets/heist/templates/login.tpl,+ project_template/default/snaplets/heist/templates/new_user.tpl,+ project_template/default/snaplets/heist/templates/userform.tpl, project_template/default/src/Application.hs, project_template/default/src/Main.hs, project_template/default/src/Site.hs,@@ -60,7 +63,7 @@ test/non-cabal-appdir/bad.tpl, test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl, test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl,- test/non-cabal-appdir/snaplets/baz/snaplet.cfg,+ test/non-cabal-appdir/snaplets/baz/devel.cfg, test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl, test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl, test/non-cabal-appdir/snaplets/heist/templates/index.tpl,@@ -69,25 +72,20 @@ test/non-cabal-appdir/snaplets/heist/templates/page.tpl, test/non-cabal-appdir/good.tpl, test/non-cabal-appdir/log/placeholder,- test/non-cabal-appdir/snaplet.cfg,+ test/non-cabal-appdir/devel.cfg, test/foosnaplet/templates/foopage.tpl,- test/foosnaplet/snaplet.cfg--Flag hint- Description: Support dynamic project reloading via hint- Default: False+ test/foosnaplet/devel.cfg Library hs-source-dirs: src exposed-modules: Snap,- Snap.Loader.Prod,- Snap.Loader.Devel, Snap.Snaplet, 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@@ -113,21 +111,9 @@ Snap.Snaplet.Session.SecureCookie, Snap.Snaplet.Session.SessionManager - if flag(hint)- other-modules:- Snap.Loader.Devel.Evaluator,- Snap.Loader.Devel.Signal,- Snap.Loader.Devel.TreeWatcher-- cpp-options: -DHINT_ENABLED-- build-depends:- hint >= 0.3.3.1 && < 0.4,- old-time >= 1.0 && < 1.2- if !os(windows) build-depends:- unix >= 2.2.0.0 && < 2.6+ unix >= 2.2.0.0 && < 2.6 build-depends: MonadCatchIO-transformers >= 0.2 && < 0.4,@@ -136,7 +122,7 @@ base >= 4 && < 5, bytestring >= 0.9.1 && < 0.10, cereal >= 0.3 && < 0.4,- clientsession >= 0.7.3.6 && <0.8,+ clientsession >= 0.7.3.6 && < 0.8, configurator >= 0.1 && < 0.3, containers >= 0.3 && < 0.5, directory >= 1.0 && < 1.2,@@ -150,8 +136,8 @@ mtl > 2.0 && < 2.2, mwc-random >= 0.8 && < 0.13, pwstore-fast >= 2.2 && < 2.3,- snap-core >= 0.8.1 && < 0.9,- snap-server >= 0.8.1 && < 0.9,+ snap-core >= 0.9 && < 0.10,+ snap-server >= 0.9 && < 0.10, stm >= 2.2 && < 2.4, syb >= 0.1 && < 0.4, template-haskell >= 2.2 && < 2.8,@@ -162,7 +148,7 @@ utf8-string >= 0.3 && < 0.4, vector >= 0.7.1 && < 0.10, vector-algorithms >= 0.4 && < 0.6,- xmlhtml >= 0.1 && < 0.2+ xmlhtml >= 0.1 && < 0.3 extensions: BangPatterns,@@ -177,6 +163,7 @@ OverloadedStrings, PackageImports, Rank2Types,+ RecordWildCards, ScopedTypeVariables, TemplateHaskell, TypeFamilies,@@ -204,7 +191,7 @@ 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
− src/Snap/Loader/Devel.hs
@@ -1,213 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}----------------------------------------------------------------------------------- | This module includes the machinery necessary to use hint to load--- action code dynamically. It includes a Template Haskell function--- 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.Devel- ( loadSnapTH- ) where---------------------------------------------------------------------------------#ifdef HINT_ENABLED-import Control.Monad (liftM2)-import Data.Char (isAlphaNum)-import Data.List-import Data.Maybe (maybeToList)-import Data.Time.Clock (diffUTCTime, getCurrentTime)-import Data.Typeable-import Language.Haskell.Interpreter hiding (lift, liftIO, typeOf)-import Language.Haskell.Interpreter.Unsafe-import Language.Haskell.TH-import System.Environment (getArgs)-import Snap.Core-import Snap.Loader.Devel.Signal-import Snap.Loader.Devel.Evaluator-import Snap.Loader.Devel.TreeWatcher-#else-import Language.Haskell.TH-#endif------------------------------------------------------------------------------------ | This function derives all the information necessary to use the interpreter--- from the compile-time environment, and compiles it in to the generated code.------ This could be considered a TH wrapper around a function------ > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ()))--- > -> [String] -> IO (a, Snap (), IO ())------ with a magical implementation. The [String] argument is a list of--- directories to watch for updates to trigger a reloading. Directories--- containing code should be automatically picked up by this splice.------ The generated splice executes the initialiser once, sets up the interpreter--- for the load function, and returns the initializer's result along with the--- interpreter's proxy handler and cleanup actions. The behavior of the proxy--- actions will change to reflect changes in the watched files, reinterpreting--- the load function as needed and applying it to the initializer result.------ This will handle reloading the application successfully in most cases. The--- cases in which it is certain to fail are those involving changing the types--- of the initializer or the load function, or changing the compiler options--- required, such as by changing/adding dependencies in the project's .cabal--- file. In those cases, a full recompile will be needed.----loadSnapTH :: Q Exp -- ^ the initializer expression- -> Name -- ^ the name of the load function- -> [String] -- ^ a list of directories to watch in addition- -- to those containing code- -> Q Exp-#ifndef HINT_ENABLED-loadSnapTH _ _ _ = fail $- concat [ "Snap was built without hint support. Hint "- , "support is necessary for development mode. "- , "Please reinstall snap with hint support.\n\n "- , " cabal install snap -fhint\n\n" ]-#else-loadSnapTH initializer action additionalWatchDirs = do- args <- runIO getArgs-- let opts = getHintOpts args- srcPaths = additionalWatchDirs ++ getSrcPaths args-- -- The first line is an extra type check to ensure the arguments- -- provided have the the correct types- [| do let _ = $initializer >>= $(varE action)- v <- $initializer- (handler, cleanup) <- hintSnap opts actMods srcPaths loadStr v- return (v, handler, cleanup) |]- where- actMods = maybeToList $ nameModule action- loadStr = nameBase action------------------------------------------------------------------------------------ | Convert the command-line arguments passed in to options for the--- hint interpreter. This is somewhat brittle code, based on a few--- experimental datapoints regarding the structure of the command-line--- arguments cabal produces.-getHintOpts :: [String] -> [String]-getHintOpts args = removeBad opts- where- --------------------------------------------------------------------------- bad = ["-threaded", "-O"]-- --------------------------------------------------------------------------- removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad)-- --------------------------------------------------------------------------- hideAll = filter (== "-hide-all-packages") args-- --------------------------------------------------------------------------- srcOpts = filter (\x -> "-i" `isPrefixOf` x- && not ("-idist" `isPrefixOf` x))- args-- --------------------------------------------------------------------------- toCopy = filter (not . isSuffixOf ".hs") $- dropWhile (not . ("-package" `isPrefixOf`)) args-- --------------------------------------------------------------------------- copy = map (intercalate " ")- . groupBy (\_ s -> not $ "-" `isPrefixOf` s)-- --------------------------------------------------------------------------- opts = concat [hideAll, srcOpts, copy toCopy]------------------------------------------------------------------------------------ | This function extracts the source paths from the compilation args-getSrcPaths :: [String] -> [String]-getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg- where- srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x)------------------------------------------------------------------------------------ | This function creates the Snap handler that actually is responsible for--- doing the dynamic loading of actions via hint, given all of the--- configuration information that the interpreter needs. It also ensures safe--- concurrent access to the interpreter, and caches the interpreter results for--- a short time before allowing it to run again.------ Generally, this won't be called manually. Instead, loadSnapTH will generate--- a call to it at compile-time, calculating all the arguments from its--- environment.----hintSnap :: Typeable a- => [String]- -- ^ A list of command-line options for the interpreter- -> [String]- -- ^ A list of modules that need to be interpreted. This should- -- contain only the modules which contain the initialization,- -- cleanup, and handler actions. Everything else they require will- -- be loaded transitively.- -> [String]- -- ^ A list of paths to watch for updates- -> String- -- ^ The name of the function to load- -> a- -- ^ The value to apply the loaded function to- -> IO (Snap (), IO ())-hintSnap opts modules srcPaths action value =- protectedHintEvaluator initialize test loader-- where- --------------------------------------------------------------------------- witness x = undefined $ x `asTypeOf` value :: HintLoadable-- --------------------------------------------------------------------------- -- This is somewhat fragile, and probably can be cleaned up with a future- -- version of Typeable. For the moment, and backwards-compatibility, this- -- is the approach being taken.- witnessModules = map (reverse . drop 1 . dropWhile (/= '.') . reverse) .- filter (elem '.') . groupBy typePart . show . typeOf $- witness-- --------------------------------------------------------------------------- typePart x y = (isAlphaNum x && isAlphaNum y) || x == '.' || y == '.'-- --------------------------------------------------------------------------- interpreter = do- loadModules . nub $ modules- setImports . nub $ "Prelude" : witnessModules ++ modules-- f <- interpret action witness- return $ f value-- --------------------------------------------------------------------------- loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter-- --------------------------------------------------------------------------- formatOnError (Left err) = error $ format err- formatOnError (Right a) = a-- --------------------------------------------------------------------------- loader = formatOnError `fmap` protectHandlers loadInterpreter-- --------------------------------------------------------------------------- initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths-- --------------------------------------------------------------------------- test (prevTime, ts) = do- now <- getCurrentTime- if diffUTCTime now prevTime < 3- then return True- else checkTreeStatus ts------------------------------------------------------------------------------------ | Convert an InterpreterError to a String for presentation-format :: InterpreterError -> String-format (UnknownError e) = "Unknown interpreter error:\r\n\r\n" ++ e-format (NotAllowed e) = "Interpreter action not allowed:\r\n\r\n" ++ e-format (GhcException e) = "GHC error:\r\n\r\n" ++ e-format (WontCompile errs) = "Compile errors:\r\n\r\n" ++- (intercalate "\r\n" $ nub $ map errMsg errs)--#endif
− src/Snap/Loader/Devel/Evaluator.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Loader.Devel.Evaluator- ( HintLoadable- , protectedHintEvaluator- ) where---------------------------------------------------------------------------------import Control.Exception-import Control.Monad (when)-import Control.Monad.Trans (liftIO)-import Control.Concurrent (ThreadId, forkIO, myThreadId)-import Control.Concurrent.MVar-import Prelude hiding (catch, init, any)-import Snap.Core (Snap)------------------------------------------------------------------------------------ | A type synonym to simply talking about the type loaded by hint.-type HintLoadable = IO (Snap (), IO ())------------------------------------------------------------------------------------ | Convert an action to generate 'HintLoadable's into Snap and IO actions--- that handle periodic reloading. The resulting action will share initialized--- state until the next execution of the input action. At this time, the--- cleanup action will be executed.------ The first two arguments control when recompiles are done. The first argument--- is an action that is executed when compilation starts. The second is a--- function from the result of the first action to an action that determines--- whether the value from the previous compilation is still good. This--- abstracts out the strategy for determining when a cached result is no longer--- valid.------ If an exception is raised during the processing of the action, it will be--- thrown to all waiting threads, and for all requests made before the--- recompile condition is reached.-protectedHintEvaluator :: forall a.- IO a- -> (a -> IO Bool)- -> IO HintLoadable- -> IO (Snap (), IO ())-protectedHintEvaluator start test getInternals = do- -- The list of requesters waiting for a result. Contains the ThreadId in- -- case of exceptions, and an empty MVar awaiting a successful result.- readerContainer <- newReaderContainer-- -- Contains the previous result and initialization value, and the time it- -- was stored, if a previous result has been computed. The result stored is- -- either the actual result and initialization result, or the exception- -- thrown by the calculation.- resultContainer <- newResultContainer-- -- The model used for the above MVars in the returned action is "keep them- -- full, unless updating them." In every case, when one of those MVars is- -- emptied, the next action is to fill that same MVar. This makes- -- deadlocking on MVar wait impossible.- let snap = do- let waitForNewResult :: IO (Snap ())- waitForNewResult = do- -- Need to calculate a new result- tid <- myThreadId- reader <- newEmptyMVar-- readers <- takeMVar readerContainer-- -- Some strictness is employed to ensure the MVar- -- isn't holding on to a chain of unevaluated thunks.- let pair = (tid, reader)- newReaders = readers `seq` pair `seq` (pair : readers)- putMVar readerContainer $! newReaders-- -- If this is the first reader to queue, clean up the- -- previous state, if there was any, and then begin- -- evaluation of the new code and state.- when (null readers) $ do- let runAndFill = block $ do- -- run the cleanup action- previous <- readMVar resultContainer- unblock $ cleanup previous-- -- compile the new internals and initialize- stateInitializer <- unblock getInternals- res <- unblock stateInitializer-- let a = fst res-- clearAndNotify (Right res)- (flip putMVar a . snd)-- killWaiting :: SomeException -> IO ()- killWaiting e = block $ do- clearAndNotify (Left e) (flip throwTo e . fst)- throwIO e-- clearAndNotify r f = do- a <- unblock start- _ <- swapMVar resultContainer $ Just (r, a)- allReaders <- swapMVar readerContainer []- mapM_ f allReaders-- _ <- forkIO $ runAndFill `catch` killWaiting- return ()-- -- Wait for the evaluation of the action to complete,- -- and return its result.- takeMVar reader-- existingResult <- liftIO $ readMVar resultContainer-- getResult <- liftIO $ case existingResult of- Just (res, a) -> do- -- There's an existing result. Check for validity- valid <- test a- case (valid, res) of- (True, Right (x, _)) -> return x- (True, Left e) -> throwIO e- (False, _) -> waitForNewResult- Nothing -> waitForNewResult- getResult-- clean = do- let msg = "invalid dynamic loader state. " ++- "The cleanup action has been executed"- contents <- swapMVar resultContainer $ error msg- cleanup contents-- return (snap, clean)-- where- newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))])- newReaderContainer = newMVar []-- newResultContainer :: IO (MVar (Maybe (Either SomeException- (Snap (), IO ()), a)))- newResultContainer = newMVar Nothing-- cleanup (Just (Right (_, clean), _)) = clean- cleanup _ = return ()
− src/Snap/Loader/Devel/Signal.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE CPP #-}-module Snap.Loader.Devel.Signal (protectHandlers) where---------------------------------------------------------------------------------import Control.Exception (bracket)---#ifdef mingw32_HOST_OS-- -------------- -- windows --- ---------------------------------------------------------------------------------------------import GHC.ConsoleHandler as C--saveHandlers :: IO C.Handler-saveHandlers = C.installHandler Ignore--restoreHandlers :: C.Handler -> IO C.Handler-restoreHandlers = C.installHandler----------------------------------------------------------------------------------#else-- ------------ -- posix --- -------------------------------------------------------------------------------------------import qualified System.Posix.Signals as S--helper :: S.Handler -> S.Signal -> IO S.Handler-helper handler signal = S.installHandler signal handler Nothing--signals :: [S.Signal]-signals = [ S.sigQUIT- , S.sigINT- , S.sigHUP- , S.sigTERM- ]--saveHandlers :: IO [S.Handler]-saveHandlers = mapM (helper S.Ignore) signals--restoreHandlers :: [S.Handler] -> IO [S.Handler]-restoreHandlers h = sequence $ zipWith helper h signals---------------------------------------------------------------------------------#endif-- ----------- -- both --- ------------------------------------------------------------------------------------------protectHandlers :: IO a -> IO a-protectHandlers a = bracket saveHandlers restoreHandlers $ const a-------------------------------------------------------------------------------
− src/Snap/Loader/Devel/TreeWatcher.hs
@@ -1,40 +0,0 @@-module Snap.Loader.Devel.TreeWatcher- ( TreeStatus- , getTreeStatus- , checkTreeStatus- ) where---------------------------------------------------------------------------------import Control.Applicative-import System.Directory-import System.Directory.Tree-import System.Time------------------------------------------------------------------------------------ | An opaque representation of the contents and last modification--- times of a forest of directory trees.-data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime]------------------------------------------------------------------------------------ | Create a 'TreeStatus' for later checking with 'checkTreeStatus'-getTreeStatus :: [FilePath] -> IO TreeStatus-getTreeStatus = liftA2 (<$>) TS readModificationTimes------------------------------------------------------------------------------------ | Checks that all the files present in the initial set of paths are--- the exact set of files currently present, with unchanged modifcations times-checkTreeStatus :: TreeStatus -> IO Bool-checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths- where- check = and . zipWith (==) entries------------------------------------------------------------------------------------ | This is the core of the functions in this module. It converts a--- list of filepaths into a list of 'AnchoredDirTree' annotated with--- the modification times of the files located in those paths.-readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime]-readModificationTimes = mapM $ readDirectoryWith getModificationTime
− src/Snap/Loader/Prod.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Snap.Loader.Prod- ( loadSnapTH- ) where---------------------------------------------------------------------------------import Language.Haskell.TH------------------------------------------------------------------------------------ | This function provides a non-magical type-compatible loader for--- the one in Snap.Loader.Devel, allowing switching one import to--- provide production-mode compilation.------ This could be considered a TH wrapper around a function------ > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ()))--- > -> [String] -> IO (a, Snap (), IO ())------ The third argument is unused, and only present for--- type-compatibility with Snap.Loader.Devel-loadSnapTH :: Q Exp -> Name -> [String] -> Q Exp-loadSnapTH initializer action _additionalWatchDirs =- [| do value <- $initializer- (site, conf) <- $(varE action) value- return (value, site, conf) |]
src/Snap/Snaplet/Auth/Handlers.hs view
@@ -418,9 +418,8 @@ -> Handler b (AuthManager b) () -- ^ Upon success -> Handler b (AuthManager b) ()-loginUser unf pwdf remf loginFail loginSucc = do+loginUser unf pwdf remf loginFail loginSucc = runErrorT go >>= either loginFail (const loginSucc)- where go = do mbUsername <- getParam unf@@ -434,7 +433,7 @@ password <- maybe (throwError PasswordMissing) return mbPassword username <- maybe (fail "Username is missing") return mbUsername- lift $ loginByUsername username (ClearText password) remember+ ErrorT $ loginByUsername username (ClearText password) remember ------------------------------------------------------------------------------
+ src/Snap/Snaplet/Config.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Snap.Snaplet.Config where++import Data.Function+import Data.Maybe+import Data.Monoid+import Data.Typeable+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 }+++------------------------------------------------------------------------------+-- | The Typeable instance is here so Snap can be dynamically executed with+-- Hint.+appConfigTyCon :: TyCon+appConfigTyCon = mkTyCon "Snap.Snaplet.Config.AppConfig"+{-# NOINLINE appConfigTyCon #-}++instance Typeable AppConfig where+ typeOf _ = mkTyConApp appConfigTyCon []+++------------------------------------------------------------------------------+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+++------------------------------------------------------------------------------+-- | Command line options for snaplet applications.+appOpts :: AppConfig -> [OptDescr (Maybe (Config m AppConfig))]+appOpts defaults = map (fmapOpt $ fmap (flip setOther mempty))+ [ Option ['e'] ["environment"]+ (ReqArg setter "ENVIRONMENT")+ $ "runtime environment to use" ++ defaultC appEnvironment+ ]+ where+ setter s = Just $ mempty { appEnvironment = Just s}+ defaultC f = maybe "" ((", default " ++) . show) $ f defaults+++------------------------------------------------------------------------------+-- | Calls snap-server's extendedCommandLineConfig to add snaplet options to+-- the built-in server command line options.+commandLineAppConfig :: MonadSnap m+ => Config m AppConfig+ -> IO (Config m AppConfig)+commandLineAppConfig defaults =+ extendedCommandLineConfig (appOpts appDefaults ++ optDescrs defaults)+ mappend defaults+ where+ appDefaults = fromMaybe mempty $ getOther defaults+
src/Snap/Snaplet/Internal/Initializer.hs view
@@ -46,6 +46,7 @@ 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 @@ ] -- 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 @@ ------------------------------------------------------------------------------ -- | 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 @@ -- 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 @@ --------------------------------------------------------------------------------- | 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 @@ ------------------------------------------------------------------------------ -- | 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
src/Snap/Snaplet/Internal/Types.hs view
@@ -332,6 +332,7 @@ -- ^ This snaplet config is the incrementally built config for whatever -- snaplet is currently being constructed. , _initMessages :: IORef Text+ , _environment :: String }
+ test/foosnaplet/devel.cfg view
@@ -0,0 +1,2 @@+fooSnapletField = "fooValue"+
− test/foosnaplet/snaplet.cfg
@@ -1,2 +0,0 @@-fooSnapletField = "fooValue"-
+ test/non-cabal-appdir/devel.cfg view
@@ -0,0 +1,6 @@+topConfigField = "topConfigValue"++db {+import "db.cfg"+}+
− test/non-cabal-appdir/snaplet.cfg
@@ -1,6 +0,0 @@-topConfigField = "topConfigValue"--db {-import "db.cfg"-}-
+ test/non-cabal-appdir/snaplets/baz/devel.cfg view
@@ -0,0 +1,2 @@+barSnapletField = "barValue"+
− test/non-cabal-appdir/snaplets/baz/snaplet.cfg
@@ -1,2 +0,0 @@-barSnapletField = "barValue"-
test/snap-testsuite.cabal view
@@ -22,11 +22,12 @@ directory-tree >= 0.10 && < 0.11, filepath, heist >= 0.7 && < 0.9,- http-enumerator >= 0.7.1.7 && < 0.8,+ http-conduit >= 1.4 && < 1.5,+ http-types >= 0.6 && < 0.7, mtl >= 2, process == 1.*,- snap-core >= 0.8.1 && < 0.9,- snap-server >= 0.8.1 && < 0.9,+ snap-core >= 0.9 && < 0.10,+ snap-server >= 0.9 && < 0.10, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, test-framework-quickcheck2 >= 0.2.12.1 && <0.3,@@ -82,8 +83,8 @@ mtl >= 2, mwc-random >= 0.8, process == 1.*,- snap-core >= 0.8.1 && < 0.9,- snap-server >= 0.8.1 && < 0.9,+ snap-core >= 0.9 && < 0.10,+ snap-server >= 0.9 && < 0.10, syb >= 0.1, time >= 1.1, text >= 0.11 && < 0.12,@@ -133,8 +134,8 @@ heist >= 0.7 && < 0.9, mtl >= 2, process == 1.*,- snap-core >= 0.8.1 && < 0.9,- snap-server >= 0.8.1 && < 0.9,+ snap-core >= 0.9 && < 0.10,+ snap-server >= 0.9 && < 0.10, text >= 0.11 && < 0.12, transformers >= 0.2, utf8-string >= 0.3 && < 0.4,
test/suite/Blackbox/Tests.hs view
@@ -15,7 +15,8 @@ import qualified Data.ByteString.Lazy.Char8 as L import Data.Text.Lazy (Text) import qualified Data.Text.Lazy.Encoding as T-import qualified Network.HTTP.Enumerator as HTTP+import qualified Network.HTTP.Conduit as HTTP+import Network.HTTP.Types (Status(..)) import Prelude hiding (catch) import System.Directory import System.FilePath@@ -147,9 +148,10 @@ HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url assertFailure "expected 404" - h e@(HTTP.StatusCodeException c _) | c == 404 = return ()- | otherwise = throwIO e- h e = throwIO e+ h e@(HTTP.StatusCodeException (Status c _) _)+ | c == 404 = return ()+ | otherwise = throwIO e+ h e = throwIO e ------------------------------------------------------------------------------@@ -165,17 +167,21 @@ -------------------------------------------------------------------------------requestNoError :: String -> Text -> Test-requestNoError url desired =- testCase (testName url) $ requestNoError' url desired+requestExpectingError :: String -> Int -> Text -> Test+requestExpectingError url status desired =+ testCase (testName url) $ requestExpectingError' url status desired -------------------------------------------------------------------------------requestNoError' :: String -> Text -> IO ()-requestNoError' url desired = do+requestExpectingError' :: String -> Int -> Text -> IO ()+requestExpectingError' url status desired = do let fullUrl = "http://127.0.0.1:9753/" ++ url- url' <- HTTP.parseUrl fullUrl- HTTP.Response _ _ b <- liftIO $ HTTP.withManager $ HTTP.httpLbsRedirect url'+ req <- HTTP.parseUrl fullUrl+ let req' = req { HTTP.checkStatus = \_ _ -> Nothing }+ resp <- liftIO $ HTTP.withManager $ HTTP.httpLbs req'+ let b = HTTP.responseBody resp+ s = HTTP.responseStatus resp+ assertEqual ("Status code: "++fullUrl) status (statusCode s) assertEqual fullUrl desired (T.decodeUtf8 b) @@ -197,7 +203,7 @@ , requestTest "bazpage3" "baz template page <barsplice></barsplice>\n" , requestTest "bazpage4" "baz template page <barsplice></barsplice>\n" , requestTest "barrooturl" "url"- , requestNoError "bazbadpage" "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found."+ , requestExpectingError "bazbadpage" 500 "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found." , requestTest "foo/fooSnapletName" "foosnaplet" , fooConfigPathTest
test/suite/Snap/Snaplet/Internal/Tests.hs view
@@ -108,7 +108,7 @@ ------------------------------------------------------------------------------ initTest :: IO () initTest = do- (out,_,_) <- runSnaplet appInit+ (out,_,_) <- runSnaplet Nothing appInit -- note from gdc: wtf? if out == "aoeu"
test/suite/Snap/TestCommon.hs view
@@ -58,19 +58,24 @@ snapExe <- findSnap systemOrDie $ snapExe ++ " init " ++ snapInitArgs - snapCoreSrc <- fromEnv "SNAP_CORE_SRC" $- snapRepos </> "snap-core"- snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $- snapRepos </> "snap-server"- xmlhtmlSrc <- fromEnv "XMLHTML_SRC" $ snapRepos </> "xmlhtml"- heistSrc <- fromEnv "HEIST_SRC" $ snapRepos </> "heist"+ snapCoreSrc <- fromEnv "SNAP_CORE_SRC" $+ snapRepos </> "snap-core"+ snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $+ snapRepos </> "snap-server"+ xmlhtmlSrc <- fromEnv "XMLHTML_SRC" $ snapRepos </> "xmlhtml"+ heistSrc <- fromEnv "HEIST_SRC" $ snapRepos </> "heist"+ dynLoaderSrc <- fromEnv "DYNAMIC_LOADER_SRC" $+ snapRepos </> "snap-loader-dynamic"+ staticLoaderSrc <- fromEnv "STATIC_LOADER_SRC" $+ snapRepos </> "snap-loader-static" let snapSrc = snapRoot - forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap" ]+ forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap"+ , "snap-loader-static", "snap-loader-dynamic"] (pkgCleanUp sandbox) forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc- , snapSrc] $ \s ->+ , snapSrc, staticLoaderSrc, dynLoaderSrc] $ \s -> systemOrDie $ concat [ "cabal-dev " , cabalDevArgs , " add-source "
test/suite/TestSuite.hs view
@@ -9,7 +9,7 @@ import Control.Monad import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S-import qualified Network.HTTP.Enumerator as HTTP+import qualified Network.HTTP.Conduit as HTTP import Prelude hiding (catch) import Snap.Http.Server.Config import Snap.Snaplet@@ -82,7 +82,7 @@ flip finally (putMVar mvar ()) $ handle handleErr $ do hPutStrLn stderr "initializing snaplet"- (_, handler, doCleanup) <- runSnaplet initializer+ (_, handler, doCleanup) <- runSnaplet Nothing initializer flip finally doCleanup $ do (conf, site) <- combineConfig config handler@@ -122,8 +122,8 @@ testIt = do body <- liftM (S.concat . L.toChunks) $ HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)- assertBool "response contains phrase 'it works!'"- $ "It works!" `S.isInfixOf` body+ assertBool "response contains phrase 'Snap Example App Login'"+ $ "Snap Example App Login" `S.isInfixOf` body ------------------------------------------------------------------------------