snap 0.4.3 → 0.5.0

raw patch · 12 files changed

+216/−139 lines, 12 filesdep ~directory-treedep ~snap-coredep ~snap-serverPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: directory-tree, snap-core, snap-server

API changes (from Hackage documentation)

Files

• project_template/barebones/foo.cabal +2/−2
• project_template/default/foo.cabal +3/−3
• project_template/default/src/Application.hs +1/−1
• project_template/default/src/Main.hs +6/−3
• snap.cabal +5/−4
• src/Snap/Extension/Heist/Impl.hs +15/−6
• src/Snap/Extension/Loader/Devel.hs +44/−27
• src/Snap/Extension/Loader/Devel/Evaluator.hs +61/−53
• src/Snap/Extension/Loader/Devel/TreeWatcher.hs +1/−6
• src/Snap/Extension/Server.hs +14/−29
• test/snap-testsuite.cabal +2/−1
• test/suite/Snap/TestCommon.hs +62/−4

@@ -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

@@ -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.*

@@ -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

@@ -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

@@ -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,

@@ -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.

@@ -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) 

@@ -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 []

@@ -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   ------------------------------------------------------------------------------

@@ -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   ------------------------------------------------------------------------------

@@ -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,

@@ -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