diff --git a/project_template/barebones/foo.cabal b/project_template/barebones/foo.cabal --- a/project_template/barebones/foo.cabal +++ b/project_template/barebones/foo.cabal @@ -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 diff --git a/project_template/default/foo.cabal b/project_template/default/foo.cabal --- a/project_template/default/foo.cabal +++ b/project_template/default/foo.cabal @@ -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 - diff --git a/project_template/default/snaplets/heist/templates/base.tpl b/project_template/default/snaplets/heist/templates/base.tpl new file mode 100644 --- /dev/null +++ b/project_template/default/snaplets/heist/templates/base.tpl @@ -0,0 +1,13 @@ + + + Snap web server + + + +
+ + + +
+ + diff --git a/project_template/default/snaplets/heist/templates/echo.tpl b/project_template/default/snaplets/heist/templates/echo.tpl deleted file mode 100644 --- a/project_template/default/snaplets/heist/templates/echo.tpl +++ /dev/null @@ -1,13 +0,0 @@ - - - Echo Page - - -
-

Is there an echo in here?

-
-

You wanted me to say this?

-

""

-

Return

- - diff --git a/project_template/default/snaplets/heist/templates/index.tpl b/project_template/default/snaplets/heist/templates/index.tpl --- a/project_template/default/snaplets/heist/templates/index.tpl +++ b/project_template/default/snaplets/heist/templates/index.tpl @@ -1,32 +1,19 @@ - - - Snap web server - - - -
-

It works!

-

- This is a simple demo page served using - Heist - and the Snap web framework. -

-

- Echo test: - cats - dogs - fish -

- - - - - - - - - -
Config generated at:
Page generated at:
-
- - + + + +

+ This is a simple demo page served using + Heist + and the Snap web framework. +

+ +

Congrats! You're logged in as ''

+ +

Logout

+ + + + + + + diff --git a/project_template/default/snaplets/heist/templates/login.tpl b/project_template/default/snaplets/heist/templates/login.tpl new file mode 100644 --- /dev/null +++ b/project_template/default/snaplets/heist/templates/login.tpl @@ -0,0 +1,11 @@ + +

Snap Example App Login

+ +

+ + /login + Login + + +

Don't have a login yet? Create a new user

+ diff --git a/project_template/default/snaplets/heist/templates/new_user.tpl b/project_template/default/snaplets/heist/templates/new_user.tpl new file mode 100644 --- /dev/null +++ b/project_template/default/snaplets/heist/templates/new_user.tpl @@ -0,0 +1,9 @@ + + +

Register a new user

+ + /new_user + Add User + + + diff --git a/project_template/default/snaplets/heist/templates/userform.tpl b/project_template/default/snaplets/heist/templates/userform.tpl new file mode 100644 --- /dev/null +++ b/project_template/default/snaplets/heist/templates/userform.tpl @@ -0,0 +1,14 @@ +
+ + + + + + + + + + + +
Login:
Password:
+
diff --git a/project_template/default/src/Application.hs b/project_template/default/src/Application.hs --- a/project_template/default/src/Application.hs +++ b/project_template/default/src/Application.hs @@ -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 diff --git a/project_template/default/src/Main.hs b/project_template/default/src/Main.hs --- a/project_template/default/src/Main.hs +++ b/project_template/default/src/Main.hs @@ -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) diff --git a/project_template/default/src/Site.hs b/project_template/default/src/Site.hs --- a/project_template/default/src/Site.hs +++ b/project_template/default/src/Site.hs @@ -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 diff --git a/project_template/tutorial/foo.cabal b/project_template/tutorial/foo.cabal --- a/project_template/tutorial/foo.cabal +++ b/project_template/tutorial/foo.cabal @@ -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 diff --git a/snap.cabal b/snap.cabal --- a/snap.cabal +++ b/snap.cabal @@ -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 diff --git a/src/Snap/Loader/Devel.hs b/src/Snap/Loader/Devel.hs deleted file mode 100644 --- a/src/Snap/Loader/Devel.hs +++ /dev/null @@ -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 diff --git a/src/Snap/Loader/Devel/Evaluator.hs b/src/Snap/Loader/Devel/Evaluator.hs deleted file mode 100644 --- a/src/Snap/Loader/Devel/Evaluator.hs +++ /dev/null @@ -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 () diff --git a/src/Snap/Loader/Devel/Signal.hs b/src/Snap/Loader/Devel/Signal.hs deleted file mode 100644 --- a/src/Snap/Loader/Devel/Signal.hs +++ /dev/null @@ -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 ------------------------------------------------------------------------------- diff --git a/src/Snap/Loader/Devel/TreeWatcher.hs b/src/Snap/Loader/Devel/TreeWatcher.hs deleted file mode 100644 --- a/src/Snap/Loader/Devel/TreeWatcher.hs +++ /dev/null @@ -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 diff --git a/src/Snap/Loader/Prod.hs b/src/Snap/Loader/Prod.hs deleted file mode 100644 --- a/src/Snap/Loader/Prod.hs +++ /dev/null @@ -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) |] diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs --- a/src/Snap/Snaplet/Auth/Handlers.hs +++ b/src/Snap/Snaplet/Auth/Handlers.hs @@ -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 ------------------------------------------------------------------------------ diff --git a/src/Snap/Snaplet/Config.hs b/src/Snap/Snaplet/Config.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Config.hs @@ -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 + diff --git a/src/Snap/Snaplet/Internal/Initializer.hs b/src/Snap/Snaplet/Internal/Initializer.hs --- a/src/Snap/Snaplet/Internal/Initializer.hs +++ b/src/Snap/Snaplet/Internal/Initializer.hs @@ -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 diff --git a/src/Snap/Snaplet/Internal/Types.hs b/src/Snap/Snaplet/Internal/Types.hs --- a/src/Snap/Snaplet/Internal/Types.hs +++ b/src/Snap/Snaplet/Internal/Types.hs @@ -332,6 +332,7 @@ -- ^ This snaplet config is the incrementally built config for whatever -- snaplet is currently being constructed. , _initMessages :: IORef Text + , _environment :: String } diff --git a/test/foosnaplet/devel.cfg b/test/foosnaplet/devel.cfg new file mode 100644 --- /dev/null +++ b/test/foosnaplet/devel.cfg @@ -0,0 +1,2 @@ +fooSnapletField = "fooValue" + diff --git a/test/foosnaplet/snaplet.cfg b/test/foosnaplet/snaplet.cfg deleted file mode 100644 --- a/test/foosnaplet/snaplet.cfg +++ /dev/null @@ -1,2 +0,0 @@ -fooSnapletField = "fooValue" - diff --git a/test/non-cabal-appdir/devel.cfg b/test/non-cabal-appdir/devel.cfg new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/devel.cfg @@ -0,0 +1,6 @@ +topConfigField = "topConfigValue" + +db { +import "db.cfg" +} + diff --git a/test/non-cabal-appdir/snaplet.cfg b/test/non-cabal-appdir/snaplet.cfg deleted file mode 100644 --- a/test/non-cabal-appdir/snaplet.cfg +++ /dev/null @@ -1,6 +0,0 @@ -topConfigField = "topConfigValue" - -db { -import "db.cfg" -} - diff --git a/test/non-cabal-appdir/snaplets/baz/devel.cfg b/test/non-cabal-appdir/snaplets/baz/devel.cfg new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/snaplets/baz/devel.cfg @@ -0,0 +1,2 @@ +barSnapletField = "barValue" + diff --git a/test/non-cabal-appdir/snaplets/baz/snaplet.cfg b/test/non-cabal-appdir/snaplets/baz/snaplet.cfg deleted file mode 100644 --- a/test/non-cabal-appdir/snaplets/baz/snaplet.cfg +++ /dev/null @@ -1,2 +0,0 @@ -barSnapletField = "barValue" - diff --git a/test/snap-testsuite.cabal b/test/snap-testsuite.cabal --- a/test/snap-testsuite.cabal +++ b/test/snap-testsuite.cabal @@ -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, diff --git a/test/suite/Blackbox/Tests.hs b/test/suite/Blackbox/Tests.hs --- a/test/suite/Blackbox/Tests.hs +++ b/test/suite/Blackbox/Tests.hs @@ -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 \n" , requestTest "bazpage4" "baz template page \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 diff --git a/test/suite/Snap/Snaplet/Internal/Tests.hs b/test/suite/Snap/Snaplet/Internal/Tests.hs --- a/test/suite/Snap/Snaplet/Internal/Tests.hs +++ b/test/suite/Snap/Snaplet/Internal/Tests.hs @@ -108,7 +108,7 @@ ------------------------------------------------------------------------------ initTest :: IO () initTest = do - (out,_,_) <- runSnaplet appInit + (out,_,_) <- runSnaplet Nothing appInit -- note from gdc: wtf? if out == "aoeu" diff --git a/test/suite/Snap/TestCommon.hs b/test/suite/Snap/TestCommon.hs --- a/test/suite/Snap/TestCommon.hs +++ b/test/suite/Snap/TestCommon.hs @@ -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 " diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -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 ------------------------------------------------------------------------------