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 @@ -19,8 +19,8 @@ bytestring >= 0.9.1 && < 0.10, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl >= 2 && < 3, - snap-core == 0.4.*, - snap-server == 0.4.* + snap-core == 0.5.*, + snap-server == 0.5.* 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 @@ -24,9 +24,9 @@ heist >= 0.5 && < 0.6, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl >= 2 && < 3, - snap == 0.4.*, - snap-core == 0.4.*, - snap-server == 0.4.*, + snap == 0.5.*, + snap-core == 0.5.*, + snap-server == 0.5.*, text >= 0.11 && < 0.12, time >= 1.1 && < 1.3, xmlhtml == 0.1.* 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 @@ -53,6 +53,6 @@ -- to worry about. applicationInitializer :: Initializer ApplicationState applicationInitializer = do - heist <- heistInitializer "resources/templates" + heist <- heistInitializer "resources/templates" id timer <- timerInitializer return $ ApplicationState heist timer 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 @@ -42,6 +42,8 @@ module Main where #ifdef DEVELOPMENT +import Control.Exception (SomeException, try) + import Snap.Extension.Loader.Devel import Snap.Http.Server (quickHttpServe) #else @@ -57,9 +59,10 @@ -- All source directories will be watched for updates -- automatically. If any extra directories should be watched for -- updates, include them here. - snap <- $(let extraWatcheDirs = ["resources/templates"] - in loadSnapTH 'applicationInitializer 'site extraWatcheDirs) - quickHttpServe snap + (snap, cleanup) <- $(let watchDirs = ["resources/templates"] + in loadSnapTH 'applicationInitializer 'site watchDirs) + try $ quickHttpServe snap :: IO (Either SomeException ()) + cleanup #else main = quickHttpServe applicationInitializer site #endif diff --git a/snap.cabal b/snap.cabal --- a/snap.cabal +++ b/snap.cabal @@ -1,5 +1,5 @@ name: snap -version: 0.4.3 +version: 0.5.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 @@ -58,10 +58,11 @@ blaze-builder >= 0.2.1.4 && <0.4, bytestring >= 0.9.1 && < 0.10, directory >= 1.0 && < 1.2, + directory-tree >= 0.10 && < 0.11, enumerator == 0.4.*, filepath >= 1.1 && <1.3, MonadCatchIO-transformers >= 0.2.1 && < 0.3, - snap-core == 0.4.*, + snap-core == 0.5.*, heist >= 0.5 && < 0.6, hint >= 0.3.3.1 && < 0.4, template-haskell >= 2.3 && < 2.6, @@ -100,8 +101,8 @@ mtl >= 2, old-locale, old-time, - snap-core >= 0.4 && <0.5, - snap-server >= 0.4 && <0.5, + snap-core == 0.5.*, + snap-server >= 0.5 && <0.6, template-haskell >= 2.3 && < 2.6, text >= 0.11 && <0.12, time, diff --git a/src/Snap/Extension/Heist/Impl.hs b/src/Snap/Extension/Heist/Impl.hs --- a/src/Snap/Extension/Heist/Impl.hs +++ b/src/Snap/Extension/Heist/Impl.hs @@ -119,12 +119,16 @@ ------------------------------------------------------------------------------ --- | The 'Initializer' for 'HeistState'. It takes one argument, a path to a --- template directory containing @.tpl@ files. -heistInitializer :: MonadSnap m => FilePath -> Initializer (HeistState m) -heistInitializer p = do +-- | The 'Initializer' for 'HeistState'. +heistInitializer :: MonadSnap m + => FilePath + -- ^ Path to a template directory containing @.tpl@ files + -> (TemplateState m -> TemplateState m) + -- ^ Function to modify the initial template state + -> Initializer (HeistState m) +heistInitializer p modTS = do heistState <- liftIO $ do - (origTs,sts) <- bindStaticTag $ emptyTemplateState p + (origTs,sts) <- bindStaticTag $ modTS $ emptyTemplateState p loadTemplates p origTs >>= either error (\ts -> do tsMVar <- newMVar ts return $ HeistState p origTs tsMVar sts id) @@ -183,7 +187,12 @@ ------------------------------------------------------------------------------ -- | Take your application's state and register these splices in it so -- that you don't have to re-list them in every handler. Should be called from --- inside your application's 'Initializer'. +-- inside your application's 'Initializer'. The splices registered by this +-- function do not persist through template reloads. Those splices must be +-- passed as a parameter to heistInitializer. +-- +-- (NOTE: In the future we may decide to deprecate registerSplices in favor of +-- the heistInitializer argument.) -- -- Typical use cases are dynamically generated components that are present in -- many of your views. diff --git a/src/Snap/Extension/Loader/Devel.hs b/src/Snap/Extension/Loader/Devel.hs --- a/src/Snap/Extension/Loader/Devel.hs +++ b/src/Snap/Extension/Loader/Devel.hs @@ -7,6 +7,7 @@ -- the calls to the dynamic loader. module Snap.Extension.Loader.Devel ( loadSnapTH + , loadSnapTH' ) where import Control.Monad (liftM2) @@ -24,7 +25,6 @@ ------------------------------------------------------------------------------ import Snap.Types -import Snap.Extension (runInitializerWithoutReloadAction) import Snap.Extension.Loader.Devel.Signal import Snap.Extension.Loader.Devel.Evaluator import Snap.Extension.Loader.Devel.TreeWatcher @@ -44,23 +44,43 @@ -- during development unless your .cabal file changes, or the code -- that uses this splice changes. loadSnapTH :: Name -> Name -> [String] -> Q Exp -loadSnapTH initializer action additionalWatchDirs = do - args <- runIO getArgs +loadSnapTH initializer action additionalWatchDirs = + loadSnapTH' modules imports additionalWatchDirs loadStr + where + initMod = nameModule initializer + initBase = nameBase initializer + actMod = nameModule action + actBase = nameBase action - let initMod = nameModule initializer - initBase = nameBase initializer - actMod = nameModule action - actBase = nameBase action + modules = catMaybes [initMod, actMod] + imports = ["Snap.Extension"] - opts = getHintOpts args - modules = catMaybes [initMod, actMod] + loadStr = intercalate " " [ "runInitializerWithoutReloadAction" + , initBase + , actBase + ] + + +------------------------------------------------------------------------------ +-- | This is the backing implementation for 'loadSnapTH'. This +-- interface can be used when the types involved don't include a +-- SnapExtend and an Initializer. +loadSnapTH' :: [String] -- ^ the list of modules to interpret + -> [String] -- ^ the list of modules to import in addition + -- to those being interpreted + -> [String] -- ^ additional directories to watch for + -- changes to trigger to recompile/reload + -> String -- ^ the expression to interpret in the + -- context of the loaded modules and imports. + -- It should have the type 'HintLoadable' + -> Q Exp +loadSnapTH' modules imports additionalWatchDirs loadStr = do + args <- runIO getArgs + + let opts = getHintOpts args srcPaths = additionalWatchDirs ++ getSrcPaths args - -- The let in this block causes an extra static type check that the - -- types of the names passed in were correct at compile time. - [| let _ = runInitializerWithoutReloadAction $(varE initializer) - $(varE action) - in hintSnap opts modules srcPaths initBase actBase |] + [| hintSnap opts modules imports srcPaths loadStr |] ------------------------------------------------------------------------------ @@ -111,24 +131,21 @@ -- modules which contain the initialization, -- cleanup, and handler actions. Everything else -- they require will be loaded transitively. + -> [String] -- ^ A list of modules that need to be be + -- imported, in addition to the ones that need to + -- be interpreted. This only needs to contain + -- modules that aren't being interpreted, such as + -- those from other libraries, that are used in + -- the expression passed in. -> [String] -- ^ A list of paths to watch for updates - -> String -- ^ The name of the initializer action - -> String -- ^ The name of the SnapExtend action - -> IO (Snap ()) -hintSnap opts modules srcPaths initialization handler = + -> String -- ^ The string to execute + -> IO (Snap (), IO ()) +hintSnap opts modules imports srcPaths action = protectedHintEvaluator initialize test loader where - action = intercalate " " [ "runInitializerWithoutReloadAction" - , initialization - , handler - ] interpreter = do loadModules . nub $ modules - let imports = "Prelude" : - "Snap.Extension" : - "Snap.Types" : - modules - setImports . nub $ imports + setImports . nub $ "Prelude" : "Snap.Types" : imports ++ modules interpret action (as :: HintLoadable) diff --git a/src/Snap/Extension/Loader/Devel/Evaluator.hs b/src/Snap/Extension/Loader/Devel/Evaluator.hs --- a/src/Snap/Extension/Loader/Devel/Evaluator.hs +++ b/src/Snap/Extension/Loader/Devel/Evaluator.hs @@ -43,7 +43,7 @@ IO a -> (a -> IO Bool) -> IO HintLoadable - -> IO (Snap ()) + -> 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 @@ -61,70 +61,78 @@ -- "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. - return $ do - let waitForNewResult :: IO (Snap ()) - waitForNewResult = do - -- Need to calculate a new result - tid <- myThreadId - reader <- newEmptyMVar + let snap = do + let waitForNewResult :: IO (Snap ()) + waitForNewResult = do + -- Need to calculate a new result + tid <- myThreadId + reader <- newEmptyMVar - readers <- takeMVar readerContainer + 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 + -- 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 + -- 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 + -- compile the new internals and initialize + stateInitializer <- unblock getInternals + res <- unblock stateInitializer - let a = fst res + let a = fst res - clearAndNotify (Right res) (flip putMVar a . snd) + clearAndNotify (Right res) (flip putMVar a . snd) - killWaiting :: SomeException -> IO () - killWaiting e = block $ do - clearAndNotify (Left e) (flip throwTo e . fst) - throwIO e + 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 + clearAndNotify r f = do + a <- unblock start + _ <- swapMVar resultContainer $ Just (r, a) + allReaders <- swapMVar readerContainer [] + mapM_ f allReaders - _ <- forkIO $ runAndFill `catch` killWaiting - return () + _ <- forkIO $ runAndFill `catch` killWaiting + return () - -- Wait for the evaluation of the action to complete, - -- and return its result. - takeMVar reader + -- Wait for the evaluation of the action to complete, + -- and return its result. + takeMVar reader - existingResult <- liftIO $ readMVar resultContainer + 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, _) -> do - _ <- swapMVar resultContainer Nothing - waitForNewResult - Nothing -> waitForNewResult - getResult + 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, _) -> do + _ <- swapMVar resultContainer Nothing + 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 [] diff --git a/src/Snap/Extension/Loader/Devel/TreeWatcher.hs b/src/Snap/Extension/Loader/Devel/TreeWatcher.hs --- a/src/Snap/Extension/Loader/Devel/TreeWatcher.hs +++ b/src/Snap/Extension/Loader/Devel/TreeWatcher.hs @@ -30,12 +30,7 @@ checkTreeStatus :: TreeStatus -> IO Bool checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths where - check = and . zipWith adtEq entries - adtEq (n1 :/ dt1) (n2 :/ dt2) = n1 == n2 && dtEq dt1 dt2 - - dtEq (Dir n1 d1) (Dir n2 d2) = n1 == n2 && and (zipWith dtEq d1 d2) - dtEq (File n1 t1) (File n2 t2) = n1 == n2 && t1 == t2 - dtEq _ _ = False + check = and . zipWith (==) entries ------------------------------------------------------------------------------ diff --git a/src/Snap/Extension/Server.hs b/src/Snap/Extension/Server.hs --- a/src/Snap/Extension/Server.hs +++ b/src/Snap/Extension/Server.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-| @@ -31,7 +32,7 @@ import qualified Data.Text.Encoding as T import Prelude hiding (catch) import Snap.Extension -import Snap.Http.Server (simpleHttpServe) +import qualified Snap.Http.Server as SS import qualified Snap.Http.Server.Config as C import Snap.Http.Server.Config hiding ( defaultConfig , completeConfig @@ -89,11 +90,8 @@ ------------------------------------------------------------------------------ -- | Completes a partial 'Config' by filling in the unspecified values with -- the default values from 'defaultConfig'. -completeConfig :: ConfigExtend s -> ConfigExtend s -completeConfig c = case getListen c' of - [] -> addListen (ListenHttp "0.0.0.0" 8000) c' - _ -> c' - where c' = mappend defaultConfig c +completeConfig :: ConfigExtend s -> IO (ConfigExtend s) +completeConfig = C.completeConfig . (mappend defaultConfig) ------------------------------------------------------------------------------ @@ -108,33 +106,20 @@ -- ^ The application to be served -> IO () httpServe config initializer handler = do - (snap, cleanup) <- runInitializerWithReloadAction + conf <- completeConfig config + let !verbose = fromJust $ getVerbose conf + let !reloader = fromJust $ getReloadHandler conf + let !compress = if fromJust $ getCompression conf then withCompression else id + let !catch500 = flip catch $ fromJust $ getErrorHandler conf + let !serve = SS.simpleHttpServe config + (site, cleanup) <- runInitializerWithReloadAction verbose initializer - (catch500 handler) + (catch500 $ compress handler) reloader - let site = compress $ snap - mapM_ printListen $ C.getListen config _ <- try $ serve $ site :: IO (Either SomeException ()) putStr "\n" cleanup - output "Shutting down..." - - where - conf = completeConfig config - verbose = fromJust $ getVerbose conf - output = when verbose . hPutStrLn stderr - reloader = fromJust $ getReloadHandler conf - compress = if fromJust $ getCompression conf then withCompression else id - catch500 = flip catch $ fromJust $ getErrorHandler conf - serve = simpleHttpServe config - - listenToString (C.ListenHttp host port) = - concat ["http://", fromUTF8 host, ":", show port, "/"] - listenToString (C.ListenHttps host port _ _) = - concat ["https://", fromUTF8 host, ":", show port, "/"] - - printListen l = output $ "Listening on " ++ listenToString l ------------------------------------------------------------------------------ diff --git a/test/snap-testsuite.cabal b/test/snap-testsuite.cabal --- a/test/snap-testsuite.cabal +++ b/test/snap-testsuite.cabal @@ -13,8 +13,9 @@ bytestring == 0.9.*, directory, filepath, + Glob == 0.5.*, HUnit >= 1.2 && < 2, - http-enumerator >= 0.2.1.5 && <0.3, + http-enumerator >= 0.6.5.3 && <0.7, process == 1.*, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3, 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 @@ -1,14 +1,22 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Snap.TestCommon where import Control.Concurrent import Control.Exception -import Control.Monad (when) +import Control.Monad (forM_, when) +import Data.Maybe +import Data.Monoid +import Prelude hiding (catch) import System.Cmd import System.Directory +import System.Environment import System.Exit import System.FilePath -import System.Process +import System.FilePath.Glob +import System.Process hiding (cwd) + testGeneratedProject :: String -- ^ project name and directory -> String -- ^ arguments to @snap init@ -> String -- ^ arguments to @cabal install@ @@ -25,8 +33,24 @@ removeDirectoryRecursive projectPath) $ do makeWorkDirectory projectPath setCurrentDirectory projectPath - systemOrDie $ "snap init " ++ snapInitArgs - systemOrDie $ "cabal install " ++ cabalInstallArgs + snapExe <- findSnap + systemOrDie $ snapExe ++ " init " ++ snapInitArgs + + snapCoreSrc <- fromEnv "SNAP_CORE_SRC" "../../../snap-core" + snapServerSrc <- fromEnv "SNAP_SERVER_SRC" "../../../snap-server" + xmlhtmlSrc <- fromEnv "XMLHTML_SRC" "../../../xmlhtml" + heistSrc <- fromEnv "HEIST_SRC" "../../../heist" + let snapSrc = "../.." + + forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap" ] + (pkgCleanUp sandbox) + + forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc + , snapSrc] $ \s -> + systemOrDie $ "cabal-dev " ++ cabalDevArgs + ++ " add-source " ++ s + + systemOrDie $ "cabal-dev install " ++ args let cmd = ("." "dist" "build" projName projName) ++ " -p " ++ show httpPort putStrLn $ "Running \"" ++ cmd ++ "\"" @@ -34,6 +58,10 @@ waitABit return (cwd, projectPath, pHandle) + fromEnv name def = do + r <- getEnv name `catch` \(_::SomeException) -> return "" + if r == "" then return def else return r + cleanup (cwd, projectPath, pHandle) = do setCurrentDirectory cwd terminateProcess pHandle @@ -41,6 +69,36 @@ removeDirectoryRecursive projectPath waitABit = threadDelay $ 2*10^(6::Int) + + sandbox = "../test-cabal-dev" projName + + cabalDevArgs = "-s " ++ sandbox + + pkgCleanUp d pkg = do + paths <- globDir1 (compile $ "packages*conf/" ++ pkg ++ "-*") d + forM_ paths + (\x -> (rm x `catch` \(_::SomeException) -> return ())) + where + rm x = do + putStrLn $ "removing " ++ x + removeFile x + + args = cabalDevArgs ++ " " ++ cabalInstallArgs + + gimmeIfExists p = do + b <- doesFileExist p + if b then return (Just p) else return Nothing + + + findSnap = do + home <- fromEnv "HOME" "." + p1 <- gimmeIfExists "../../dist/build/snap/snap" + p2 <- gimmeIfExists $ home ".cabal/bin/snap" + p3 <- findExecutable "snap" + + return $ fromMaybe (error "couldn't find snap executable") + (getFirst $ mconcat $ map First [p1,p2,p3]) + systemOrDie :: String -> IO () systemOrDie s = do