snap 0.11.3.1 → 0.12.0

raw patch · 26 files changed

+565/−289 lines, 26 filesdep ~heistdep ~snap-coredep ~snap-serverPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: heist, snap-core, snap-server

API changes (from Hackage documentation)

Files

• project_template/barebones/foo.cabal +2/−2
• project_template/default/foo.cabal +5/−5
• project_template/default/src/Site.hs +1/−1
• project_template/tutorial/foo.cabal +4/−4
• snap.cabal +9/−4
• src/Snap/Snaplet.hs +3/−0
• src/Snap/Snaplet/Auth/Handlers.hs +14/−11
• src/Snap/Snaplet/Auth/SpliceHelpers.hs +9/−6
• src/Snap/Snaplet/Heist.hs +105/−52
• src/Snap/Snaplet/Heist/Generic.hs +37/−0
• src/Snap/Snaplet/Heist/Internal.hs +30/−0
• src/Snap/Snaplet/Heist/Interpreted.hs +0/−1
• src/Snap/Snaplet/HeistNoClass.hs +150/−71
• src/Snap/Snaplet/Internal/Initializer.hs +40/−19
• src/Snap/Snaplet/Internal/Types.hs +58/−39
• src/Snap/Snaplet/Session/Backends/CookieSession.hs +16/−9
• src/Snap/Snaplet/Session/Common.hs +0/−7
• src/Snap/Snaplet/Session/SecureCookie.hs +6/−5
• src/Snap/Snaplet/Test.hs +3/−2
• test/snap-testsuite.cabal +22/−13
• test/suite/Blackbox/App.hs +5/−4
• test/suite/Blackbox/FooSnaplet.hs +6/−3
• test/suite/Blackbox/Tests.hs +18/−22
• test/suite/SafeCWD.hs +3/−0
• test/suite/Snap/Snaplet/Internal/Tests.hs +12/−1
• test/suite/TestSuite.hs +7/−8

@@ -19,8 +19,8 @@     bytestring                >= 0.9.1 && < 0.11,     MonadCatchIO-transformers >= 0.2.1 && < 0.4,     mtl                       >= 2     && < 3,-    snap-core                 >= 0.9   && < 0.10,-    snap-server               >= 0.9   && < 0.10+    snap-core                 >= 0.9   && < 0.11,+    snap-server               >= 0.9   && < 0.11    if impl(ghc >= 6.12.0)     ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2

@@ -24,12 +24,12 @@    Build-depends:     bytestring                >= 0.9.1   && < 0.11,-    heist                     >= 0.11    && < 0.12,+    heist                     >= 0.12    && < 0.13,     MonadCatchIO-transformers >= 0.2.1   && < 0.4,     mtl                       >= 2       && < 3,-    snap                      >= 0.11    && < 0.12,-    snap-core                 >= 0.9     && < 0.10,-    snap-server               >= 0.9     && < 0.10,+    snap                      >= 0.11    && < 0.13,+    snap-core                 >= 0.9     && < 0.11,+    snap-server               >= 0.9     && < 0.11,     snap-loader-static        >= 0.9     && < 0.10,     text                      >= 0.11    && < 0.12,     time                      >= 1.1     && < 1.5,@@ -42,7 +42,7 @@   else     build-depends:       base                      >= 4.4      && < 5,-      lens                      >= 3.7.6    && < 3.9+      lens                      >= 3.7.6    && < 3.10    if flag(development)     build-depends:

@@ -83,6 +83,6 @@     a <- nestSnaplet "auth" auth $            initJsonFileAuthManager defAuthSettings sess "users.json"     addRoutes routes-    addAuthSplices auth+    addAuthSplices h auth     return $ App h s a 

@@ -22,9 +22,9 @@     bytestring                >= 0.9.1   && < 0.11,     MonadCatchIO-transformers >= 0.2.1   && < 0.4,     mtl                       >= 2       && < 3,-    snap                      >= 0.11    && < 0.12,-    snap-core                 >= 0.9     && < 0.10,-    snap-server               >= 0.9     && < 0.10+    snap                      >= 0.11    && < 0.13,+    snap-core                 >= 0.9     && < 0.11,+    snap-server               >= 0.9     && < 0.11    if flag(old-base)     build-depends:@@ -33,7 +33,7 @@   else     build-depends:       base                      >= 4.4      && < 5,-      lens                      >= 3.7.6    && < 3.9+      lens                      >= 3.7.6    && < 3.10    if impl(ghc >= 6.12.0)     ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2

@@ -1,5 +1,5 @@ name:           snap-version:        0.11.3.1+version:        0.12.0 synopsis:       Top-level package for the Snap Web Framework description:     This is the top-level package for the official Snap Framework libraries.@@ -111,6 +111,7 @@     Snap.Snaplet.Heist     Snap.Snaplet.HeistNoClass     Snap.Snaplet.Heist.Compiled+    Snap.Snaplet.Heist.Generic     Snap.Snaplet.Heist.Interpreted     Snap.Snaplet.Auth     Snap.Snaplet.Auth.Backends.JsonFile@@ -133,6 +134,7 @@     Snap.Snaplet.Auth.Types     Snap.Snaplet.Auth.Handlers     Snap.Snaplet.Auth.SpliceHelpers+    Snap.Snaplet.Heist.Internal     Snap.Snaplet.Internal.Initializer     Snap.Snaplet.Internal.LensT     Snap.Snaplet.Internal.Lensed@@ -157,14 +159,14 @@     filepath                  >= 1.1      && < 1.4,     -- Blacklist bad versions of hashable     hashable                  (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),-    heist                     >= 0.11     && < 0.12,+    heist                     >= 0.12     && < 0.13,     logict                    >= 0.4.2    && < 0.7,     mtl                       >  2.0      && < 2.2,     mwc-random                >= 0.8      && < 0.13,     pwstore-fast              >= 2.2      && < 2.4,     regex-posix               >= 0.95     && < 1,-    snap-core                 >= 0.9      && < 0.10,-    snap-server               >= 0.9      && < 0.10,+    snap-core                 >= 0.9      && < 0.11,+    snap-server               >= 0.9      && < 0.11,     stm                       >= 2.2      && < 2.5,     syb                       >= 0.1      && < 0.5,     text                      >= 0.11     && < 0.12,@@ -231,6 +233,9 @@     snap-server         >= 0.9     && < 0.11,     template-haskell    >= 2.2     && < 2.9,     text                >= 0.11    && < 0.12++  extensions:+    OverloadedStrings    ghc-prof-options: -prof -auto-all 

@@ -64,6 +64,7 @@   , getSnapletDescription   , getSnapletUserConfig   , getSnapletRootURL+  , snapletURL   , getRoutePattern   , setRoutePattern @@ -100,7 +101,9 @@    -- * Handlers   , Handler+  , failIfNotLocal   , reloadSite+  , modifyMaster   , bracketHandler    -- * Serving Applications

@@ -59,7 +59,7 @@ ------------------------------------------------------------------------------ -- | Lookup a user by her username, check given password and perform login ---loginByUsername :: ByteString       -- ^ Username/login for user+loginByUsername :: Text             -- ^ Username/login for user                 -> Password         -- ^ Should be ClearText                 -> Bool             -- ^ Set remember token?                 -> Handler b (AuthManager b) (Either AuthFailure AuthUser)@@ -79,7 +79,7 @@                      -> t                      -> Handler b (AuthManager b) (Either AuthFailure AuthUser)     loginByUsername' sk cn rp r =-        liftIO (lookupByLogin r $ decodeUtf8 unm) >>=+        liftIO (lookupByLogin r unm) >>=         maybe (return $! Left UserNotFound) found        where@@ -108,16 +108,18 @@ ------------------------------------------------------------------------------ -- | Remember user from the remember token if possible and perform login ---loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)+loginByRememberToken :: Handler b (AuthManager b) (Either AuthFailure AuthUser) loginByRememberToken = withBackend $ \impl -> do     key         <- gets siteKey     cookieName_ <- gets rememberCookieName     period      <- gets rememberPeriod -    runMaybeT $ do-        token <- MaybeT $ getRememberToken key cookieName_ period-        user  <- MaybeT $ liftIO $ lookupByRememberToken impl-                                 $ decodeUtf8 token+    runEitherT $ do+        token <- noteT (AuthError "loginByRememberToken: no remember token") $+                   MaybeT $ getRememberToken key cookieName_ period+        user  <- noteT (AuthError "loginByRememberToken: no remember token") $+                   MaybeT $ liftIO $ lookupByRememberToken impl+                                   $ decodeUtf8 token         lift $ forceLogin user         return user @@ -142,7 +144,7 @@     s   <- gets session     uid <- withTop s getSessionUserId     case uid of-      Nothing -> loginByRememberToken+      Nothing -> hush <$> loginByRememberToken       Just uid' -> liftIO $ lookupByUserId r uid'  @@ -286,14 +288,14 @@ -- who she says she is. -- forceLogin :: AuthUser       -- ^ An existing user, somehow looked up from db-           -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+           -> Handler b (AuthManager b) (Either AuthFailure ()) forceLogin u = do     s <- gets session     withSession s $         case userId u of           Just x -> do             withTop s (setSessionUserId x)-            return $ Right u+            return $ Right ()           Nothing -> return . Left $                      AuthError $ "forceLogin: Can't force the login of a user "                                    ++ "without userId"@@ -450,7 +452,8 @@     password <- noteT PasswordMissing $ hoistMaybe mbPassword     username <- noteT UsernameMissing $ hoistMaybe mbUsername -    EitherT $ loginByUsername username (ClearText password) remember+    EitherT $ loginByUsername (decodeUtf8 username)+                              (ClearText password) remember   ------------------------------------------------------------------------------

@@ -52,14 +52,17 @@ -- \<loggedInUser\> addAuthSplices   :: HasHeist b-  => SnapletLens b (AuthManager b)+  => Snaplet (Heist b)+  -> SnapletLens b (AuthManager b)       -- ^ A lens reference to 'AuthManager'   -> Initializer b v ()-addAuthSplices auth = addSplices-    [ ("ifLoggedIn", ifLoggedIn auth)-    , ("ifLoggedOut", ifLoggedOut auth)-    , ("loggedInUser", loggedInUser auth)-    ]+addAuthSplices h auth = addConfig h $ mempty+    { hcInterpretedSplices = [ ("ifLoggedIn", ifLoggedIn auth)+                             , ("ifLoggedOut", ifLoggedOut auth)+                             , ("loggedInUser", loggedInUser auth)+                             ]+    , hcCompiledSplices = compiledAuthSplices auth+    }   ------------------------------------------------------------------------------

@@ -13,15 +13,23 @@   -- $initializerSection   , heistInit   , heistInit'+  , Unclassed.heistReloader+  , Unclassed.setInterpreted+  , Unclassed.getCurHeistConfig    , addTemplates   , addTemplatesAt   , Unclassed.addConfig   , modifyHeistState   , withHeistState-  , addSplices    -- * Handler Functions   -- $handlerSection+  , gRender+  , gRenderAs+  , gHeistServe+  , gHeistServeSingle+  , chooseMode+   , cRender   , cRenderAs   , cHeistServe@@ -46,14 +54,15 @@  ------------------------------------------------------------------------------ import           Prelude hiding (id, (.))+import           Control.Monad.State import           Data.ByteString (ByteString) import           Data.Text (Text) import           Heist ------------------------------------------------------------------------------ import           Snap.Snaplet+import           Snap.Snaplet.Heist.Internal import qualified Snap.Snaplet.HeistNoClass as Unclassed-import           Snap.Snaplet.HeistNoClass ( Heist-                                           , heistInit+import           Snap.Snaplet.HeistNoClass ( heistInit                                            , heistInit'                                            , clearHeistCache                                            )@@ -72,7 +81,7 @@ -- > -- > appInit = makeSnaplet "app" "" Nothing $ do -- >     h <- nestSnaplet "heist" heist $ heistInit "templates"--- >     addSplices myAppSplices+-- >     addConfig h heistConfigWithMyAppSplices -- >     return $ App h class HasHeist b where     -- | A lens to the Heist snaplet.  The b parameter to Heist will@@ -116,19 +125,6 @@   --------------------------------------------------------------------------------- | Allows snaplets to add interpreted splices.------ NOTE: The splices added with this function will not work if you render your--- templates with cRender.  To add splices that work with cRender, you have to--- use the addConfig function to add compiled splices or load time splices.-addSplices :: (HasHeist b)-           => [(Text, Unclassed.SnapletISplice b)]-               -- ^ Splices to bind-           -> Initializer b v ()-addSplices = Unclassed.addSplices' heistLens--------------------------------------------------------------------------------- -- | More general function allowing arbitrary HeistState modification. modifyHeistState :: (HasHeist b)                  => (HeistState (Handler b b) -> HeistState (Handler b b))@@ -148,35 +144,70 @@  -- $handlerSection -- This section contains functions in the 'Handler' monad that you'll use in--- processing requests.  Functions beginning with a 'c' prefix use compiled--- template rendering.  The other functions use the older interpreted--- rendering.  Splices added with addSplices will only work if you use+-- processing requests.  Functions beginning with a 'g' prefix use generic+-- rendering that checks the preferred rendering mode and chooses+-- appropriately.  Functions beginning with a 'c' prefix use compiled template+-- rendering.  The other functions use the older interpreted rendering.+-- Interpreted splices added with addConfig will only work if you use -- interpreted rendering.+--+-- The generic functions are useful if you are writing general snaplets that+-- use heist, but need to work for applications that use either interpreted+-- or compiled mode.   --------------------------------------------------------------------------------- | Renders a template as text\/html. If the given template is not found,--- this returns 'empty'.-render :: HasHeist b-       => ByteString-           -- ^ Template name-       -> Handler b v ()-render t = withTop' heistLens (Unclassed.render t)+-- | Generic version of 'render'/'cRender'.+gRender :: HasHeist b+        => ByteString+            -- ^ Template name+        -> Handler b v ()+gRender t = withTop' heistLens (Unclassed.gRender t)   --------------------------------------------------------------------------------- | Renders a template as the given content type.  If the given template--- is not found, this returns 'empty'.-renderAs :: HasHeist b-         => ByteString-             -- ^ Content type to render with-         -> ByteString-             -- ^ Template name-         -> Handler b v ()-renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t)+-- | Generic version of 'renderAs'/'cRenderAs'.+gRenderAs :: HasHeist b+          => ByteString+              -- ^ Content type to render with+          -> ByteString+              -- ^ Template name+          -> Handler b v ()+gRenderAs ct t = withTop' heistLens (Unclassed.gRenderAs ct t)   ------------------------------------------------------------------------------+-- | Generic version of 'heistServe'/'cHeistServe'.+gHeistServe :: HasHeist b => Handler b v ()+gHeistServe = withTop' heistLens Unclassed.gHeistServe+++------------------------------------------------------------------------------+-- | Generic version of 'heistServeSingle'/'cHeistServeSingle'.+gHeistServeSingle :: HasHeist b+                  => ByteString+                      -- ^ Template name+                  -> Handler b v ()+gHeistServeSingle t = withTop' heistLens (Unclassed.gHeistServeSingle t)+++------------------------------------------------------------------------------+-- | Chooses between a compiled action and an interpreted action based on the+-- configured default.+chooseMode :: HasHeist b+           => Handler b v a+               -- ^ A compiled action+           -> Handler b v a+               -- ^ An interpreted action+           -> Handler b v a+chooseMode cAction iAction = do+    mode <- withTop' heistLens $ gets _defMode+    case mode of+      Unclassed.Compiled -> cAction+      Unclassed.Interpreted -> iAction+++------------------------------------------------------------------------------ -- | Renders a compiled template as text\/html. If the given template is not -- found, this returns 'empty'. cRender :: HasHeist b@@ -199,6 +230,44 @@   ------------------------------------------------------------------------------+-- | A compiled version of 'heistServe'.+cHeistServe :: HasHeist b => Handler b v ()+cHeistServe = withTop' heistLens Unclassed.cHeistServe+++------------------------------------------------------------------------------+-- | Analogous to 'fileServeSingle'. If the given template is not found,+-- this throws an error.+cHeistServeSingle :: HasHeist b+                 => ByteString+                     -- ^ Template name+                 -> Handler b v ()+cHeistServeSingle t = withTop' heistLens (Unclassed.cHeistServeSingle t)+++------------------------------------------------------------------------------+-- | Renders a template as text\/html. If the given template is not found,+-- this returns 'empty'.+render :: HasHeist b+       => ByteString+           -- ^ Template name+       -> Handler b v ()+render t = withTop' heistLens (Unclassed.render t)+++------------------------------------------------------------------------------+-- | Renders a template as the given content type.  If the given template+-- is not found, this returns 'empty'.+renderAs :: HasHeist b+         => ByteString+             -- ^ Content type to render with+         -> ByteString+             -- ^ Template name+         -> Handler b v ()+renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t)+++------------------------------------------------------------------------------ -- | A handler that serves all the templates (similar to 'serveDirectory'). -- If the template specified in the request path is not found, it returns -- 'empty'.  Also, this function does not serve any templates beginning with@@ -219,22 +288,6 @@                      -- ^ Template name                  -> Handler b v () heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t)------------------------------------------------------------------------------------ | A compiled version of 'heistServe'.-cHeistServe :: HasHeist b => Handler b v ()-cHeistServe = withTop' heistLens Unclassed.cHeistServe------------------------------------------------------------------------------------ | Analogous to 'fileServeSingle'. If the given template is not found,--- this throws an error.-cHeistServeSingle :: HasHeist b-                 => ByteString-                     -- ^ Template name-                 -> Handler b v ()-cHeistServeSingle t = withTop' heistLens (Unclassed.cHeistServeSingle t)   ------------------------------------------------------------------------------

@@ -0,0 +1,37 @@+{-|++A module exporting only generic functions that choose between compiled and+interpreted mode based on the setting specified in the initializer.  This+module is most useful for writitng general snaplets that use Heist and are+meant to be used in applications that might use either interpreted or compiled+templates.++-}+module Snap.Snaplet.Heist.Generic+  ( Heist+  , HasHeist(..)+  , SnapletHeist+  , SnapletCSplice++  -- * Initializer Functions+  -- $initializerSection+  , heistInit+  , heistInit'+  , addTemplates+  , addTemplatesAt+  , addConfig+  , modifyHeistState+  , withHeistState++  -- * Handler Functions+  -- $handlerSection+  , gRender+  , gRenderAs+  , gHeistServe+  , gHeistServeSingle+  , chooseMode++  , clearHeistCache+  ) where++import Snap.Snaplet.Heist

@@ -0,0 +1,30 @@+module Snap.Snaplet.Heist.Internal where++import           Prelude hiding ((.), id)+import           Control.Lens+import           Data.IORef+import           Heist+import           Heist.Splices.Cache++import           Snap.Snaplet+++data DefaultMode = Compiled | Interpreted+++------------------------------------------------------------------------------+-- | The state for the Heist snaplet.  To use the Heist snaplet in your app+-- include this in your application state and use 'heistInit' to initialize+-- it.  The type parameter b will typically be the base state type for your+-- application.+data Heist b = Configuring+                 { _heistConfig :: IORef (HeistConfig (Handler b b), DefaultMode)+                 }+             | Running+                 { _masterConfig :: HeistConfig (Handler b b)+                 , _heistState   :: HeistState (Handler b b)+                 , _heistCTS     :: CacheTagState+                 , _defMode      :: DefaultMode+                 }++makeLenses ''Heist

@@ -21,7 +21,6 @@   , addConfig   , modifyHeistState   , withHeistState-  , addSplices    -- * Handler Functions   -- $handlerSection

@@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE FunctionalDependencies     #-}-{-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeSynonymInstances       #-}  {-|@@ -17,8 +16,12 @@ -} module Snap.Snaplet.HeistNoClass   ( Heist+  , DefaultMode(..)   , heistInit   , heistInit'+  , heistReloader+  , setInterpreted+  , getCurHeistConfig    , clearHeistCache    , addTemplates@@ -27,9 +30,13 @@   , modifyHeistState'   , withHeistState   , withHeistState'-  , addSplices-  , addSplices' +  , gRender+  , gRenderAs+  , gHeistServe+  , gHeistServeSingle+  , chooseMode+   , addConfig   , cRender   , cRenderAs@@ -55,8 +62,8 @@ import           Prelude hiding ((.), id) import           Control.Applicative import           Control.Category-import           Control.Comonad import           Control.Error+import           Control.Lens import           Control.Monad.Reader import           Control.Monad.State import           Data.ByteString (ByteString)@@ -76,30 +83,18 @@ import           Heist.Splices.Cache  import           Snap.Snaplet+import           Snap.Snaplet.Heist.Internal import           Snap.Core import           Snap.Util.FileServe   --------------------------------------------------------------------------------- | The state for the Heist snaplet.  To use the Heist snaplet in your app--- include this in your application state and use 'heistInit' to initialize--- it.  The type parameter b will typically be the base state type for your--- application.-data Heist b = Configuring-                 { _heistConfig :: IORef (HeistConfig (Handler b b)) }-             | Running-                 { _heistState    :: HeistState (Handler b b)-                 , _heistCTS      :: CacheTagState-                 }--------------------------------------------------------------------------------- changeState :: (HeistState (Handler a a) -> HeistState (Handler a a))             -> Heist a             -> Heist a changeState _ (Configuring _)  =     error "changeState: HeistState has not been initialized"-changeState f (Running hs cts) = Running (f hs) cts+changeState f (Running hc hs cts dm) = Running hc (f hs) cts dm   ------------------------------------------------------------------------------@@ -110,6 +105,22 @@ clearHeistCache = clearCacheTagState . _heistCTS  +------------------------------------------------------------------------------+-- | Handler that triggers a template reload.  For large sites, this can be+-- desireable because it may be much quicker than the full site reload+-- provided at the /admin/reload route.  This allows you to reload only the+-- heist templates  This handler is automatically set up by heistInit, but if+-- you use heistInit', then you can create your own route with it.+heistReloader :: Handler b (Heist b) ()+heistReloader = do+    h <- get+    ehs <- liftIO $ runEitherT $ initHeist $ _masterConfig h+    either (writeText . T.pack . unlines)+           (\hs -> do writeText "Heist reloaded."+                      modifyMaster $ set heistState hs h)+           ehs++                          -----------------------------                          -- SnapletSplice functions --                          -----------------------------@@ -134,14 +145,17 @@ ------------------------------------------------------------------------------ -- | The 'Initializer' for 'Heist'. This function is a convenience wrapper -- around `heistInit'` that uses defaultHeistState and sets up routes for all--- the templates.+-- the templates.  It sets up a \"heistReload\" route that reloads the heist+-- templates when you request it from localhost. heistInit :: FilePath               -- ^ Path to templates           -> SnapletInit b (Heist b) heistInit templateDir = do     makeSnaplet "heist" "" Nothing $ do         hs <- heistInitWorker templateDir defaultConfig-        addRoutes [ ("", heistServe) ]+        addRoutes [ ("", heistServe)+                  , ("heistReload", failIfNotLocal heistReloader)+                  ]         return hs   where     defaultConfig = mempty { hcLoadTimeSplices = defaultLoadTimeSplices }@@ -161,8 +175,8 @@   --------------------------------------------------------------------------------- | Internal worker function used by variantsof heistInit.  This is necessary--- because of the divide between SnapletInit and Initializer.+-- | Internal worker function used by variants of heistInit.  This is+-- necessary because of the divide between SnapletInit and Initializer. heistInitWorker :: FilePath                 -> HeistConfig (Handler b b)                 -> Initializer b (Heist b) (Heist b)@@ -171,29 +185,47 @@     let tDir = snapletPath </> templateDir     templates <- liftIO $ runEitherT (loadTemplates tDir) >>=                           either (error . concat) return-    let config = initialConfig `mappend` mempty { hcTemplates = templates }     printInfo $ T.pack $ unwords         [ "...loaded"         , (show $ Map.size templates)         , "templates from"         , tDir         ]-    ref <- liftIO $ newIORef config+    let config = initialConfig `mappend`+                 mempty { hcTemplateLocations = [loadTemplates tDir] }+    ref <- liftIO $ newIORef (config, Compiled)++    -- FIXME This runs after all the initializers, but before post init+    -- hooks registered by other snaplets.     addPostInitHook finalLoadHook     return $ Configuring ref   ------------------------------------------------------------------------------+-- | Sets the snaplet to default to interpreted mode.  Initially, the+-- initializer sets the value to compiled mode.  This function allows you to+-- override that setting.  Note that this is just a default.  It only has an+-- effect if you use one of the generic functions: 'gRender', 'gRenderAs',+-- 'gHeistServe', or 'gHeistServeSingle'.  If you call the non-generic+-- versions directly, then this value will not be checked and you will get the+-- mode implemented by the function you called.+setInterpreted :: Snaplet (Heist b) -> Initializer b v ()+setInterpreted h = +    liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h)+        (\(hc,_) -> ((hc,Interpreted),()))+++------------------------------------------------------------------------------ -- | Hook that converts the Heist type from Configuring to Running at the end -- of initialization. finalLoadHook :: Heist b -> EitherT Text IO (Heist b) finalLoadHook (Configuring ref) = do-    hc <- lift $ readIORef ref+    (hc,dm) <- lift $ readIORef ref     (hs,cts) <- toTextErrors $ initHeistWithCacheTag hc-    return $ Running hs cts+    return $ Running hc hs cts dm   where     toTextErrors = bimapEitherT (T.pack . intercalate "\n") id-finalLoadHook (Running _ _) = left "finalLoadHook called while running"+finalLoadHook (Running _ _ _ _) = left "finalLoadHook called while running"   ------------------------------------------------------------------------------@@ -226,10 +258,10 @@     rootUrl <- getSnapletRootURL     let fullPrefix = (T.unpack $ decodeUtf8 rootUrl) </>                      (T.unpack $ decodeUtf8 urlPrefix)-        addPrefix = return . addTemplatePathPrefix-                               (encodeUtf8 $ T.pack fullPrefix)+        addPrefix = addTemplatePathPrefix+                      (encodeUtf8 $ T.pack fullPrefix)     ts <- liftIO $ runEitherT (loadTemplates templateDir) >>=-                   either (error . concat) addPrefix+                   either (error . concat) return     printInfo $ T.pack $ unwords         [ "...adding"         , (show $ Map.size ts)@@ -238,10 +270,22 @@         , "with route prefix"         , fullPrefix ++ "/"         ]-    liftIO $ atomicModifyIORef (_heistConfig $ extract h)-        (\hc -> (hc `mappend` mempty { hcTemplates = ts }, ()))+    let locations = [liftM addPrefix $ loadTemplates templateDir]+        hc' = mempty { hcTemplateLocations = locations }+    liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h)+        (\(hc,dm) -> ((hc `mappend` hc', dm), ()))  +getCurHeistConfig :: Snaplet (Heist b)+                  -> Initializer b v (HeistConfig (Handler b b))+getCurHeistConfig h = case view snapletValue h of+    Configuring ref -> do+        (hc, _) <- liftIO $ readIORef ref+        return hc+    Running _ _ _ _ ->+        error "Can't get HeistConfig after heist is initialized."+    + ------------------------------------------------------------------------------ modifyHeistState' :: SnapletLens (Snaplet b) (Heist b)                   -> (HeistState (Handler b b) -> HeistState (Handler b b))@@ -280,30 +324,15 @@ addConfig :: Snaplet (Heist b)           -> HeistConfig (Handler b b)           -> Initializer b v ()-addConfig h hc = case extract h of+addConfig h hc = case view snapletValue h of     Configuring ref ->-        liftIO $ atomicModifyIORef ref (\hc1 -> (hc1 `mappend` hc, ()))-    Running _ _ -> do+        liftIO $ atomicModifyIORef ref+                   (\(hc1,dm) -> ((hc1 `mappend` hc, dm), ()))+    Running _ _ _ _ -> do         printInfo "finalLoadHook called while running"         error "this shouldn't happen"  --------------------------------------------------------------------------------addSplices' :: SnapletLens (Snaplet b) (Heist b)-            -> [(Text, SnapletISplice b)]-            -> Initializer b v ()-addSplices' heist splices = do-    withTop' heist $ addPostInitHook $-        return . changeState (I.bindSplices splices)----------------------------------------------------------------------------------addSplices :: SnapletLens b (Heist b)-           -> [(Text, SnapletISplice b)]-           -> Initializer b v ()-addSplices heist splices = addSplices' (subSnaplet heist) splices--                             -----------------------                             -- Handler functions --                             -----------------------@@ -314,7 +343,7 @@              -> ByteString              -> Handler b (Heist b) () iRenderHelper c t = do-    (Running hs _) <- get+    (Running _ hs _ _) <- get     withTop' id $ I.renderTemplate hs t >>= maybe pass serve   where     serve (b, mime) = do@@ -328,7 +357,7 @@               -> ByteString               -> Handler b (Heist b) () cRenderHelper c t = do-    (Running hs _) <- get+    (Running _ hs _ _) <- get     withTop' id $ maybe pass serve $ C.renderTemplate hs t   where     serve (b, mime) = do@@ -337,6 +366,15 @@   ------------------------------------------------------------------------------+serveURI :: Handler b (Heist b) ByteString+serveURI = do+    p <- getSafePath+    -- Allows users to prefix template filenames with an underscore to prevent+    -- the template from being served.+    if take 1 p == "_" then pass else return $ B.pack p+++------------------------------------------------------------------------------ render :: ByteString            -- ^ Name of the template        -> Handler b (Heist b) ()@@ -353,6 +391,18 @@   ------------------------------------------------------------------------------+heistServe :: Handler b (Heist b) ()+heistServe =+    ifTop (render "index") <|> (render =<< serveURI)+++------------------------------------------------------------------------------+heistServeSingle :: ByteString -> Handler b (Heist b) ()+heistServeSingle t =+    render t <|> error ("Template " ++ show t ++ " not found.")+++------------------------------------------------------------------------------ cRender :: ByteString            -- ^ Name of the template         -> Handler b (Heist b) ()@@ -369,36 +419,65 @@   -------------------------------------------------------------------------------serveURI :: Handler b (Heist b) ByteString-serveURI = do-    p <- getSafePath-    -- Allows users to prefix template filenames with an underscore to prevent-    -- the template from being served.-    if take 1 p == "_" then pass else return $ B.pack p+cHeistServe :: Handler b (Heist b) ()+cHeistServe =+    ifTop (cRender "index") <|> (cRender =<< serveURI)   -------------------------------------------------------------------------------heistServe :: Handler b (Heist b) ()-heistServe =-    ifTop (render "index") <|> (render =<< serveURI)+cHeistServeSingle :: ByteString -> Handler b (Heist b) ()+cHeistServeSingle t =+    cRender t <|> error ("Template " ++ show t ++ " not found.")   -------------------------------------------------------------------------------heistServeSingle :: ByteString -> Handler b (Heist b) ()-heistServeSingle t =-    render t <|> error ("Template " ++ show t ++ " not found.")+-- | Chooses between a compiled action and an interpreted action based on the+-- configured default.+chooseMode :: MonadState (Heist b1) m+           => m b+               -- ^ A compiled action+           -> m b+               -- ^ An interpreted action+           -> m b+chooseMode cAction iAction = do+    mode <- gets _defMode+    case mode of+      Compiled -> cAction+      Interpreted -> iAction   -------------------------------------------------------------------------------cHeistServe :: Handler b (Heist b) ()-cHeistServe =-    ifTop (cRender "index") <|> (cRender =<< serveURI)+-- | Like render/cRender, but chooses between the two appropriately based on+-- the default mode.+gRender :: ByteString+           -- ^ Name of the template+        -> Handler b (Heist b) ()+gRender t = chooseMode (cRender t) (render t)   -------------------------------------------------------------------------------cHeistServeSingle :: ByteString -> Handler b (Heist b) ()-cHeistServeSingle t =-    cRender t <|> error ("Template " ++ show t ++ " not found.")+-- | Like renderAs/cRenderAs, but chooses between the two appropriately based+-- on the default mode.+gRenderAs :: ByteString+             -- ^ Content type+          -> ByteString+             -- ^ Name of the template+          -> Handler b (Heist b) ()+gRenderAs ct t = chooseMode (cRenderAs ct t) (renderAs ct t)+++------------------------------------------------------------------------------+-- | Like heistServe/cHeistServe, but chooses between the two appropriately+-- based on the default mode.+gHeistServe :: Handler b (Heist b) ()+gHeistServe = chooseMode cHeistServe heistServe+++------------------------------------------------------------------------------+-- | Like heistServeSingle/cHeistServeSingle, but chooses between the two+-- appropriately based on the default mode.+gHeistServeSingle :: ByteString -> Handler b (Heist b) ()+gHeistServeSingle t = chooseMode (cHeistServeSingle t) (heistServeSingle t)   ------------------------------------------------------------------------------

@@ -22,6 +22,7 @@   , loadAppConfig   , printInfo   , getRoutes+  , modifyMaster   ) where  import           Prelude hiding (catch)@@ -89,9 +90,9 @@ -- | Converts a plain hook into a Snaplet hook. toSnapletHook :: (v -> EitherT Text IO v)               -> (Snaplet v -> EitherT Text IO (Snaplet v))-toSnapletHook f (Snaplet cfg val) = do+toSnapletHook f (Snaplet cfg  reset val) = do     val' <- f val-    return $! Snaplet cfg val'+    return $! Snaplet cfg reset val'   ------------------------------------------------------------------------------@@ -239,11 +240,15 @@ ------------------------------------------------------------------------------ -- | Internal function that gets the SnapletConfig out of the initializer -- state and uses it to create a (Snaplet a).-mkSnaplet :: Initializer b v a -> Initializer b v (Snaplet a)+mkSnaplet :: Initializer b v v -> Initializer b v (Snaplet v) mkSnaplet m = do     res <- m     cfg <- iGets _curConfig-    return $ Snaplet cfg res+    setInTop <- iGets masterReloader+    l <- getLens+    let modifier = setInTop  . set (cloneLens l . snapletValue)+    return $ Snaplet cfg modifier res+       ------------------------------------------------------------------------------@@ -325,10 +330,12 @@        -> Initializer b v a chroot rte l (Initializer m) = do     curState <- iGet+    let newSetter f = masterReloader curState (over (cloneLens l) f)     ((a,s), (Hook hook)) <- liftIO $ runWriterT $ LT.runLensT m id $         curState {           _handlers = [],-          _hFilter = id+          _hFilter = id,+          masterReloader = newSetter         }     let handler = chrootHandler l $ _hFilter s $ route $ _handlers s     iModify $ over handlers (++[(rte,handler)])@@ -443,17 +450,17 @@ -- | Builds an IO reload action for storage in the SnapletState. mkReloader :: FilePath            -> String-           -> MVar (Snaplet b)+           -> ((Snaplet b -> Snaplet b) -> IO ())            -> IORef (IO ())            -> Initializer b b (Snaplet b)            -> IO (Either Text Text)-mkReloader cwd env mvar cleanupRef i = do+mkReloader cwd env resetter cleanupRef i = do     join $ readIORef cleanupRef-    !res <- runInitializer' mvar env i cwd+    !res <- runInitializer' resetter env i cwd     either (return . Left) good res   where     good (b,is) = do-        _ <- swapMVar mvar b+        _ <- resetter (const b)         msgs <- readIORef $ _initMessages is         return $ Right msgs @@ -470,36 +477,47 @@   ------------------------------------------------------------------------------+-- | Lets you change a snaplet's initial state.  It's alomst like a reload,+-- except that it doesn't run the initializer.  It just modifies the result of+-- the initializer.  This can be used to let you define actions for reloading+-- individual snaplets.+modifyMaster :: v -> Handler b v ()+modifyMaster v = do+    modifier <- getsSnapletState _snapletModifier+    liftIO $ modifier v+++------------------------------------------------------------------------------ -- | Internal function for running Initializers.  If any exceptions were -- thrown by the initializer, this function catches them, runs any cleanup -- actions that had been registered, and returns an expanded error message -- containing the exception details as well as all messages generated by the -- initializer before the exception was thrown.-runInitializer :: MVar (Snaplet b)+runInitializer :: ((Snaplet b -> Snaplet b) -> IO ())                -> String                -> Initializer b b (Snaplet b)                -> IO (Either Text (Snaplet b, InitializerState b))-runInitializer mvar env b =-    getCurrentDirectory >>= runInitializer' mvar env b+runInitializer resetter env b =+    getCurrentDirectory >>= runInitializer' resetter env b   -------------------------------------------------------------------------------runInitializer' :: MVar (Snaplet b)+runInitializer' :: ((Snaplet b -> Snaplet b) -> IO ())                 -> String                 -> Initializer b b (Snaplet b)                 -> FilePath                 -> IO (Either Text (Snaplet b, InitializerState b))-runInitializer' mvar env b@(Initializer i) cwd = do+runInitializer' resetter env b@(Initializer i) cwd = do     cleanupRef <- newIORef (return ())+    let reloader_ = mkReloader cwd env resetter cleanupRef b     let builtinHandlers = [("/admin/reload", reloadSite)]-    let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing-                            (mkReloader cwd env mvar cleanupRef b)+    let cfg = SnapletConfig [] cwd Nothing "" empty [] Nothing reloader_     logRef <- newIORef ""      let body = runEitherT $ do             ((res, s), (Hook hook)) <- lift $ runWriterT $ LT.runLensT i id $                 InitializerState True cleanupRef builtinHandlers id cfg logRef-                                 env+                                 env resetter             res' <- hook res             right (res', s) @@ -528,7 +546,8 @@ runSnaplet :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ()) runSnaplet env (SnapletInit b) = do     snapletMVar <- newEmptyMVar-    eRes <- runInitializer snapletMVar (fromMaybe "devel" env) b+    let resetter f = modifyMVar_ snapletMVar (return . f)+    eRes <- runInitializer resetter (fromMaybe "devel" env) b     let go (siteSnaplet,is) = do         putMVar snapletMVar siteSnaplet         msgs <- liftIO $ readIORef $ _initMessages is@@ -574,10 +593,12 @@     createDirectoryIfMissing False "log"     let serve = simpleHttpServe conf -    liftIO $ hPutStrLn stderr $ T.unpack msgs+    when (loggingEnabled conf) $ liftIO $ hPutStrLn stderr $ T.unpack msgs     _ <- try $ serve $ site          :: IO (Either SomeException ())     doCleanup+  where+    loggingEnabled = not . (== Just False) . getVerbose   ------------------------------------------------------------------------------

@@ -14,7 +14,6 @@ module Snap.Snaplet.Internal.Types where  import           Control.Applicative-import           Control.Comonad import           Control.Error import           Control.Lens import           Control.Monad.CatchIO hiding (Handler)@@ -27,7 +26,6 @@ import           Data.IORef import           Data.Monoid import           Data.Text (Text)-import           Data.Foldable (Foldable(..))  import           Snap.Core import qualified Snap.Snaplet.Internal.LensT as LT@@ -50,6 +48,10 @@         -- current handler.  Nothing during initialization and before route         -- dispatech.     , _reloader          :: IO (Either Text Text) -- might change+        -- ^ This is the universal reload action for the top-level site.  We+        -- can't update this in place to be a reloader for each individual+        -- snaplet because individual snaplets can't be reloaded in isolation+        -- without losing effects that subsequent hooks may have had.     }  makeLenses ''SnapletConfig@@ -58,7 +60,7 @@ ------------------------------------------------------------------------------ -- | Joins a reversed list of directories into a path. buildPath :: [ByteString] -> ByteString-buildPath ps = B.intercalate "/" $ reverse ps+buildPath ps = B.intercalate "/" $ filter (not . B.null) $ reverse ps   ------------------------------------------------------------------------------@@ -77,28 +79,35 @@ --   the snaplet's configuration, the snaplet's root directory on the --   filesystem, the snaplet's root URL, and so on. data Snaplet s = Snaplet-    { _snapletConfig :: SnapletConfig-    , _snapletValue  :: s+    { _snapletConfig   :: SnapletConfig+    , _snapletModifier :: s -> IO ()+        -- ^ See the _reloader comment for why we have to use this to reload+        -- single snaplets in isolation.  This action won't actually run the+        -- initializer at all.  It will only modify the existing state.  It is+        -- the responsibility of the snaplet author to avoid using this in+        -- situations where it will destroy data in its state that was created+        -- by subsequent hook actions.+    , _snapletValue    :: s     }  makeLenses ''Snaplet -instance Functor Snaplet where-  fmap f (Snaplet c a) = Snaplet c (f a)--instance Foldable Snaplet where-  foldMap f (Snaplet _ a) = f a--instance Traversable Snaplet where-  traverse f (Snaplet c a) = Snaplet c <$> f a--instance Comonad Snaplet where-  extract (Snaplet _ a) = a--#if !(MIN_VERSION_comonad(3,0,0))-instance Extend Snaplet where-#endif-  extend f w@(Snaplet c _) = Snaplet c (f w)+--instance Functor Snaplet where+--  fmap f (Snaplet c r a) = Snaplet c r (f a)+--+--instance Foldable Snaplet where+--  foldMap f (Snaplet _ _ a) = f a+--+--instance Traversable Snaplet where+--  traverse f (Snaplet c r a) = Snaplet c r <$> f a+--+--instance Comonad Snaplet where+--  extract (Snaplet _ _ a) = a+--+-- #if !(MIN_VERSION_comonad(3,0,0))+-- instance Extend Snaplet where+-- #endif+--   extend f w@(Snaplet c r _) = Snaplet c r (f w)  {- ------------------------------------------------------------------------------@@ -222,6 +231,18 @@   ------------------------------------------------------------------------------+-- | Constructs a url relative to the current snaplet.+snapletURL :: (Monad (m b v), MonadSnaplet m)+           => ByteString -> m b v ByteString+snapletURL suffix = do+    cfg <- getOpaqueConfig+    return $ buildPath (cleanSuffix : _scRouteContext cfg)+  where+    dropSlash = B.dropWhile (=='/')+    cleanSuffix = B.reverse $ dropSlash $ B.reverse $ dropSlash suffix+++------------------------------------------------------------------------------ -- | Snaplet infrastructure is available during runtime request processing -- through the Handler monad.  There aren't very many standalone functions to -- read about here, but this is deceptive.  The key is in the type class@@ -322,6 +343,19 @@   ------------------------------------------------------------------------------+-- | Pass if the request is not coming from localhost.+failIfNotLocal :: MonadSnap m => m b -> m b+failIfNotLocal m = do+    -- FIXME: this moves to auth once control-panel is done+    rip <- liftM rqRemoteAddr getRequest+    if not $ elem rip [ "127.0.0.1"+                      , "localhost"+                      , "::1" ]+      then pass+      else m+++------------------------------------------------------------------------------ -- | Handler that reloads the site. reloadSite :: Handler b v () reloadSite = failIfNotLocal $ do@@ -335,14 +369,6 @@     good msg = do         writeText msg         writeText $ "Site successfully reloaded.\n"-    failIfNotLocal m = do-        -- FIXME: this moves to auth once control-panel is done-        rip <- liftM rqRemoteAddr getRequest-        if not $ elem rip [ "127.0.0.1"-                          , "localhost"-                          , "::1" ]-          then pass-          else m   ------------------------------------------------------------------------------@@ -384,6 +410,9 @@         -- whatever snaplet is currently being constructed.     , _initMessages    :: IORef Text     , _environment     :: String+    , masterReloader   :: (Snaplet b -> Snaplet b) -> IO ()+        -- ^ We can't just hae a simple MVar here because MVars can't be+        -- chrooted.     }  @@ -422,15 +451,5 @@ -- | Opaque newtype which gives us compile-time guarantees that the user is -- using makeSnaplet and either nestSnaplet or embedSnaplet correctly. newtype SnapletInit b v = SnapletInit (Initializer b v (Snaplet v))------------------------------------------------------------------------------------ | Information needed to reload a site.  Instead of having snaplets define--- their own reload actions, we store the original site initializer and use it--- instead.-data ReloadInfo b = ReloadInfo-    { riRef     :: IORef (Snaplet b)-    , riAction  :: Initializer b b b-    }  

@@ -4,8 +4,8 @@ {-# LANGUAGE OverloadedStrings          #-}  module Snap.Snaplet.Session.Backends.CookieSession-  ( initCookieSessionManager-  ) where+    ( initCookieSessionManager+    ) where  ------------------------------------------------------------------------------ import           Control.Applicative@@ -14,10 +14,10 @@ import           Data.Generics import           Data.HashMap.Strict                 (HashMap) import qualified Data.HashMap.Strict                 as HM-import           Data.Hashable                       (Hashable) import           Data.Serialize                      (Serialize) import qualified Data.Serialize                      as S import           Data.Text                           (Text)+import           Data.Text.Encoding import           Snap.Core                           (Snap) import           Web.ClientSession ------------------------------------------------------------------------------@@ -45,13 +45,20 @@  ------------------------------------------------------------------------------ instance Serialize CookieSession where-    put (CookieSession a b) = S.put (a,b)-    get                     = uncurry CookieSession <$> S.get+    put (CookieSession a b) =+        S.put (encodeUtf8 a, map encodeTuple $ HM.toList b)+    get                     =+        let unpack (a,b) = CookieSession (decodeUtf8 a)+                                         (HM.fromList $ map decodeTuple b)+        in  unpack <$> S.get -instance (Serialize k, Serialize v, Hashable k,-          Eq k) => Serialize (HashMap k v) where-    put = S.put . HM.toList-    get = HM.fromList <$> S.get++encodeTuple :: (Text, Text) -> (ByteString, ByteString)+encodeTuple (a,b) = (encodeUtf8 a, encodeUtf8 b)+++decodeTuple :: (ByteString, ByteString) -> (Text, Text)+decodeTuple (a,b) = (decodeUtf8 a, decodeUtf8 b)   ------------------------------------------------------------------------------

@@ -14,8 +14,6 @@ import           Control.Applicative import           Control.Concurrent import           Control.Monad-import           Data.Serialize-import qualified Data.Serialize as S import           Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.Text.Encoding as T@@ -58,9 +56,4 @@ mkCSRFToken :: RNG -> IO Text mkCSRFToken rng = T.decodeUtf8 <$> randomToken 40 rng ---------------------------------------------------------------------------------instance Serialize Text where-    put = S.put . T.encodeUtf8-    get = T.decodeUtf8 <$> S.get 

@@ -28,9 +28,9 @@  ------------------------------------------------------------------------------ -- | Serialize UTCTime-instance Serialize UTCTime where-    put t = put (round (utcTimeToPOSIXSeconds t) :: Integer)-    get   = posixSecondsToUTCTime . fromInteger <$> get+--instance Serialize UTCTime where+--    put t = put (round (utcTimeToPOSIXSeconds t) :: Integer)+--    get   = posixSecondsToUTCTime . fromInteger <$> get   ------------------------------------------------------------------------------@@ -54,7 +54,7 @@     case val' of       Nothing -> return Nothing       Just (ts, t) -> do-          to <- checkTimeout timeout ts+          to <- checkTimeout timeout $ posixSecondsToUTCTime $ fromInteger ts           return $ case to of             True -> Nothing             False -> Just t@@ -70,8 +70,9 @@                 -> m () setSecureCookie name key to val = do     t <- liftIO getCurrentTime+    let seconds = round (utcTimeToPOSIXSeconds t) :: Integer     let expire = to >>= Just . flip addUTCTime t . fromIntegral-    val' <- liftIO . encryptIO key . encode $ (t, val)+    val' <- liftIO . encryptIO key . encode $ (seconds, val)     let nc = Cookie name val' expire Nothing (Just "/") False True     modifyResponse $ addResponseCookie nc 

@@ -102,6 +102,7 @@            => SnapletInit b b            -> m (Either Text (Snaplet b, InitializerState b)) getSnaplet (SnapletInit initializer) = liftIO $ do-        mvar <- newEmptyMVar-        runInitializer mvar "" initializer+    mvar <- newEmptyMVar+    let resetter f = modifyMVar_ mvar (return . f)+    runInitializer resetter "" initializer 

@@ -15,12 +15,14 @@     Glob                       >= 0.5      && < 0.8,     HUnit                      >= 1.2      && < 2,     QuickCheck                 >= 2.3.0.2,-    http-conduit               >= 1.7      && < 1.9,-    http-types                 >= 0.6      && < 0.8,+    blaze-builder              >= 0.3      && < 0.4,+    http-streams               >= 0.4.0.1  && < 0.5,     process                    == 1.*,+    smallcheck                 >= 0.6      && < 0.7,     test-framework             >= 0.6      && < 0.7,     test-framework-hunit       >= 0.2.7    && < 0.3,     test-framework-quickcheck2 >= 0.2.12.1 && < 0.3,+    test-framework-smallcheck  >= 0.1      && < 0.2,     unix                       >= 2.2.0.0  && < 2.7,      MonadCatchIO-transformers  >= 0.2      && < 0.4,@@ -39,17 +41,19 @@     filepath                   >= 1.1      && < 1.4,     -- Blacklist bad versions of hashable     hashable                  (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),-    heist                      >= 0.10     && < 0.12,+    heist                      >= 0.12     && < 0.13,     logict                     >= 0.4.2    && < 0.6,     mtl                        >  2.0      && < 2.2,     mwc-random                 >= 0.8      && < 0.13,     pwstore-fast               >= 2.2      && < 2.4,     regex-posix                >= 0.95     && < 1,-    snap-core                  >= 0.9      && < 0.10,-    snap-server                >= 0.9      && < 0.10,+    snap-core                  >= 0.9      && < 0.11,+    snap-server                >= 0.9      && < 0.11,     stm                        >= 2.2      && < 2.5,     syb                        >= 0.1      && < 0.5,     text                       >= 0.11     && < 0.12,+    -- Without the tagged dependency we reach backtrack limits+    tagged                     < 0.5,     time                       >= 1.1      && < 1.5,     transformers               >= 0.2      && < 0.4,     unordered-containers       >= 0.1.4    && < 0.3,@@ -111,16 +115,18 @@     filepath                   >= 1.1      && < 1.4,     -- Blacklist bad versions of hashable     hashable                  (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),-    heist                      >= 0.10     && < 0.12,+    heist                      >= 0.12     && < 0.13,     logict                     >= 0.4.2    && < 0.6,     mtl                        >  2.0      && < 2.2,     mwc-random                 >= 0.8      && < 0.13,     pwstore-fast               >= 2.2      && < 2.4,     regex-posix                >= 0.95     && < 1,-    snap-core                  >= 0.9      && < 0.10,-    snap-server                >= 0.9      && < 0.10,+    snap-core                  >= 0.9      && < 0.11,+    snap-server                >= 0.9      && < 0.11,     stm                        >= 2.2      && < 2.5,     syb                        >= 0.1      && < 0.5,+    -- Without the tagged dependency we reach backtrack limits+    tagged                     < 0.5,     text                       >= 0.11     && < 0.12,     time                       >= 1.1      && < 1.5,     transformers               >= 0.2      && < 0.4,@@ -168,12 +174,13 @@     Glob                       >= 0.5      && < 0.8,     HUnit                      >= 1.2      && < 2,     QuickCheck                 >= 2.3.0.2,-    http-conduit               >= 1.7      && < 1.9,-    http-types                 >= 0.6      && < 0.8,+    http-streams               >= 0.4.0.1  && < 0.5,     process                    == 1.*,+    smallcheck                 >= 0.6      && < 0.7,     test-framework             >= 0.6      && < 0.7,     test-framework-hunit       >= 0.2.7    && < 0.3,     test-framework-quickcheck2 >= 0.2.12.1 && < 0.3,+    test-framework-smallcheck  >= 0.1      && < 0.2,     unix                       >= 2.2.0.0  && < 2.7,      MonadCatchIO-transformers  >= 0.2      && < 0.4,@@ -192,16 +199,18 @@     filepath                   >= 1.1      && < 1.4,     -- Blacklist bad versions of hashable     hashable                  (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),-    heist                      >= 0.10     && < 0.12,+    heist                      >= 0.12     && < 0.13,     logict                     >= 0.4.2    && < 0.6,     mtl                        >  2.0      && < 2.2,     mwc-random                 >= 0.8      && < 0.13,     pwstore-fast               >= 2.2      && < 2.4,     regex-posix                >= 0.95     && < 1,-    snap-core                  >= 0.9      && < 0.10,-    snap-server                >= 0.9      && < 0.10,+    snap-core                  >= 0.9      && < 0.11,+    snap-server                >= 0.9      && < 0.11,     stm                        >= 2.2      && < 2.5,     syb                        >= 0.1      && < 0.5,+    -- Without the tagged dependency we reach backtrack limits+    tagged                     < 0.5,     text                       >= 0.11     && < 0.12,     time                       >= 1.1      && < 1.5,     transformers               >= 0.2      && < 0.4,

@@ -15,6 +15,7 @@ import Control.Lens import Control.Monad.Trans import Data.Maybe+import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Configurator@@ -25,6 +26,7 @@ import Snap.Snaplet import Snap.Snaplet.Heist import qualified Snap.Snaplet.HeistNoClass as HNC+import Heist import Heist.Interpreted  ------------------------------------------------------------------------------@@ -51,10 +53,9 @@           initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60))     ns <- embedSnaplet "embed" embedded embeddedInit     _lens <- getLens-    addSplices-        [("appsplice", textSplice "contents of the app splice")]-    HNC.addSplices heist-        [("appconfig", shConfigSplice _lens)]+    addConfig hs $ mempty+        { hcInterpretedSplices = [("appsplice", textSplice "contents of the app splice")+                                 ,("appconfig", shConfigSplice _lens)] }     addRoutes [ ("/hello", writeText "hello world")               , ("/routeWithSplice", routeWithSplice)               , ("/routeWithConfig", routeWithConfig)

@@ -7,10 +7,12 @@ import Control.Monad.State import Data.Configurator import Data.Maybe+import Data.Monoid import qualified Data.Text as T import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Core+import Heist import Heist.Interpreted  import Blackbox.Common@@ -22,13 +24,14 @@     (Just $ return "../foosnaplet") $ do     config <- getSnapletUserConfig     addTemplates h ""-    addSplices-        [("foosplice", textSplice "contents of the foo splice")]     rootUrl <- getSnapletRootURL     fp <- getSnapletFilePath     name <- getSnapletName     _lens <- getLens-    addSplices [("fooconfig", shConfigSplice _lens)]+    addConfig h $ mempty+        { hcInterpretedSplices = [("foosplice", textSplice "contents of the foo splice")+                                 ,("fooconfig", shConfigSplice _lens)]+        }     addRoutes [("fooConfig", liftIO (lookup config "fooSnapletField") >>= writeLBS . fromJust)               ,("fooRootUrl", writeBS rootUrl)               ,("fooSnapletName", writeText $ fromMaybe "empty snaplet name" name)

@@ -8,16 +8,18 @@   ) where  ------------------------------------------------------------------------------+import           Blaze.ByteString.Builder       (Builder)+import qualified Blaze.ByteString.Builder       as Builder import           Control.Exception              (catch, throwIO) import           Control.Monad import           Control.Monad.Trans import qualified Data.ByteString.Char8          as S import qualified Data.ByteString.Lazy.Char8     as L+import           Data.Monoid import           Data.Text.Lazy                 (Text) import qualified Data.Text.Lazy                 as T import qualified Data.Text.Lazy.Encoding        as T-import qualified Network.HTTP.Conduit           as HTTP-import           Network.HTTP.Types             (Status(..))+import           Network.Http.Client import           Prelude                        hiding (catch) import           System.Directory import           System.FilePath@@ -108,8 +110,8 @@ ------------------------------------------------------------------------------ requestTest' :: String -> Text -> IO () requestTest' url desired = do-    actual <- HTTP.simpleHttp $ testServerUrl ++ url-    assertEqual url desired (T.decodeUtf8 actual)+    actual <- get (S.pack $ testServerUrl ++ url) concatHandler+    assertEqual url desired (T.decodeUtf8 $ L.fromChunks [actual])   ------------------------------------------------------------------------------@@ -122,13 +124,11 @@ requestExpectingError' :: String -> Int -> Text -> IO () requestExpectingError' url status desired = do     let fullUrl = testServerUrl ++ 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)+    get (S.pack fullUrl) $ \resp is -> do+      assertEqual ("Status code: "++fullUrl) status+                  (getStatusCode resp)+      res <- concatHandler resp is+      assertEqual fullUrl desired (T.decodeUtf8 $ L.fromChunks [res])   ------------------------------------------------------------------------------@@ -147,7 +147,8 @@  ------------------------------------------------------------------------------ grab :: MonadIO m => String -> m L.ByteString-grab path = liftIO $ HTTP.simpleHttp $ testServerUri ++ path+grab path = liftIO $ liftM (L.fromChunks . (:[])) $+  get (S.pack $ testServerUri ++ path) concatHandler   ------------------------------------------------------------------------------@@ -229,16 +230,11 @@  ------------------------------------------------------------------------------ expect404 :: String -> IO ()-expect404 url = action `catch` h-  where-    action = do-        HTTP.simpleHttp $ testServerUrl ++ url-        assertFailure "expected 404"--    h e@(HTTP.StatusCodeException (Status c _) _)-      | c == 404  = return ()-      | otherwise = throwIO e-    h e           = throwIO e+expect404 url = do+    get (S.pack $ testServerUrl ++ url) $ \resp i -> do+        case getStatusCode resp of+          404 -> return ()+          _   -> assertFailure "expected 404"   ------------------------------------------------------------------------------

@@ -11,7 +11,9 @@  sem :: QSem sem = unsafePerformIO $ newQSem 1+{-# NOINLINE sem #-} + inDir :: Bool -> FilePath -> IO a -> IO a inDir startClean dir action = bracket before after (const action)   where@@ -25,6 +27,7 @@     after cwd = do         setCurrentDirectory cwd         signalQSem sem+  removeDirectoryRecursiveSafe p =     doesDirectoryExist p >>= flip when (removeDirectoryRecursive p)

@@ -11,13 +11,16 @@ import           Control.Monad import           Control.Monad.Trans import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B import           Data.List-import           Data.Text+import           Data.Text (Text) import           Prelude hiding (catch, (.)) import           System.Directory import           Test.Framework import           Test.Framework.Providers.HUnit+import           Test.Framework.Providers.SmallCheck import           Test.HUnit hiding (Test, path)+import           Test.SmallCheck ------------------------------------------------------------------------------ import           Snap.Snaplet.Internal.Initializer import           Snap.Snaplet.Internal.Types@@ -120,5 +123,13 @@ tests :: Test tests = testGroup "Snap.Snaplet.Internal"     [ testCase "initializer tests" initTest+    , testProperty "buildPath generates no double slashes" doubleSlashes     ]++--doubleSlashes :: Monad m => [String] -> Property m+doubleSlashes arrStr = noSlashes ==> not (B.isInfixOf "//" $ buildPath arr)+  where+    arr = map B.pack arrStr+    noSlashes = not $ or $ map (B.elem '/') arr+ 

@@ -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.Conduit    as HTTP+import           Network.Http.Client import           Prelude hiding (catch) import           Snap.Http.Server.Config import           Snap.Snaplet@@ -102,12 +102,12 @@   where     go = testGeneratedProject "barebonesTest"                               "barebones"-                              ""+                              "--force-reinstalls"                               port                               testIt     port = 9990 :: Int     testIt = do-        body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)+        body <- get (S.pack $ "http://127.0.0.1:"++(show port)) concatHandler         assertEqual "server not up" "hello world" body  @@ -117,13 +117,12 @@   where     go = testGeneratedProject "defaultTest"                               ""-                              ""+                              "--force-reinstalls"                               port                               testIt     port = 9991 :: Int     testIt = do-        body <- liftM (S.concat . L.toChunks) $-                HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)+        body <- get (S.pack $ "http://127.0.0.1:"++(show port)) concatHandler         assertBool "response contains phrase 'Snap Example App Login'"                    $ "Snap Example App Login" `S.isInfixOf` body @@ -134,12 +133,12 @@   where     go = testGeneratedProject "tutorialTest"                               "tutorial"-                              ""+                              "--force-reinstalls"                               port                               testIt     port = 9992 :: Int     testIt = do-        body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)++"/hello"+        body <- get (S.pack $ "http://127.0.0.1:"++(show port)++"/hello") concatHandler         assertEqual "server not up" "hello world" body