snap 0.5.5.1 → 0.6.0

raw patch · 60 files changed

+5257/−1747 lines, 60 filesdep +Cryptodep +aesondep +clientsessiondep −blaze-builderdep −bytestring-numsdep −dlistdep ~MonadCatchIO-transformersdep ~attoparsecdep ~bytestringnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: Crypto, aeson, clientsession, configurator, data-lens, data-lens-template, hashable, logict, mwc-random, pwstore-fast, safe, stm, syb, transformers, unordered-containers, utf8-string, vector, vector-algorithms, xmlhtml

Dependencies removed: blaze-builder, bytestring-nums, dlist, enumerator, old-locale, unix-compat, zlib

Dependency ranges changed: MonadCatchIO-transformers, attoparsec, bytestring, containers, directory-tree, heist, mtl, old-time, snap-core, snap-server, template-haskell, time

API changes (from Hackage documentation)

Files

• CONTRIBUTORS +2/−4
• README.SNAP.md +5/−5
• README.md +18/−18
• project_template/barebones/foo.cabal +2/−2
• project_template/barebones/src/Main.hs +1/−1
• project_template/default/foo.cabal +6/−7
• project_template/default/resources/templates/index.tpl +1/−1
• project_template/default/src/Application.hs +16/−45
• project_template/default/src/Main.hs +64/−23
• project_template/default/src/Site.hs +48/−13
• project_template/default/src/Snap/Extension/Timer.hs +0/−53
• project_template/default/src/Snap/Extension/Timer/Impl.hs +0/−67
• snap.cabal +89/−52
• src/Data/RBAC/Checker.hs +223/−0
• src/Data/RBAC/Internal/Role.hs +81/−0
• src/Data/RBAC/Internal/RoleMap.hs +58/−0
• src/Data/RBAC/Internal/Rule.hs +31/−0
• src/Data/RBAC/Internal/Types.hs +33/−0
• src/Data/RBAC/Role.hs +24/−0
• src/Data/RBAC/Types.hs +14/−0
• src/Snap.hs +26/−0
• src/Snap/Extension.hs +0/−500
• src/Snap/Extension/Heist.hs +0/−79
• src/Snap/Extension/Heist/Impl.hs +0/−219
• src/Snap/Extension/Loader/Devel.hs +0/−176
• src/Snap/Extension/Loader/Devel/Evaluator.hs +0/−145
• src/Snap/Extension/Loader/Devel/Signal.hs +0/−43
• src/Snap/Extension/Loader/Devel/TreeWatcher.hs +0/−41
• src/Snap/Extension/Server.hs +0/−138
• src/Snap/Loader/Devel.hs +180/−0
• src/Snap/Loader/Devel/Evaluator.hs +144/−0
• src/Snap/Loader/Devel/Signal.hs +43/−0
• src/Snap/Loader/Devel/TreeWatcher.hs +41/−0
• src/Snap/Loader/Prod.hs +25/−0
• src/Snap/Snaplet.hs +330/−0
• src/Snap/Snaplet/Auth.hs +74/−0
• src/Snap/Snaplet/Auth/AuthManager.hs +102/−0
• src/Snap/Snaplet/Auth/Backends/JsonFile.hs +335/−0
• src/Snap/Snaplet/Auth/Handlers.hs +437/−0
• src/Snap/Snaplet/Auth/SpliceHelpers.hs +75/−0
• src/Snap/Snaplet/Auth/Types.hs +175/−0
• src/Snap/Snaplet/Heist.hs +201/−0
• src/Snap/Snaplet/HeistNoClass.hs +384/−0
• src/Snap/Snaplet/Internal/Initializer.hs +489/−0
• src/Snap/Snaplet/Internal/LensT.hs +105/−0
• src/Snap/Snaplet/Internal/Lensed.hs +151/−0
• src/Snap/Snaplet/Internal/RST.hs +109/−0
• src/Snap/Snaplet/Internal/Types.hs +340/−0
• src/Snap/Snaplet/Session.hs +107/−0
• src/Snap/Snaplet/Session/Backends/CookieSession.hs +160/−0
• src/Snap/Snaplet/Session/Common.hs +41/−0
• src/Snap/Snaplet/Session/SecureCookie.hs +96/−0
• src/Snap/Snaplet/Session/SessionManager.hs +49/−0
• src/Snap/Starter.hs +51/−28
• src/Snap/StarterTH.hs +5/−5
• test/runTests.sh +0/−21
• test/runTestsAndCoverage.sh +62/−0
• test/snap-testsuite.cabal +98/−14
• test/suite/Snap/TestCommon.hs +37/−40
• test/suite/TestSuite.hs +69/−7

@@ -1,8 +1,6 @@ Ozgun Ataman <ozataman@gmail.com> Doug Beardsley <mightybyte@gmail.com> Gregory Collins <greg@gregorycollins.net>-Shu-yu Guo <shu@rfrn.org> Carl Howells <chowells79@gmail.com>-Shane O'Brien <shane@duairc.com>-James Sanders <jimmyjazz14@gmail.com>-Jacob Stanley <jystic@jystic.com>+Chris Smith <cdsmith@gmail.com>+Jurriën Stutterheim <j.stutterheim@me.com>

@@ -16,11 +16,11 @@    * a sensible and clean monad for web programming -  * an xml-based templating system for generating HTML based on-    [expat](http://expat.sourceforge.net/) (via-    [hexpat](http://hackage.haskell.org/package/hexpat)) that allows you to-    bind Haskell functionality to XML tags without getting PHP-style tag soup-    all over your pants+  * an xml-based templating system for generating HTML that allows you to bind+    Haskell functionality to XML tags without getting PHP-style tag soup all+    over your pants++  * a "snaplet" system for building web sites from composable pieces.  Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows.

@@ -1,18 +1,14 @@ Snap Framework ============== -This is the first developer prerelease of the Snap Framework snap-tool.  For more information about Snap, read the `README.SNAP.md` or-visit the Snap project website at http://www.snapframework.com/.--Snap is a nascent web framework for Haskell, based on iteratee I/O (as-[popularized by Oleg-Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)).-+Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by+Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)).  For more+information about Snap, read the `README.SNAP.md` or visit the Snap project+website at http://www.snapframework.com/.  ## Library contents -This is the `snap` executable and supporting library, which contains:+This is top-level project for the Snap Framework, which contains:    * a command-line utility for creating initial Snap applications @@ -20,12 +16,14 @@     fly in development mode, with no performance loss in production     mode. +  * a "snaplet" API allowing web applications to be build from composable+    pieces.  Building snap =============  The snap tool and library are built using- [Cabal](http://www.haskell.org/cabal/) and+[Cabal](http://www.haskell.org/cabal/) and [Hackage](http://hackage.haskell.org/packages/hackage.html). Just run      cabal install@@ -35,20 +33,13 @@  ## Building the Haddock Documentation -The haddock documentation can be built using the supplied `haddock.sh` shell-script:--    ./haddock.sh+The haddock documentation can be built using 'cabal haddock'.  The docs get put in `dist/doc/html/`.   ## Building the testsuite -Snap is still in its very early stages, so most of the "action" (and a big-chunk of the code) right now is centred on the test suite. Snap aims for 100%-test coverage, and we're trying hard to stick to that.- To build the test suite, `cd` into the `test/` directory and run      $ cabal configure@@ -60,3 +51,12 @@   The testsuite generates an `hpc` test coverage report in `test/dist/hpc`.+++## Roadmap to Understanding Snaplets++1. Read Tutorial.lhs which is in `project_template/tutorial/src`.+2. Generate and read the haddock docs.+3. The test code has the nice property that it actually functions as a pretty good example app and covers a lot of the use cases.+4. If you're interested in the implementation, read design.md.+

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

@@ -2,7 +2,7 @@ module Main where  import           Control.Applicative-import           Snap.Types+import           Snap.Core import           Snap.Util.FileServe import           Snap.Http.Server 

@@ -21,21 +21,20 @@   Build-depends:     base >= 4 && < 5,     bytestring >= 0.9.1 && < 0.10,-    heist >= 0.5 && < 0.6,+    data-lens >= 2.0.1 && < 2.1,+    data-lens-template >= 2.1 && < 2.2,+    heist >= 0.6 && < 0.7,     MonadCatchIO-transformers >= 0.2.1 && < 0.3,     mtl >= 2 && < 3,-    snap == 0.5.*,-    snap-core == 0.5.*,-    snap-server == 0.5.*,+    snap == 0.6.*,+    snap-core   == 0.6.*,+    snap-server == 0.6.*,     text >= 0.11 && < 0.12,     time >= 1.1 && < 1.4,     xmlhtml == 0.1.* -  extensions: TypeSynonymInstances MultiParamTypeClasses-   if flag(development)     cpp-options: -DDEVELOPMENT-    build-depends: hint >= 0.3.2 && < 0.4     -- In development mode, speed is already going to suffer, so skip     -- the fancy optimization flags.  Additionally, disable all     -- warnings.  The hint library doesn't give an option to execute

@@ -1,7 +1,7 @@ <html>   <head>     <title>Snap web server</title>-    <link rel="stylesheet" type="text/css" href="screen.css"/>+    <link rel="stylesheet" type="text/css" href="/screen.css"/>   </head>   <body>     <div id="content">

@@ -1,58 +1,29 @@+{-# LANGUAGE TemplateHaskell #-}+ {- -This module defines our application's monad and any application-specific-information it requires.+This module defines our application's state type and an alias for its handler+monad.  -} -module Application-  ( Application-  , applicationInitializer-  ) where--import           Snap.Extension-import           Snap.Extension.Heist.Impl-import           Snap.Extension.Timer.Impl-+module Application where ---------------------------------------------------------------------------------- | 'Application' is our application's monad. It uses 'SnapExtend' from--- 'Snap.Extension' to provide us with an extended 'MonadSnap' making use of--- the Heist and Timer Snap extensions.-type Application = SnapExtend ApplicationState+import Data.Lens.Template+import Data.Time.Clock +import Snap.Snaplet+import Snap.Snaplet.Heist ---------------------------------------------------------------------------------- | 'ApplicationState' is a record which contains the state needed by the Snap--- extensions we're using.  We're using Heist so we can easily render Heist--- templates, and Timer simply to illustrate the config loading differences--- between development and production modes.-data ApplicationState = ApplicationState-    { templateState :: HeistState Application-    , timerState    :: TimerState+data App = App+    { _heist :: Snaplet (Heist App)+    , _startTime :: UTCTime     } ---------------------------------------------------------------------------------instance HasHeistState Application ApplicationState where-    getHeistState     = templateState-    setHeistState s a = a { templateState = s }-+type AppHandler = Handler App App --------------------------------------------------------------------------------instance HasTimerState ApplicationState where-    getTimerState     = timerState-    setTimerState s a = a { timerState = s }+makeLens ''App +instance HasHeist App where+    heistLens = subSnaplet heist ---------------------------------------------------------------------------------- | The 'Initializer' for ApplicationState. For more on 'Initializer's, see--- the documentation from the snap package. Briefly, this is used to--- generate the 'ApplicationState' needed for our application and will--- automatically generate reload\/cleanup actions for us which we don't need--- to worry about.-applicationInitializer :: Initializer ApplicationState-applicationInitializer = do-    heist <- heistInitializer "resources/templates" id-    timer <- timerInitializer-    return $ ApplicationState heist timer

@@ -1,6 +1,27 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} +module Main where++import           Control.Exception (SomeException, try)++import qualified Data.Text as T++import           Snap.Http.Server+import           Snap.Snaplet+import           Snap.Core++import           System.IO++import           Site++#ifdef DEVELOPMENT+import           Snap.Loader.Devel+#else+import           Snap.Loader.Prod+#endif++ {-|  This is the entry point for this web server application.  It supports@@ -38,31 +59,51 @@ change.  -}+main :: IO ()+main = do+    -- depending on the version of loadSnapTH in scope, this either+    -- enables dynamic reloading, or compiles it without.  The last+    -- argument to loadSnapTH is a list of additional directories to+    -- watch for changes to trigger reloads in development mode.  It+    -- doesn't need to include source directories, those are picked up+    -- automatically by the splice.+    (conf, site, cleanup) <- $(loadSnapTH [| getConf |]+                                          'getActions+                                          ["resources/templates"]) -module Main where+    _ <- try $ httpServe conf $ site :: IO (Either SomeException ())+    cleanup -#ifdef DEVELOPMENT-import           Control.Exception (SomeException, try) -import           Snap.Extension.Loader.Devel-import           Snap.Http.Server (quickHttpServe)-#else-import           Snap.Extension.Server-#endif+-- | This action loads the config used by this application.  The+-- loaded config is returned as the first element of the tuple+-- produced by the loadSnapTH Splice.  The type is not solidly fixed,+-- though it must be an IO action that produces the same type as+-- 'getActions' takes.  It also must be an instance of Typeable.  If+-- the type of this is changed, a full recompile will be needed to+-- pick up the change, even in development mode.+--+-- This action is only run once, regardless of whether development or+-- production mode is in use.+getConf :: IO (Config Snap ())+getConf = commandLineConfig defaultConfig -import           Application-import           Site -main :: IO ()-#ifdef DEVELOPMENT-main = do-    -- All source directories will be watched for updates-    -- automatically.  If any extra directories should be watched for-    -- updates, include them here.-    (snap, cleanup) <- $(let watchDirs = ["resources/templates"]-                         in loadSnapTH 'applicationInitializer 'site watchDirs)-    try $ quickHttpServe snap :: IO (Either SomeException ())-    cleanup-#else-main = quickHttpServe applicationInitializer site-#endif+-- | This function generates the the site handler and cleanup action+-- from the configuration.  In production mode, this action is only+-- run once.  In development mode, this action is run whenever the+-- application is reloaded.+--+-- Development mode also makes sure that the cleanup actions are run+-- appropriately before shutdown.  The cleanup action returned from+-- loadSnapTH should still be used after the server has stopped+-- handling requests, as the cleanup actions are only automatically+-- run when a reload is triggered.+--+-- This sample doesn't actually use the config passed in, but more+-- sophisticated code might.+getActions :: Config Snap () -> IO (Snap (), IO ())+getActions _ = do+    (msgs, site, cleanup) <- runSnaplet app+    hPutStrLn stderr $ T.unpack msgs+    return (site, cleanup)

@@ -3,22 +3,29 @@ {-|  This is where all the routes and handlers are defined for your site. The-'site' function combines everything together and is exported by this module.+'app' function is the initializer that combines everything together and+is exported by this module.  -}  module Site-  ( site+  ( app   ) where  import           Control.Applicative+import           Control.Monad.Trans+import           Control.Monad.State+import           Data.ByteString (ByteString) import           Data.Maybe+import qualified Data.Text as T import qualified Data.Text.Encoding as T-import           Snap.Extension.Heist-import           Snap.Extension.Timer+import           Data.Time.Clock+import           Snap.Core+import           Snap.Snaplet+import           Snap.Snaplet.Heist import           Snap.Util.FileServe-import           Snap.Types import           Text.Templating.Heist+import           Text.XmlHtml hiding (render)  import           Application @@ -29,7 +36,7 @@ -- The 'ifTop' is required to limit this to the top of a route. -- Otherwise, the way the route table is currently set up, this action -- would be given every request.-index :: Application ()+index :: Handler App App () index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"   where     indexSplices =@@ -39,8 +46,24 @@   ------------------------------------------------------------------------------+-- | For your convenience, a splice which shows the start time.+startTimeSplice :: Splice AppHandler+startTimeSplice = do+    time <- lift $ gets _startTime+    return $ [TextNode $ T.pack $ show $ time]+++------------------------------------------------------------------------------+-- | For your convenience, a splice which shows the current time.+currentTimeSplice :: Splice AppHandler+currentTimeSplice = do+    time <- liftIO getCurrentTime+    return $ [TextNode $ T.pack $ show $ time]+++------------------------------------------------------------------------------ -- | Renders the echo page.-echo :: Application ()+echo :: Handler App App () echo = do     message <- decodedParam "stuff"     heistLocal (bindString "message" (T.decodeUtf8 message)) $ render "echo"@@ -49,9 +72,21 @@   --------------------------------------------------------------------------------- | The main entry point handler.-site :: Application ()-site = route [ ("/",            index)-             , ("/echo/:stuff", echo)-             ]-       <|> serveDirectory "resources/static"+-- | The application's routes.+routes :: [(ByteString, Handler App App ())]+routes = [ ("/",            index)+         , ("/echo/:stuff", echo)+         , ("", with heist heistServe)+         , ("", serveDirectory "resources/static")+         ]++------------------------------------------------------------------------------+-- | The application initializer.+app :: SnapletInit App App+app = makeSnaplet "app" "An snaplet example application." Nothing $ do+    sTime <- liftIO getCurrentTime+    h <- nestSnaplet "heist" heist $ heistInit "resources/templates"+    addRoutes routes+    return $ App h sTime++

@@ -1,53 +0,0 @@-{-|--'Snap.Extension.Timer' exports the 'MonadTimer' interface which allows you to-keep track of the time at which your application was started. The interface's-only operation is 'startTime'.--Two splices, 'startTimeSplice' and 'currentTimeSplice' are also provided, for-your convenience.--'Snap.Extension.Timer.Timer' contains the only implementation of this-interface and can be used to turn your application's monad into a-'MonadTimer'.--More than anything else, this is intended to serve as an example Snap-Extension to any developer wishing to write their own Snap Extension.---}--module Snap.Extension.Timer-  ( MonadTimer(..)-  , startTimeSplice-  , currentTimeSplice-  ) where--import           Control.Monad.Trans-import           Data.Time.Clock-import qualified Data.Text as T-import           Snap.Types-import           Text.Templating.Heist-import           Text.XmlHtml------------------------------------------------------------------------------------ | The 'MonadTimer' type class. Minimal complete definition: 'startTime'.-class MonadSnap m => MonadTimer m where-    -- | The time at which your application was last loaded.-    startTime :: m UTCTime------------------------------------------------------------------------------------ | For your convenience, a splice which shows the start time.-startTimeSplice :: MonadTimer m => Splice m-startTimeSplice = do-    time <- lift startTime-    return $ [TextNode $ T.pack $ show $ time]------------------------------------------------------------------------------------ | For your convenience, a splice which shows the current time.-currentTimeSplice :: MonadTimer m => Splice m-currentTimeSplice = do-    time <- lift $ liftIO getCurrentTime-    return $ [TextNode $ T.pack $ show $ time]

@@ -1,67 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-|--'Snap.Extension.Timer.Impl' is an implementation of the 'MonadTimer'-interface defined in 'Snap.Extension.Timer'.--As always, to use, add 'TimerState' to your application's state, along with an-instance of 'HasTimerState' for your application's state, making sure to use a-'timerInitializer' in your application's 'Initializer', and then you're ready to go.--This implementation does not require that your application's monad implement-interfaces from any other Snap Extension.---}--module Snap.Extension.Timer.Impl-  ( TimerState-  , HasTimerState(..)-  , timerInitializer-  , module Snap.Extension.Timer-  ) where--import           Control.Monad.Reader-import           Data.Time.Clock-import           Snap.Extension-import           Snap.Extension.Timer-import           Snap.Types----------------------------------------------------------------------------------- | Your application's state must include a 'TimerState' in order for your--- application to be a 'MonadTimer'.-newtype TimerState = TimerState-    { _startTime :: UTCTime-    }------------------------------------------------------------------------------------ | For your application's monad to be a 'MonadTimer', your application's--- state needs to be an instance of 'HasTimerState'. Minimal complete--- definition: 'getTimerState', 'setTimerState'.-class HasTimerState s where-    getTimerState :: s -> TimerState-    setTimerState :: TimerState -> s -> s------------------------------------------------------------------------------------ | The Initializer for 'TimerState'. No arguments are required.-timerInitializer :: Initializer TimerState-timerInitializer = liftIO getCurrentTime >>= mkInitializer . TimerState----------------------------------------------------------------------------------instance InitializerState TimerState where-    extensionId = const "Timer/Timer"-    mkCleanup   = const $ return ()-    mkReload    = const $ return ()----------------------------------------------------------------------------------instance HasTimerState s => MonadTimer (SnapExtend s) where-    startTime = fmap _startTime $ asks getTimerState----------------------------------------------------------------------------------instance (MonadSnap m, HasTimerState s) => MonadTimer (ReaderT s m) where-    startTime = fmap _startTime $ asks getTimerState

@@ -1,13 +1,13 @@ name:           snap-version:        0.5.5.1+version:        0.6.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 license-file:   LICENSE-author:         James Sanders, Shu-yu Guo, Gregory Collins, Doug Beardsley+author:         Ozgun Ataman, Doug Beardsley, Gregory Collins, Carl Howells, Chris Smith maintainer:     snap@snapframework.com build-type:     Simple-cabal-version:  >= 1.6+cabal-version:  >= 1.8 homepage:       http://snapframework.com/ category:       Web @@ -27,58 +27,106 @@   project_template/default/src/Application.hs,   project_template/default/src/Main.hs,   project_template/default/src/Site.hs,-  project_template/default/src/Snap/Extension/Timer/Impl.hs,-  project_template/default/src/Snap/Extension/Timer.hs,   extra/hscolour.css,   extra/haddock.css,   extra/logo.gif,   test/snap-testsuite.cabal,-  test/runTests.sh,+  test/runTestsAndCoverage.sh,   test/suite/Snap/TestCommon.hs,   test/suite/TestSuite.hs  Flag hint   Description: Support dynamic project reloading via hint-  Default: True+  Default: False  Library   hs-source-dirs: src -  exposed-modules:-    Snap.Extension.Heist,-    Snap.Extension.Heist.Impl,-    Snap.Extension.Server,-    Snap.Extension-   if flag(hint)     exposed-modules:-      Snap.Extension.Loader.Devel+      Snap.Loader.Devel -    other-modules:-      Snap.Extension.Loader.Devel.Evaluator,-      Snap.Extension.Loader.Devel.Signal,-      Snap.Extension.Loader.Devel.TreeWatcher+  exposed-modules:+    Snap,+    Snap.Loader.Prod+    Snap.Snaplet,+    Snap.Snaplet.Heist,+    Snap.Snaplet.Auth,+    Snap.Snaplet.Auth.Backends.JsonFile,+    Snap.Snaplet.Session,+    Snap.Snaplet.Session.Backends.CookieSession +  other-modules:+    Data.RBAC.Checker,+    Data.RBAC.Role,+    Data.RBAC.Types,+    Data.RBAC.Internal.Role,+    Data.RBAC.Internal.RoleMap,+    Data.RBAC.Internal.Rule,+    Data.RBAC.Internal.Types,+    Snap.Loader.Devel.Evaluator,+    Snap.Loader.Devel.Signal,+    Snap.Loader.Devel.TreeWatcher,+    Snap.Snaplet.Auth.AuthManager,+    Snap.Snaplet.Auth.Types,+    Snap.Snaplet.Auth.Handlers,+    Snap.Snaplet.Auth.SpliceHelpers,+    Snap.Snaplet.HeistNoClass,+    Snap.Snaplet.Internal.Initializer,+    Snap.Snaplet.Internal.LensT,+    Snap.Snaplet.Internal.Lensed,+    Snap.Snaplet.Internal.RST,+    Snap.Snaplet.Internal.Types+    Snap.Snaplet.Session.Common,+    Snap.Snaplet.Session.SecureCookie,+    Snap.Snaplet.Session.SessionManager+   build-depends:-    base                      >= 4 && < 5,-    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.13.1 && <0.5,-    filepath                  >= 1.1 && <1.3,-    MonadCatchIO-transformers >= 0.2.1 && < 0.3,-    snap-core                 >= 0.5.4 && <0.6,-    heist                     >= 0.5 && < 0.6,-    template-haskell          >= 2.3 && < 2.7,-    time                      >= 1.0 && < 1.4+    Crypto                    >= 4.2     && < 4.3,+    MonadCatchIO-transformers >= 0.2     && < 0.3,+    aeson                     >= 0.3.2   && < 0.4,+    attoparsec                (>= 0.8.0.2 && < 0.9) ||+                              (>= 0.9.1.1 && < 0.10),+    base                      >= 4       && < 5,+    bytestring                >= 0.9.1   && < 0.10,+    cereal                    >= 0.3     && < 0.4,+    clientsession             >= 0.7.2   && < 0.8,+    configurator              >= 0.1     && < 0.2,+    containers                >= 0.3     && < 0.5,+    directory                 >= 1.0     && < 1.2,+    directory-tree            >= 0.10    && < 0.11,+    data-lens                 >= 2.0.1   && < 2.1,+    data-lens-template        >= 2.1     && < 2.2,+    filepath                  >= 1.1     && < 1.3,+    hashable                  >= 1.1     && < 1.2,+    heist                     >= 0.6     && < 0.7,+    logict                    >= 0.4.2   && < 0.6,+    mtl                       >  2.0     && < 2.1,+    mwc-random                >= 0.8     && < 0.11,+    old-time                  >= 1.0     && < 1.1,+    pwstore-fast              >= 2.2     && < 2.3,+    safe                      >= 0.3     && < 0.4,+    snap-core                 >= 0.6     && < 0.7,+    snap-server               >= 0.6     && < 0.7,+    stm                       >= 2.2     && < 2.3,+    syb                       >= 0.1     && < 0.4,+    template-haskell          >= 2.2     && < 2.7,+    text                      >= 0.11    && < 0.12,+    time                      >= 1.1     && < 1.5,+    transformers              >= 0.2     && < 0.3,+    unordered-containers      >= 0.1.4   && < 0.2,+    utf8-string               >= 0.3     && < 0.4,+    vector                    >= 0.7.1   && < 0.10,+    vector-algorithms         >= 0.4     && < 0.6,+    xmlhtml                   >= 0.1     && < 0.2    if flag(hint)     build-depends:       hint                    >= 0.3.3.1 && < 0.4    if !os(windows)-    build-depends:    unix >= 2.2.0.0 && < 2.6+    build-depends:+      unix                    >= 2.2.0.0 && < 2.6    if impl(ghc >= 6.12.0)     ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2@@ -94,27 +142,16 @@   other-modules: Snap.StarterTH    build-depends:-    attoparsec       >= 0.8.0.2 && < 0.10,-    base             >= 4   && < 5,-    bytestring,-    bytestring-nums,-    cereal           >= 0.3 && < 0.4,-    containers,-    directory        >= 1.0 && < 1.2,-    directory-tree,-    dlist            >= 0.5 && < 0.6,-    enumerator       >= 0.4.13.1 && <0.5,-    filepath         >= 1.1 && <1.3,-    mtl              >= 2,-    old-locale,-    old-time,-    snap-core        >= 0.5.4 && <0.6,-    snap-server      >= 0.5.4 && <0.6,-    template-haskell >= 2.3 && < 2.7,-    text             >= 0.11 && <0.12,-    time             >= 1.0 && < 1.4,-    unix-compat,-    zlib+    base                >= 4       && < 5,+    bytestring          >= 0.9.1   && < 0.10,+    containers          >= 0.3     && < 0.5,+    directory           >= 1.0     && < 1.2,+    directory-tree      >= 0.10    && < 0.11,+    filepath            >= 1.1     && < 1.3,+    old-time            >= 1.0     && < 1.1,+    snap-server         >= 0.6     && < 0.7,+    template-haskell    >= 2.2     && < 2.7,+    text                >= 0.11    && < 0.12    ghc-prof-options: -prof -auto-all 

@@ -0,0 +1,223 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.RBAC.Checker where++import           Control.Monad+import           Control.Monad.Logic+import           Control.Monad.Reader+import           Control.Monad.State.Lazy+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as M+import           Data.Maybe (fromMaybe, isJust)+import           Data.Text (Text)++import           Data.RBAC.Internal.RoleMap (RoleMap)+import qualified Data.RBAC.Internal.RoleMap as RM+import           Data.RBAC.Internal.Types+import           Data.RBAC.Role+++------------------------------------------------------------------------------+type RoleBuilder a = StateT RoleMap RoleMonad a+++------------------------------------------------------------------------------+applyRule :: Role -> Rule -> [Role]+applyRule r (Rule _ f) = f r+++------------------------------------------------------------------------------+applyRuleSet :: Role -> RuleSet -> [Role]+applyRuleSet r (RuleSet m) = f r+  where+    f = fromMaybe (const []) $ M.lookup (_roleName r) m+++------------------------------------------------------------------------------+checkUnseen :: Role -> RoleBuilder ()+checkUnseen role = do+    m <- get+    if isJust $ RM.lookup role m then mzero else return ()+++------------------------------------------------------------------------------+checkSeen :: Role -> RoleBuilder ()+checkSeen = lnot . checkUnseen+++------------------------------------------------------------------------------+markSeen :: Role -> RoleBuilder ()+markSeen role = modify $ RM.insert role+++------------------------------------------------------------------------------+isum :: (MonadLogic m, MonadPlus m) => [m a] -> m a+isum l = case l of+            []     -> mzero+            (x:xs) -> x `interleave` isum xs+++------------------------------------------------------------------------------+-- | Given a set of roles to check, and a set of implication rules describing+-- how a given role inherits from other roles, this function produces a stream+-- of expanded Roles. If a Role is seen twice, expandRoles mzeros.+expandRoles :: [Rule] -> [Role] -> RoleMonad Role+expandRoles rules roles0 = evalStateT (go roles0) RM.empty+  where+    ruleSet = rulesToSet rules++    go roles = isum $ map expandOne roles++    expandOne role = do+        checkUnseen role+        markSeen role+        return role `interleave` go newRoles++      where+        newRoles = applyRuleSet role ruleSet+++------------------------------------------------------------------------------+hasRole :: Role -> RuleChecker ()+hasRole r = RuleChecker $ do+    ch <- ask+    once $ go ch+  where+    go gen = do+        r' <- lift gen+        if r `matches` r' then return () else mzero+++------------------------------------------------------------------------------+missingRole :: Role -> RuleChecker ()+missingRole = lnot . hasRole+++------------------------------------------------------------------------------+hasAllRoles :: [Role] -> RuleChecker ()+hasAllRoles rs = RuleChecker $ do+    ch <- ask+    lift $ once $ go ch $ RM.fromList rs+  where+    go gen !st = do+        mr <- msplit gen+        maybe mzero+              (\(r,gen') -> let st' = RM.delete r st+                            in if RM.null st'+                                 then return ()+                                 else go gen' st')+              mr+++------------------------------------------------------------------------------+hasAnyRoles :: [Role] -> RuleChecker ()+hasAnyRoles rs = RuleChecker $ do+    ch <- ask+    lift $ once $ go ch+  where+    st = RM.fromList rs+    go gen = do+        mr <- msplit gen+        maybe mzero+              (\(r,gen') -> if isJust $ RM.lookup r st+                                 then return ()+                                 else go gen')+              mr+++------------------------------------------------------------------------------+runRuleChecker :: [Rule]+               -> [Role]+               -> RuleChecker a+               -> Bool+runRuleChecker rules roles (RuleChecker f) =+    case outs of+      []    -> False+      _     -> True+  where+    (RoleMonad st) = runReaderT f $ expandRoles rules roles+    outs = observeMany 1 st+++------------------------------------------------------------------------------+mkRule :: Text -> (Role -> [Role]) -> Rule+mkRule = Rule+++------------------------------------------------------------------------------+implies :: Role -> [Role] -> Rule+implies src dest = Rule (_roleName src)+                        (\role -> if role `matches` src then dest else [])+++------------------------------------------------------------------------------+impliesWith :: Role -> (HashMap Text RoleValue -> [Role]) -> Rule+impliesWith src f = Rule (_roleName src)+                         (\role -> if src `matches` role+                                     then f $ _roleData role+                                     else [])+++------------------------------------------------------------------------------+-- Testing code follows: TODO: move into test suite+++testRules :: [Rule]+testRules = [ "user" `implies` ["guest", "can_post"]+            , "superuser" `implies` [ "user"+                                    , "can_moderate"+                                    , "can_administrate"]+            , "superuser" `implies` [ addRoleData "arg" "*" "with_arg" ]+            , "with_arg" `impliesWith` \dat ->+                maybe [] (\arg -> [addRoleData "arg" arg "dependent_arg"]) $+                      M.lookup "arg" dat+            , "superuser" `implies` [ addRoleData "arg1" "a" $+                                      addRoleData "arg2" "b" "multi_args" ]+            ]++tX :: RuleChecker () -> Bool+tX f = runRuleChecker testRules ["superuser"] f++t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17 :: Bool+t1 = tX $ hasAnyRoles ["guest","userz"]++t2 = tX $ hasAllRoles ["guest","userz"]++t3 = tX $ hasAllRoles ["guest","user"]++t4 = tX $ hasRole "can_administrate"++t5 = tX $ hasRole "lkfdhjkjfhds"++t6 = tX $ do+         hasRole "guest"+         hasRole "superuser"++t7 = tX $ do+         hasRole "zzzzz"+         hasRole "superuser"++t8 = tX $ hasRole $ addRoleData "arg" "*" "dependent_arg"++t9 = tX $ hasRole "multi_args"++t10 = tX $ hasRole $ addRoleData "arg2" "b" "multi_args"++t11 = tX $ hasRole $ addRoleData "arg2" "z" "multi_args"++t12 = tX $ hasAllRoles [addRoleData "arg2" "b" "multi_args"]++t13 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"+                       , addRoleData "arg2" "b" "multi_args" ]++t14 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args"+                       , addRoleData "arg2" "aaa" "multi_args" ]++t15 = tX $ missingRole "jflsdkjf"++t16 = tX $ do+          missingRole "fdjlksjlf"+          hasRole "multi_args"++t17 = tX $ missingRole "multi_args"

@@ -0,0 +1,81 @@+module Data.RBAC.Internal.Role where++import           Control.Monad.ST+import           Data.Hashable+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as M+import           Data.String+import           Data.Text (Text)+import qualified Data.Vector as V+import qualified Data.Vector.Algorithms.Merge as VA+++------------------------------------------------------------------------------+data RoleValue = RoleBool Bool+               | RoleText Text+               | RoleInt Int+               | RoleDouble Double+  deriving (Ord, Eq, Show)+++instance IsString RoleValue where+    fromString = RoleText . fromString+++instance Hashable RoleValue where+    hashWithSalt salt (RoleBool e)   = hashWithSalt salt e `combine` 7+    hashWithSalt salt (RoleText t)   = hashWithSalt salt t `combine` 196613+    hashWithSalt salt (RoleInt i)    = hashWithSalt salt i `combine` 12582917+    hashWithSalt salt (RoleDouble d) =+        hashWithSalt salt d `combine` 1610612741+++------------------------------------------------------------------------------+data Role = Role {+      _roleName :: Text+    , _roleData :: HashMap Text RoleValue+    }+  deriving (Eq, Show)+++instance IsString Role where+    fromString s = Role (fromString s) M.empty+++------------------------------------------------------------------------------+toSortedList :: (Ord k, Ord v) => HashMap k v -> [(k,v)]+toSortedList m = runST $ do+    v <- V.unsafeThaw $ V.fromList $ M.toList m+    VA.sort v+    v' <- V.unsafeFreeze v+    return $ V.toList v'++++instance Hashable Role where+    hashWithSalt salt (Role nm dat) =+        h $ hashWithSalt salt nm+      where+        h s = hashWithSalt s $ toSortedList dat+++------------------------------------------------------------------------------+data RoleValueMeta = RoleBoolMeta+                   | RoleTextMeta+                   | RoleEnumMeta [Text]+                   | RoleIntMeta+                   | RoleDoubleMeta+++data RoleDataDefinition = RoleDataDefinition {+      _roleDataName        :: Text+    , _roleValueMeta       :: RoleValueMeta+    , _roleDataDescription :: Text+    }+++data RoleMetadata = RoleMetadata {+      _roleMetadataName :: Text+    , _roleDescription  :: Text+    , _roleDataDefs     :: [RoleDataDefinition]+    }

@@ -0,0 +1,58 @@+module Data.RBAC.Internal.RoleMap where++import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as M+import           Data.HashSet (HashSet)+import qualified Data.HashSet as S+import           Data.List (find, foldl')+import           Data.Text (Text)++import           Data.RBAC.Role+import           Data.RBAC.Internal.Types+++newtype RoleMap = RoleMap (HashMap Text (HashSet Role))+++------------------------------------------------------------------------------+fromList :: [Role] -> RoleMap+fromList = RoleMap . foldl' ins M.empty+  where+    ins m role =+        M.insertWith S.union (_roleName role) (S.singleton role) m+++------------------------------------------------------------------------------+lookup :: Role -> RoleMap -> Maybe Role+lookup role (RoleMap m) = find (`matches` role) l+  where+    l = maybe [] S.toList $ M.lookup (_roleName role) m+++------------------------------------------------------------------------------+delete :: Role -> RoleMap -> RoleMap+delete role (RoleMap m) = RoleMap $ maybe m upd $ M.lookup rNm m+  where+    rNm = _roleName role+    upd s = maybe m+                  (\r -> let s' = S.delete r s+                         in if S.null s'+                              then M.delete rNm m+                              else M.insert rNm s' m)+                  (find (`matches` role) $ S.toList s)+++------------------------------------------------------------------------------+insert :: Role -> RoleMap -> RoleMap+insert role (RoleMap m) =+    RoleMap $ M.insertWith S.union (_roleName role) (S.singleton role) m+++------------------------------------------------------------------------------+empty :: RoleMap+empty = RoleMap M.empty+++------------------------------------------------------------------------------+null :: RoleMap -> Bool+null (RoleMap m) = M.null m

@@ -0,0 +1,31 @@+module Data.RBAC.Internal.Rule where++import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as M+import           Data.List (foldl')+import           Data.Monoid+import           Data.Text (Text)++import           Data.RBAC.Internal.Role++------------------------------------------------------------------------------+data Rule = Rule Text (Role -> [Role])++newtype RuleSet = RuleSet (HashMap Text (Role -> [Role]))++instance Monoid RuleSet where+    mempty = RuleSet M.empty+    (RuleSet m1) `mappend` (RuleSet m2) = RuleSet $ M.foldlWithKey' ins m2 m1+      where+        combine f1 f2 r = f1 r ++ f2 r+        ins m k v       = M.insertWith combine k v m+++------------------------------------------------------------------------------+ruleToSet :: Rule -> RuleSet+ruleToSet (Rule nm f) = RuleSet $ M.singleton nm f+++------------------------------------------------------------------------------+rulesToSet :: [Rule] -> RuleSet+rulesToSet = foldl' mappend (RuleSet M.empty) . map ruleToSet

@@ -0,0 +1,33 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++module Data.RBAC.Internal.Types+  ( module Data.RBAC.Internal.Role+  , module Data.RBAC.Internal.Rule+  , RoleMonad(..)+  , RuleChecker(..)+  ) where++import           Control.Applicative+import           Control.Monad.Reader+import           Control.Monad.Logic++import           Data.RBAC.Internal.Role+import           Data.RBAC.Internal.Rule+++------------------------------------------------------------------------------+-- TODO: should the monads be transformers here? If they were, you could check+-- more complex predicates here+++------------------------------------------------------------------------------+newtype RoleMonad a = RoleMonad { _unRC :: Logic a }+  deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic)+++------------------------------------------------------------------------------+newtype RuleChecker a = RuleChecker (ReaderT (RoleMonad Role) RoleMonad a)+  deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic)+

@@ -0,0 +1,24 @@+module Data.RBAC.Role where++import qualified Data.HashMap.Strict as M+import           Data.RBAC.Internal.Types+import           Data.Text (Text)+++------------------------------------------------------------------------------+matches :: Role -> Role -> Bool+matches (Role a1 d1) (Role a2 d2) =+    a1 == a2 && dmatch (toSortedList d1) (toSortedList d2)+  where+    dmatch []         _      = True+    dmatch _          []     = False+    dmatch dds@(d:ds) (e:es) =+        case compare d e of+          LT -> False+          EQ -> dmatch ds es+          GT -> dmatch dds es+++------------------------------------------------------------------------------+addRoleData :: Text -> RoleValue -> Role -> Role+addRoleData k v (Role n d) = Role n $ M.insert k v d

@@ -0,0 +1,14 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++module Data.RBAC.Types+  ( Role(..)                    -- fixme: remove (..)+  , RoleValue(..)               -- fixme+  , RoleValueMeta(..)+  , RoleDataDefinition(..)+  , RoleMetadata(..)+  , Rule+  , RuleChecker+  ) where++import Data.RBAC.Internal.Types

@@ -0,0 +1,26 @@+{-|++This module provides convenience exports of the modules most commonly used+when developing with the Snap Framework.  For documentation about Snaplets,+see "Snap.Snaplet".  For the core web server API, see "Snap.Core".++-}++module Snap+  ( module Control.Applicative+  , module Control.Monad.State+  , module Data.Lens.Common+  , module Data.Lens.Template+  , module Snap.Core+  , module Snap.Http.Server+  , module Snap.Snaplet+  ) where++import Control.Applicative+import Control.Monad.State+import Data.Lens.Common+import Data.Lens.Template+import Snap.Core+import Snap.Http.Server+import Snap.Snaplet+

@@ -1,500 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}--module Snap.Extension-  ( -- * Introduction-    -- $introduction--    -- ** Using Snap Extensions-    -- $using--    -- *** Define Application State and Monad-    -- $definingtypes--    -- *** Provide Instances For \"HasState\" Classes-    -- $hasstateclasses--    -- *** Define The Initializer-    -- $initializer--    -- *** Simplified Snap Extension Server-    -- $httpserve--    SnapExtend-  , Initializer-  , InitializerState(..)-  , runInitializer-  , runInitializerWithReloadAction-  , runInitializerWithoutReloadAction-  , mkInitializer-  , defaultReloadHandler-  , nullReloadHandler-  ) where--import           Blaze.ByteString.Builder-import           Control.Applicative-import           Control.Exception (SomeException)-import           Control.Monad-import           Control.Monad.CatchIO-import           Control.Monad.Reader-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import           Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import           Prelude hiding (catch, init)-import           Snap.Iteratee (enumBuilder, (>==>))-import           Snap.Types-import           System.IO---{- $introduction--  Snap Extensions is a library which makes it easy to create reusable plugins-  that extend your Snap application with modular chunks of functionality such-  as session management, user authentication, templating, or database-  connection pooling.--  We achieve this by requiring that you create a datatype that holds an-  environment for your application and wrap it around the Snap monad. This new-  construct becomes your application's handler monad and gives you access to-  your application state throughout your handlers.--  Warning: this interface is still EXPERIMENTAL and has a very high likelihood-  of changing substantially in coming versions of Snap.---}--{- $using--  Every extension has an interface and at least one implementation of that-  interface.--  For some extensions, like Heist, there is only ever going to be one-  implementation of the interface. In these cases, both the interface and the-  implementation are exported from the same module, Snap.Extension.Heist.Impl.--  Hypothetically, for something like session management though, there could be-  multiple implementations, one using a HDBC backend, one using a MongoDB-  backend and one just using an encrypted cookie as backend. In these cases,-  the interface is exported from Snap.Extension.Session, and the-  implementations live in Snap.Extension.Session.HDBC,-  Snap.Extension.Session.MongoDB and Snap.Extension.Session.CookieStore.--  Keeping this in mind, there are a number of things you need to do to use-  Snap extensions in your application. Let's walk through how to set up a-  simple application with the Heist extension turned on.---}--{- $definingtypes--  First, we define a record type AppState for holding our application's state,-  including the state needed by the extensions we're using.--  At the same time, we also define the monad for our application, App, as-  a type alias to @SnapExtend AppState@. 'SnapExtend' is a 'MonadSnap' and-  a 'MonadReader', whose environment is a given type; in our case, AppState.--  @-module App where--import Database.HDBC-import Database.HDBC.ODBC-import Snap.Extension-import Snap.Extension.Heist-import Snap.Types--type App = SnapExtend AppState--data AppState = AppState-    { heistState  :: HeistState App }-  @--  An important thing to note is that the -State types that we use in the-  fields of AppState are specific to each implementation of a extension's-  interface.  That is, Snap.Extension.Session.HDBC will export a different-  SessionState to Snap.Extension.Session.CookieStore, whose internal-  representation might be completely different.--  This state is what the extension's implementation needs to be able to do its-  job.---}--{- $hasstateclasses--  Now we have a datatype that contains all the internal state needed by our-  application and the extensions it uses. That's a great start! But when do we-  actually get to use this interface and all the functionality that these-  extensions export?  What is actually being extended?--  We use the interface provided by an extension inside our application's-  monad, App. Snap extensions extend our App with new functionality by-  allowing us to user their exported functions inside of our handlers. For-  example, the Heist extension provides the function:--  @render :: MonadHeist m => ByteString -> m ()@ that renders a template by-  its name.--  Is App a 'MonadHeist'? Well, not quite yet. Any 'MonadReader' which is also-  a 'MonadSnap' whose environment contains a 'HeistState' is a 'MonadHeist'.-  That sounds a lot like our App, doesn't it? We just have to tell the Heist-  extension how to find the 'HeistState' in our AppState:--  @-instance HasHeistState AppState where-    getHeistState = heistState-    setHeistState hs as = as { heistState = hs }-  @--  Stated another way, if we give our AppState the ability to hold a HeistState-  and let the HasHeistState typeclass know how to get/set this state, we are-  /automagically/ given the ability to render heist templates in our handlers.--  With these instances, our application's monad App is now a MonadHeist-  giving it access to operations like:--  @render :: MonadHeist m => ByteString -> m ()@--  and--  @heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a@---}--{- $initializer--  So, our monad is now a 'MonadHeist', but how do we actually construct our-  AppState and turn an App () into a 'Snap' ()? We need to do this upfront,-  once and right before our web server starts listening for connections.--  Snap extensions have a thing called an 'Initializer' that does these things.-  Each implementation of a Snap extension interface provides an 'Initializer'-  for its -State type. We must construct an initializer type for our -State-  type, AppState. An 'Initializer' monad is provided in this library to make-  it easy to do this. For your convenience, 'Initializer' is an instance of-  'MonadIO'.--  @-appInitializer :: Initializer AppState-appInitializer = do-    hs <- heistInitializer \"resources/templates\"-    return $ AppState hs-  @--  In addition to constructing the AppState, the Initializer monad also-  constructs the init, destroy and reload functions for our application from-  the init, reload and destroy functions for the extensions.--  Although it won't cause a compile-time error, it is important to get the-  order of the initializers correct as much as possible, otherwise they may be-  reloaded and destroyed in the wrong order. The "right" order is an order-  where every extension's dependencies are initialised before that extension.-  For example, Snap.Extension.Session.HDBC would depend on something which-  would extend the monad with MonadConnectionPool, i.e.,-  Snap.Extension.ConnectionPool. If you had this configuration it would be-  important that you put the connectionPoolInitializer before the-  sessionInitializer in your appInitializer.--  This Initializer AppState can then be passed to 'runInitializer', which-  combines our initializer action with our application's handler to produce a-  'Snap' handler (which can be passed to 'httpServe'), a cleanup action (which-  you can run after 'httpServe' finishes), and a reload action (which, for-  example, you may want to use in your handler for the path \"admin/reload\".--  The following is an example of how you might use this in main:--  @-main :: IO ()-main = do-    (snap,cleanup,reload) <- runInitializer appInitializer appSite-    let site = snap-               <|> path "admin/reload" $ defaultReloadHandler reload cleanup-    quickHttpServe site `finally` cleanup-  @--  You'll notice we're using 'defaultReloadHandler'. This is a function-  exported by "Snap.Extension" with the type signature--  @MonadSnap m => IO [(ByteString, Maybe ByteString)] -> m ()@ It takes the-  reload action returned by 'runInitializer' and returns a 'Snap' action which-  renders a simple page showing how the reload went. To avoid denial of-  service attacks, the reload handler only works for requests made from the-  local host.---}--{- $httpserve-- This is, of course, a lot of avoidable boilerplate. Snap extensions framework- comes with another module "Snap.Extension.Server", which provides an- interface mimicking that of "Snap.Http.Server". Their function names clash,- so if you need to use both of them in the same module, use a qualified- import. Using this module, the example above becomes:--  @-import Snap.Extension.Server--main :: IO ()-main = quickHttpServe appRunner site-  @--  All it needs is a Initializer AppState and an App () and it is ready to go.-  You might be wondering what happened to all the reload handler bits we-  had before: That stuff has been absorbed into the config for the server.--  One quick note: 'quickHttpServe' doesn't take a config, instead it uses the-  defaults augmented with any options specified on the command-line.  The-  default reload handler path in this case is "admin/reload".--  If you wanted to change this to nullReloadHandler, you would do this:--  @-import Snap.Extension.Server--main :: IO ()-main = do-    config <- commandLineConfig emptyConfig-    httpServe (setReloadHandler nullReloadHandler config) appRunner site-  @--  This behaves exactly as the above example apart from the reload handler.--  With this, we now have a fully functional base application that makes use of-  the Snap Extensions mechanism.--  To initialize a directory with all of this setup provided as a starting-  point, simply @cd@ into the desired location and type: @snap init@. An-  example \"Timer\" extension will also be included for your convenience.---}----------------------------------------------------------------------------------- | A 'SnapExtend' is a 'MonadReader' and a 'MonadSnap' whose environment is--- the application state for a given progam. You would usually type alias--- @SnapExtend AppState@ to something like @App@ to form the monad in which--- you write your application.-newtype SnapExtend s a = SnapExtend (ReaderT s Snap a)-  deriving-    ( Functor-    , Applicative-    , Alternative-    , Monad-    , MonadPlus-    , MonadIO-    , MonadCatchIO-    , MonadSnap-    , MonadReader s-    )------------------------------------------------------------------------------------ | The 'SCR' datatype is used internally by the 'Initializer' monad to store--- the application's state, cleanup actions and reload actions.-data SCR s = SCR-    { _state   :: s-      -- ^ The internal state of the application's Snap Extensions.-    , _cleanup :: IO ()-      -- ^ IO action which when run will cleanup the application's state,-      -- e.g., closing open connections.-    , _reload  :: IO [(ByteString, Maybe ByteString)]-      -- ^ IO action which when run will reload the application's state, e.g.,-      -- refreshing any cached values stored in the state.-      ---      -- It returns a list of tuples whose \"keys\" are the names of the Snap-      -- Extensions which were reloaded and whose \"values\" are @Nothing@-      -- when run successfully and @Just x@ on failure, where @x@ is an error-      -- message.-    }------------------------------------------------------------------------------------ | The 'Initializer' monad. The code that initialises your application's--- state is written in the 'Initializer' monad. It's used for constructing--- values which have cleanup\/destroy and reload actions associated with them.-newtype Initializer s = Initializer (Bool -> IO (Either s (SCR s)))------------------------------------------------------------------------------------ | Values of types which are instances of 'InitializerState' have--- cleanup\/destroy and reload actions associated with them.-class InitializerState s where-    extensionId :: s -> ByteString-    mkCleanup   :: s -> IO ()-    mkReload    :: s -> IO ()------------------------------------------------------------------------------------ | Although it has the same type signature, this is not the same as 'return'--- in the 'Initializer' monad. Return simply lifts a value into the--- 'Initializer' monad, but this lifts the value and its destroy\/reload--- actions. Use this when making your own 'Initializer' actions.-mkInitializer :: InitializerState s => s -> Initializer s-mkInitializer s = Initializer $ \v -> setup v $ Right $ mkSCR v-  where-    handler          :: SomeException -> IO (Maybe ByteString)-    handler e        = return $ Just $ toUTF8 $ show e-    maybeCatch m     = (m >> return Nothing) `catch` handler-    maybeToMsg       = maybe " done." $ const " failed."-    name             = fromUTF8 $ extensionId s-    mkSCR v          = SCR s (cleanup v) (reload v)-    cleanup v        = do-        when v $ hPutStr stderr $ "Cleaning up " ++ name ++ "..."-        m <- maybeCatch $ mkCleanup s-        when v $ hPutStrLn stderr $ maybeToMsg m-    reload v         = do-        when v $ hPutStr stderr $ "Reloading " ++ name ++ "..."-        m <- maybeCatch $ mkReload s-        when v $ hPutStrLn stderr $ maybeToMsg m-        return [(extensionId s, m)]-    setup v r        = do-        when v $ hPutStrLn stderr $ "Initializing " ++ name ++ "... done."-        return r------------------------------------------------------------------------------------ | Given the Initializer for your application's state, and a value in the--- monad formed by 'SnapExtend' wrapped it, this returns a 'Snap' action, a--- cleanup action and a reload action.-runInitializer-  :: Bool-    -- ^ Verbosity; info is printed to 'stderr' when this is 'True'-  -> Initializer s-    -- ^ The Initializer value-  -> SnapExtend s ()-    -- ^ A web handler in your application's monad-  -> IO (Snap (), IO (), IO [(ByteString, Maybe ByteString)])-     -- ^ Returns a 'Snap' handler, a cleanup action, and a reload action. The-     -- list returned by the reload action is for error reporting. There is-     -- one tuple in the list for each Snap extension; the first element of-     -- the tuple is the name of the Snap extension, and the second is a Maybe-     -- which contains Nothing if there was no error reloading that extension-     -- and a Just with the ByteString containing the error message if there-     -- was.-runInitializer v (Initializer r) (SnapExtend m) =-    r v >>= \e -> case e of-        Left s            -> return (runReaderT m s, return (), return [])-        Right (SCR s a b) -> return (runReaderT m s, a, b)------------------------------------------------------------------------------------ | Serves the same purpose as 'runInitializer', but combines the---   application's web handler with a user-supplied action to be run to reload---   the application's state.-runInitializerWithReloadAction-  :: Bool-    -- ^ Verbosity; info is printed to 'stderr' when this is 'True'-  -> Initializer s-    -- ^ The Initializer value-  -> SnapExtend s ()-    -- ^ A web handler in your application's monad.-  -> (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())-    -- ^ Your desired \"reload\" handler; it gets passed the reload-    -- action. This handler is always run, so you have to guard the path-    -- yourself (with.-  -> IO (Snap (), IO ())-    -- ^ Your 'Snap' handler and a cleanup action.-runInitializerWithReloadAction v (Initializer r) se f = do-    (state, cleanup, reload) <- runInit--    let (SnapExtend m') = f reload <|> se-    return (runReaderT m' state, cleanup)--  where-    runInit = r v >>= \e ->-              case e of-                Left s            -> return (s, return (), return [])-                Right (SCR s a b) -> return (s, a, b)----------------------------------------------------------------------------------- | A cut-down version of 'runInitializer', for use by the hint--- loading code-runInitializerWithoutReloadAction :: Initializer s-                                  -- ^ The Initializer value-                                  -> SnapExtend s ()-                                  -- ^ An action in your application's monad.-                                  -> IO (Snap (), IO ())-runInitializerWithoutReloadAction i se = do-    (action, cleanup, _) <- runInitializer True i se-    return (action, cleanup)----------------------------------------------------------------------------------instance Functor Initializer where-    fmap f (Initializer r) = Initializer $ \v -> r v >>= \e -> return $-        case e of-            Left s            -> Left $ f s-            Right (SCR s a b) -> Right $ SCR (f s) a b----------------------------------------------------------------------------------instance Applicative Initializer where-    pure  = return-    (<*>) = ap----------------------------------------------------------------------------------instance Monad Initializer where-    return   = Initializer . const . return . Left-    a >>= f  = join' $ fmap f a----------------------------------------------------------------------------------instance MonadIO Initializer where-    liftIO = Initializer . const . fmap Left------------------------------------------------------------------------------------ | Join for the 'Initializer' monad. This is used in the definition of bind--- for the 'Initializer' monad.-join' :: Initializer (Initializer s) -> Initializer s-join' (Initializer r) = Initializer $ \v -> r v >>= \e -> case e of-    Left  (Initializer r')           -> r' v-    Right (SCR (Initializer r') a b) -> r' v >>= \e' -> return $ Right $-        case e' of-            Left  s             -> SCR s a b-            Right (SCR s a' b') -> SCR s (a' >> a) (liftM2 (++) b b')------------------------------------------------------------------------------------ | This takes the last value of the tuple returned by 'runInitializer',--- which is a list representing the results of an attempt to reload the--- application's Snap Extensions, and turns it into a Snap action which--- displays the these results.-defaultReloadHandler :: MonadSnap m-                     => IO [(ByteString, Maybe ByteString)]-                     -> m ()-defaultReloadHandler ioms = failIfNotLocal $ do-    ms <- liftIO $ ioms-    let showE e       = mappend "Error: "  $ toUTF8 $ show e-        format (n, m) = mconcat [n, ": ", maybe "Success" showE m, "\n"]-        msg           = mconcat $ map format ms-    finishWith $ setContentType "text/plain; charset=utf-8"-        $ setContentLength (fromIntegral $ B.length msg)-        $ modifyResponseBody (>==> enumBuilder (fromByteString msg))-                             emptyResponse-  where-    failIfNotLocal m = do-        rip <- liftM rqRemoteAddr getRequest-        if not $ elem rip [ "127.0.0.1"-                          , "localhost"-                          , "::1" ]-          then pass-          else m----------------------------------------------------------------------------------- | Use this reload handler to disable the ability to have a web handler--- which reloads Snap extensions.-nullReloadHandler :: MonadSnap m-                  => IO [(ByteString, Maybe ByteString)]-                  -> m ()-nullReloadHandler = const pass----------------------------------------------------------------------------------fromUTF8 :: ByteString -> String-fromUTF8 = T.unpack . T.decodeUtf8--toUTF8 :: String -> ByteString-toUTF8 = T.encodeUtf8 . T.pack

@@ -1,79 +0,0 @@-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}--{-|--'Snap.Extension.Heist' exports the 'MonadHeist' interface which allows you to-integrate Heist templates into your Snap application. The interface's-operations are 'heistServe', 'heistServeSingle', 'heistLocal' and 'render'. As-a convenience, we also provide 'renderWithSplices' that combines 'heistLocal'-and 'render' into a single function call.--'Snap.Extension.Heist.Impl' contains the only implementation of this interface-and can be used to turn your application's monad into a 'MonadHeist'.--'MonadHeist' is unusual among Snap extensions in that it's a multi-parameter-typeclass. The last parameter is your application's monad, and the first is-the monad you want the 'TemplateState' to use. This is usually, but not-always, also your application's monad.--This module should not be used directly. Instead, import-"Snap.Extension.Heist.Impl" in your application.---}--module Snap.Extension.Heist-  ( MonadHeist(..)-  , renderWithSplices ) where--import           Control.Applicative-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import           Data.Text (Text)-import           Snap.Types-import           Snap.Util.FileServe-import           Text.Templating.Heist------------------------------------------------------------------------------------ | The 'MonadHeist' type class. Minimal complete definition: 'render',--- 'heistLocal'.-class (Monad n, MonadSnap m) => MonadHeist n m | m -> n where-    -- | Renders a template as text\/html. If the given template is not found,-    -- this returns 'empty'.-    render     :: ByteString -> m ()--    -- | Renders a template as the given content type.  If the given template-    -- is not found, this returns 'empty'.-    renderAs   :: ByteString -> ByteString -> m ()--    -- | Runs an action with a modified 'TemplateState'. You might want to use-    -- this if you had a set of splices which were customised for a specific-    -- action. To do that you would do:-    ---    -- > heistLocal (bindSplices mySplices) $ render "myTemplate"-    heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a--    -- | Analogous to 'fileServe'. If the template specified in the request-    -- path is not found, it returns 'empty'.-    heistServe :: m ()-    heistServe = ifTop (render "index") <|> (render . B.pack =<< getSafePath)--    -- | Analogous to 'fileServeSingle'. If the given template is not found,-    -- this throws an error.-    heistServeSingle :: ByteString -> m ()-    heistServeSingle t = render t-        <|> error ("Template " ++ show t ++ " not found.")------------------------------------------------------------------------------------ | Helper function for common use case:--- Render a template with a given set of splices.-renderWithSplices-  :: (MonadHeist n m)-  => ByteString                 -- ^ Template to render-  -> [(Text, Splice n)]   -- ^ Splice mapping-  -> m ()-renderWithSplices t sps = heistLocal bsps $ render t-  where bsps = bindSplices sps

@@ -1,219 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}--{-|--'Snap.Extension.Heist.Impl' is an implementation of the 'MonadHeist'-interface defined in 'Snap.Extension.Heist'.--As always, to use, add 'HeistState' to your application's state, along with an-instance of 'HasHeistState' for your application's state, making sure to-use a 'heistInitializer' in your application's 'Initializer', and then you're-ready to go.--'Snap.Extension.Heist.Impl' is a little different to other Snap Extensions,-which is unfortunate as it is probably the most widely useful one. As-explained below, 'HeistState' takes your application's monad as a type-argument, and 'HasHeistState' is a multi-parameter type class, the additional-first parameter also being your application's monad.--Two instances of 'MonadHeist' are provided with this module. One is designed-for users wanting to use Heist templates with their application, the other is-designed for users writing Snap Extensions which use their own Heist templates-internally.--The first one of these instances is-@HasHeistState (SnapExtend s) s => MonadHeist (SnapExtend s) (SnapExtend s)@.-This means that any type @s@ which has a 'HeistState', whose-'TemplateState'\'s monad is @SnapExtend s@ forms a 'MonadHeist' whose-'TemplateState'\'s monad is @SnapExtend s@ and whose monad itself is-@SnapExtend s@. The @s@ here is your application's state, and @SnapExtend s@-is your application's monad.--The second one of these instances is-@HasHeistState m s => MonadHeist m (ReaderT s m)@. This means that any type-@s@ which has, for any m, a @HeistState m@, forms a 'MonadHeist', whose-'TemplateState'\'s monad is @m@, when made the environment of-a 'ReaderT' wrapped around @m@. The @s@ here would be the Snap Extension's-internal state, and the @m@ would be 'SnapExtend' wrapped around any @s'@-which was an instance of the Snap Extension's @HasState@ class.--This implementation does not require that your application's monad implement-interfaces from any other Snap Extension.---}--module Snap.Extension.Heist.Impl-  (--    -- * Heist State Definitions-    HeistState-  , HasHeistState(..)-  , heistInitializer--    -- * The MonadHeist Interface-  , MonadHeist(..)--    -- * Convenience Functions-  , registerSplices-  ) where--import           Control.Concurrent.MVar-import           Control.Monad.Reader-import           Data.ByteString (ByteString)-import           Data.Maybe-import           Data.Text (Text)-import           Snap.Extension-import           Snap.Extension.Heist-import           Snap.Types-import           Text.Templating.Heist-import           Text.Templating.Heist.Splices.Static------------------------------------------------------------------------------------ | Your application's state must include a 'HeistState' in order for your--- application to be a 'MonadHeist'.------ Unlike other @-State@ types, this is of kind @(* -> *) -> *@. Unless you're--- developing your own Snap Extension which has its own internal 'HeistState',--- the type argument you want to pass to 'HeistState' is your application's--- monad, which should be 'SnapExtend' wrapped around your application's--- state.-data MonadSnap m => HeistState m = HeistState-    { _path     :: FilePath-    , _origTs   :: TemplateState m-    , _tsMVar   :: MVar (TemplateState m)-    , _sts      :: StaticTagState-    , _modifier :: TemplateState m -> TemplateState m-    }------------------------------------------------------------------------------------ | For your application's monad to be a 'MonadHeist', your application's--- state needs to be an instance of 'HasHeistState'. Minimal complete--- definition: 'getHeistState', 'setHeistState'.------ Unlike other @HasState@ type classes, this is a type class has two--- parameters. Among other things, this means that you will need to enable the--- @FlexibleInstances@ and @MultiParameterTypeClasses@ language extensions to--- be able to create an instance of @HasHeistState@. In most cases, the last--- parameter will as usual be your application's state, and the additional--- first one will be the monad formed by wrapping 'SnapExtend' around your--- application's state.------ However, if you are developing your own Snap Extension which uses its own--- internal 'HeistState', the last parameter will be your Snap Extension's--- internal state, and the additional first parameter will be any monad formed--- by wrapping @SnapExtend@ around a type which has an instance of the--- @HasState@ class for your monad. These two use cases are subtly different,--- which is why 'HasHeistState' needs two type parameters.-class MonadSnap m => HasHeistState m s | s -> m where-    getHeistState :: s -> HeistState m-    setHeistState :: HeistState m -> s -> s--    modifyHeistState :: (HeistState m -> HeistState m) -> s -> s-    modifyHeistState f s = setHeistState (f $ getHeistState s) s------------------------------------------------------------------------------------ | 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 $ modTS $ emptyTemplateState p-        loadTemplates p origTs >>= either error (\ts -> do-            tsMVar <- newMVar ts-            return $ HeistState p origTs tsMVar sts id)-    mkInitializer heistState----------------------------------------------------------------------------------instance MonadSnap m => InitializerState (HeistState m) where-    extensionId = const "Heist/Impl"-    mkCleanup   = const $ return ()-    mkReload (HeistState p origTs tsMVar sts _) = do-        clearStaticTagCache $ sts-        either error (modifyMVar_ tsMVar . const . return) =<<-            loadTemplates p origTs----------------------------------------------------------------------------------instance HasHeistState (SnapExtend s) s-      => MonadHeist (SnapExtend s) (SnapExtend s) where-    render t = do-        hs <- asks getHeistState-        renderHelper hs Nothing t--    renderAs c t = do-        hs <- asks getHeistState-        renderHelper hs (Just c) t--    heistLocal f = local $ modifyHeistState $ \s ->-        s { _modifier = f . _modifier s }----------------------------------------------------------------------------------instance HasHeistState m s => MonadHeist m (ReaderT s m) where-    render t = ReaderT $ \s -> renderHelper (getHeistState s) Nothing t--    renderAs c t = ReaderT $ \s -> renderHelper (getHeistState s) (Just c) t--    heistLocal f = local $ modifyHeistState $ \s ->-        s { _modifier = f . _modifier s }----------------------------------------------------------------------------------renderHelper :: (MonadSnap m)-             => HeistState m-             -> Maybe MIMEType-             -> ByteString-             -> m ()-renderHelper hs c t = do-    let (HeistState _ _ tsMVar _ modifier) = hs-    ts <- liftIO $ fmap modifier $ readMVar tsMVar-    renderTemplate ts t >>= maybe pass (\(b,mime) -> do-        modifyResponse $ setContentType $ fromMaybe mime c-        writeBuilder b)------------------------------------------------------------------------------------ | 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'.  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.------ Example Usage:------ @--- appInit :: Initializer AppState--- appInit = do---  hs <- heistInitializer \"templates\"---  registerSplices hs $---   [ (\"tabs\", tabsSplice)---   , (\"loginLogout\", loginLogoutSplice) ]--- @-registerSplices-  :: (MonadSnap m, MonadIO n)-  => HeistState m-  -- ^ Heist state that you are going to embed in your application's state.-  -> [(Text, Splice m)]-  -- ^ Your splices.-  -> n ()-registerSplices s sps = liftIO $ do-  let mv = _tsMVar s-  modifyMVar_ mv $ (return . bindSplices sps)

@@ -1,176 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--- | This module includes the machinery necessary to use hint to load--- action code dynamically.  It includes a Template Haskell function--- to gather the necessary compile-time information about code--- location, compiler arguments, etc, and bind that information into--- the calls to the dynamic loader.-module Snap.Extension.Loader.Devel-  ( loadSnapTH-  , loadSnapTH'-  ) where--import           Control.Monad (liftM2)--import           Data.List-import           Data.Maybe (catMaybes)-import           Data.Time.Clock (diffUTCTime, getCurrentTime)--import           Language.Haskell.Interpreter hiding (lift, liftIO)-import           Language.Haskell.Interpreter.Unsafe--import           Language.Haskell.TH--import           System.Environment (getArgs)---------------------------------------------------------------------------------import           Snap.Types-import           Snap.Extension.Loader.Devel.Signal-import           Snap.Extension.Loader.Devel.Evaluator-import           Snap.Extension.Loader.Devel.TreeWatcher----------------------------------------------------------------------------------- | This function derives all the information necessary to use the--- interpreter from the compile-time environment, and compiles it in--- to the generated code.------ This could be considered a TH wrapper around a function------ > loadSnap :: Initializer s -> SnapExtend s () -> [String] -> IO (Snap ())------ with a magical implementation.------ The upshot is that you shouldn't need to recompile your server--- 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 =-    loadSnapTH' modules imports additionalWatchDirs loadStr-  where-    initMod = nameModule initializer-    initBase = nameBase initializer-    actMod = nameModule action-    actBase = nameBase action--    modules = catMaybes [initMod, actMod]-    imports = ["Snap.Extension"]--    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--    [| hintSnap opts modules imports srcPaths loadStr |]------------------------------------------------------------------------------------ | Convert the command-line arguments passed in to options for the--- hint interpreter.  This is somewhat brittle code, based on a few--- experimental datapoints regarding the structure of the command-line--- arguments cabal produces.-getHintOpts :: [String] -> [String]-getHintOpts args = removeBad opts-  where-    bad = ["-threaded", "-O"]-    removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad)--    hideAll = filter (== "-hide-all-packages") args--    srcOpts = filter (\x -> "-i" `isPrefixOf` x-                            && not ("-idist" `isPrefixOf` x)) args--    toCopy = filter (not . isSuffixOf ".hs") $-             dropWhile (not . ("-package" `isPrefixOf`)) args-    copy = map (intercalate " ") . groupBy (\_ s -> not $ "-" `isPrefixOf` s)--    opts = hideAll ++ srcOpts ++ copy toCopy------------------------------------------------------------------------------------ | This function extracts the source paths from the compilation args-getSrcPaths :: [String] -> [String]-getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg-  where-    srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x)------------------------------------------------------------------------------------ | This function creates the Snap handler that actually is--- responsible for doing the dynamic loading of actions via hint,--- given all of the configuration information that the interpreter--- needs.  It also ensures safe concurrent access to the interpreter,--- and caches the interpreter results for a short time before allowing--- it to run again.------ Generally, this won't be called manually.  Instead, loadSnapTH will--- generate a call to it at compile-time, calculating all the--- arguments from its environment.-hintSnap :: [String] -- ^ A list of command-line options for the interpreter-         -> [String] -- ^ A list of modules that need to be-                     -- interpreted. This should contain only the-                     -- modules which contain the initialization,-                     -- cleanup, and handler actions.  Everything else-                     -- they require will be loaded transitively.-         -> [String] -- ^ A list of 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 string to execute-         -> IO (Snap (), IO ())-hintSnap opts modules imports srcPaths action =-    protectedHintEvaluator initialize test loader-  where-    interpreter = do-        loadModules . nub $ modules-        setImports . nub $ "Prelude" : "Snap.Types" : imports ++ modules--        interpret action (as :: HintLoadable)--    loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter--    formatOnError (Left err) = error $ format err-    formatOnError (Right a) = a--    loader = formatOnError `fmap` protectHandlers loadInterpreter--    initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths--    test (prevTime, ts) = do-        now <- getCurrentTime-        if diffUTCTime now prevTime < 3-            then return True-            else checkTreeStatus ts------------------------------------------------------------------------------------ | Convert an InterpreterError to a String for presentation-format :: InterpreterError -> String-format (UnknownError e)   = "Unknown interpreter error:\r\n\r\n" ++ e-format (NotAllowed e)     = "Interpreter action not allowed:\r\n\r\n" ++ e-format (GhcException e)   = "GHC error:\r\n\r\n" ++ e-format (WontCompile errs) = "Compile errors:\r\n\r\n" ++-    (intercalate "\r\n" $ nub $ map errMsg errs)-

@@ -1,145 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Snap.Extension.Loader.Devel.Evaluator-  ( HintLoadable-  , protectedHintEvaluator-  ) where---import Control.Exception-import Control.Monad (when)-import Control.Monad.Trans (liftIO)--import Control.Concurrent (ThreadId, forkIO, myThreadId)-import Control.Concurrent.MVar--import Prelude hiding (catch, init, any)--import Snap.Types (Snap)------------------------------------------------------------------------------------ | A type synonym to simply talking about the type loaded by hint.-type HintLoadable = IO (Snap (), IO ())------------------------------------------------------------------------------------ | Convert an action to generate 'HintLoadable's into an action to--- generate Snap actions.  The resulting action will share initialized--- state until the next execution of the input action.  At this time,--- the cleanup action will be executed.------ The first two arguments control when recompiles are done.  The--- first argument is an action that is executed when compilation--- starts.  The second is a function from the result of the first--- action to an action that determines whether the value from the--- previous compilation is still good.  This abstracts out the--- strategy for determining when a cached result is no longer valid.------ If an exception is raised during the processing of the action, it--- will be thrown to all waiting threads, and for all requests made--- before the recompile condition is reached.-protectedHintEvaluator :: forall a.-                          IO a-                       -> (a -> IO Bool)-                       -> IO HintLoadable-                       -> IO (Snap (), IO ())-protectedHintEvaluator start test getInternals = do-    -- The list of requesters waiting for a result.  Contains the-    -- ThreadId in case of exceptions, and an empty MVar awaiting a-    -- successful result.-    readerContainer <- newReaderContainer--    -- Contains the previous result and initialization value, and the-    -- time it was stored, if a previous result has been computed.-    -- The result stored is either the actual result and-    -- initialization result, or the exception thrown by the-    -- calculation.-    resultContainer <- newResultContainer--    -- The model used for the above MVars in the returned action is-    -- "keep them full, unless updating them."  In every case, when-    -- one of those MVars is emptied, the next action is to fill that-    -- same MVar.  This makes deadlocking on MVar wait impossible.-    let snap = do-            let waitForNewResult :: IO (Snap ())-                waitForNewResult = do-                    -- Need to calculate a new result-                    tid <- myThreadId-                    reader <- newEmptyMVar--                    readers <- takeMVar readerContainer--                    -- Some strictness is employed to ensure the MVar-                    -- isn't holding on to a chain of unevaluated thunks.-                    let pair = (tid, reader)-                        newReaders = readers `seq` pair `seq` (pair : readers)-                    putMVar readerContainer $! newReaders--                    -- If this is the first reader to queue, clean up the-                    -- previous state, if there was any, and then begin-                    -- evaluation of the new code and state.-                    when (null readers) $ do-                        let runAndFill = block $ do-                                -- run the cleanup action-                                previous <- readMVar resultContainer-                                unblock $ cleanup previous--                                -- compile the new internals and initialize-                                stateInitializer <- unblock getInternals-                                res <- unblock stateInitializer--                                let a = fst res--                                clearAndNotify (Right res) (flip putMVar a . snd)--                            killWaiting :: SomeException -> IO ()-                            killWaiting e = block $ do-                                clearAndNotify (Left e) (flip throwTo e . fst)-                                throwIO e--                            clearAndNotify r f = do-                                a <- unblock start-                                _ <- swapMVar resultContainer $ Just (r, a)-                                allReaders <- swapMVar readerContainer []-                                mapM_ f allReaders--                        _ <- forkIO $ runAndFill `catch` killWaiting-                        return ()--                    -- Wait for the evaluation of the action to complete,-                    -- and return its result.-                    takeMVar reader--            existingResult <- liftIO $ readMVar resultContainer--            getResult <- liftIO $ case existingResult of-                Just (res, a) -> do-                    -- There's an existing result.  Check for validity-                    valid <- test a-                    case (valid, res) of-                        (True, Right (x, _)) -> return x-                        (True, Left e)       -> throwIO e-                        (False, _)           -> 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 []--    newResultContainer :: IO (MVar (Maybe (Either SomeException-                                                  (Snap (), IO ()), a)))-    newResultContainer = newMVar Nothing--    cleanup (Just (Right (_, clean), _)) = clean-    cleanup _                            = return ()

@@ -1,43 +0,0 @@-{-# LANGUAGE CPP #-}-module Snap.Extension.Loader.Devel.Signal (protectHandlers) where--import Control.Exception (bracket)--#ifdef mingw32_HOST_OS-import GHC.ConsoleHandler as C---saveHandlers :: IO C.Handler-saveHandlers = C.installHandler Ignore---restoreHandlers :: C.Handler -> IO C.Handler-restoreHandlers = C.installHandler---#else-import qualified System.Posix.Signals as S--helper :: S.Handler -> S.Signal -> IO S.Handler-helper handler signal = S.installHandler signal handler Nothing---signals :: [S.Signal]-signals = [ S.sigQUIT-          , S.sigINT-          , S.sigHUP-          , S.sigTERM-          ]---saveHandlers :: IO [S.Handler]-saveHandlers = mapM (helper S.Ignore) signals---restoreHandlers :: [S.Handler] -> IO [S.Handler]-restoreHandlers h = sequence $ zipWith helper h signals---#endif-protectHandlers :: IO a -> IO a-protectHandlers a = bracket saveHandlers restoreHandlers $ const a

@@ -1,41 +0,0 @@-module Snap.Extension.Loader.Devel.TreeWatcher-    ( TreeStatus-    , getTreeStatus-    , checkTreeStatus-    ) where--import Control.Applicative--import System.Directory-import System.Directory.Tree--import System.Time------------------------------------------------------------------------------------ | An opaque representation of the contents and last modification--- times of a forest of directory trees.-data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime]------------------------------------------------------------------------------------ | Create a 'TreeStatus' for later checking with 'checkTreeStatus'-getTreeStatus :: [FilePath] -> IO TreeStatus-getTreeStatus = liftA2 (<$>) TS readModificationTimes------------------------------------------------------------------------------------ | Checks that all the files present in the initial set of paths are--- the exact set of files currently present, with unchanged modifcations times-checkTreeStatus :: TreeStatus -> IO Bool-checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths-  where-    check = and . zipWith (==) entries------------------------------------------------------------------------------------ | This is the core of the functions in this module.  It converts a--- list of filepaths into a list of 'AnchoredDirTree' annotated with--- the modification times of the files located in those paths.-readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime]-readModificationTimes = mapM $ readDirectoryWith getModificationTime

@@ -1,138 +0,0 @@-{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}--{-|--This module provides replacements for the 'httpServe' and 'quickHttpServe'-functions exported by 'Snap.Http.Server'. By taking a 'Initializer' as an-argument, these functions simplify the glue code that is needed to use Snap-Extensions.---}--module Snap.Extension.Server-  ( ConfigExtend-  , httpServe-  , quickHttpServe-  , defaultConfig-  , getReloadHandler-  , setReloadHandler-  , module Snap.Http.Server.Config-  ) where--import           Control.Exception (SomeException)-import           Control.Monad-import           Control.Monad.CatchIO-import           Data.ByteString (ByteString)-import           Data.Maybe-import           Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import           Prelude hiding (catch)-import           Snap.Extension-import qualified Snap.Http.Server as SS-import qualified Snap.Http.Server.Config as C-import           Snap.Http.Server.Config hiding ( defaultConfig-                                                , completeConfig-                                                , getOther-                                                , setOther-                                                )-import           Snap.Util.GZip-import           Snap.Types-import           System.IO------------------------------------------------------------------------------------ | 'ConfigExtend' is similar to the 'Config' exported by 'Snap.Http.Server',--- but is augmented with a @reloadHandler@ field which can be accessed using--- 'getReloadHandler' and 'setReloadHandler'.-type ConfigExtend s = Config-    (SnapExtend s) (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())----------------------------------------------------------------------------------getReloadHandler :: ConfigExtend s -> Maybe-                      (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())-getReloadHandler = C.getOther----------------------------------------------------------------------------------setReloadHandler :: (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ())-                 -> ConfigExtend s-                 -> ConfigExtend s-setReloadHandler = C.setOther-------------------------------------------------------------------------------------- | These are the default values for all the fields in 'ConfigExtend'.------ > hostname      = "localhost"--- > address       = "0.0.0.0"--- > port          = 8000--- > accessLog     = "log/access.log"--- > errorLog      = "log/error.log"--- > locale        = "en_US"--- > compression   = True--- > verbose       = True--- > errorHandler  = prints the error message--- > reloadHandler = prints the result of each reload handler (error/success)----defaultConfig :: ConfigExtend s-defaultConfig = setReloadHandler handler C.defaultConfig-  where-    handler = path "admin/reload" . defaultReloadHandler------------------------------------------------------------------------------------ | Completes a partial 'Config' by filling in the unspecified values with--- the default values from 'defaultConfig'.-completeConfig :: ConfigExtend s -> IO (ConfigExtend s)-completeConfig = C.completeConfig . (mappend defaultConfig)------------------------------------------------------------------------------------ | Starts serving HTTP requests using the given handler, with settings from--- the 'ConfigExtend' passed in. This function never returns; to shut down--- the HTTP server, kill the controlling thread.-httpServe :: ConfigExtend s-          -- ^ Any configuration options which override the defaults-          -> Initializer s-          -- ^ The 'Initializer' function for the application's monad-          -> SnapExtend s ()-          -- ^ The application to be served-          -> IO ()-httpServe config initializer handler = do-    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 $ compress handler)-                         reloader-    _   <- try $ serve $ site :: IO (Either SomeException ())-    putStr "\n"-    cleanup------------------------------------------------------------------------------------ | Starts serving HTTP using the given handler. The configuration is read--- from the options given on the command-line, as returned by--- 'commandLineConfig'.-quickHttpServe :: Initializer s-               -- ^ The 'Initializer' function for the application's monad-               -> SnapExtend s ()-               -- ^ The application to be served-               -> IO ()-quickHttpServe r m = commandLineConfig emptyConfig >>= \c -> httpServe c r m---------------------------------------------------------------------------------fromUTF8 :: ByteString -> String-fromUTF8 = T.unpack . T.decodeUtf8

@@ -0,0 +1,180 @@+{-# LANGUAGE TemplateHaskell #-}+-- | This module includes the machinery necessary to use hint to load+-- action code dynamically.  It includes a Template Haskell function+-- to gather the necessary compile-time information about code+-- location, compiler arguments, etc, and bind that information into+-- the calls to the dynamic loader.+module Snap.Loader.Devel+  ( loadSnapTH+  ) where++import           Control.Monad (liftM2)++import           Data.Char (isAlphaNum)+import           Data.List+import           Data.Maybe (maybeToList)+import           Data.Time.Clock (diffUTCTime, getCurrentTime)+import           Data.Typeable++import           Language.Haskell.Interpreter hiding (lift, liftIO, typeOf)+import           Language.Haskell.Interpreter.Unsafe++import           Language.Haskell.TH++import           System.Environment (getArgs)++------------------------------------------------------------------------------+import           Snap.Core+import           Snap.Loader.Devel.Signal+import           Snap.Loader.Devel.Evaluator+import           Snap.Loader.Devel.TreeWatcher++------------------------------------------------------------------------------+-- | This function derives all the information necessary to use the+-- interpreter from the compile-time environment, and compiles it in+-- to the generated code.+--+-- This could be considered a TH wrapper around a function+--+-- > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ()))+-- >                        -> [String] -> IO (a, Snap (), IO ())+--+-- with a magical implementation.  The [String] argument is a list of+-- directories to watch for updates to trigger a reloading.+-- Directories containing code should be automatically picked up by+-- this splice.+--+-- The generated splice executes the initialiser once, sets up the+-- interpreter for the load function, and returns the initializer's+-- result along with the interpreter's proxy handler and cleanup+-- actions.  The behavior of the proxy actions will change to reflect+-- changes in the watched files, reinterpreting the load function as+-- needed and applying it to the initializer result.+--+-- This will handle reloading the application successfully in most+-- cases.  The cases in which it is certain to fail are those+-- involving changing the types of the initializer or the load+-- function, or changing the compiler options required, such as by+-- changing/adding dependencies in the project's .cabal file.  In+-- those cases, a full recompile will be needed.+loadSnapTH :: Q Exp    -- ^ the initializer expression+           -> Name     -- ^ the name of the load function+           -> [String] -- ^ a list of directories to watch in addition+                       -- to those containing code+           -> Q Exp+loadSnapTH initializer action additionalWatchDirs = do+    args <- runIO getArgs++    let opts = getHintOpts args+        srcPaths = additionalWatchDirs ++ getSrcPaths args++    -- The first line is an extra type check to ensure the provided+    -- names refer to expressions with the correct types+    [| do let _ = $initializer >>= $(varE action)+          v <- $initializer+          (handler, cleanup) <- hintSnap opts actMods srcPaths loadStr v+          return (v, handler, cleanup) |]+  where+    actMods = maybeToList $ nameModule action+    loadStr = nameBase action+++------------------------------------------------------------------------------+-- | Convert the command-line arguments passed in to options for the+-- hint interpreter.  This is somewhat brittle code, based on a few+-- experimental datapoints regarding the structure of the command-line+-- arguments cabal produces.+getHintOpts :: [String] -> [String]+getHintOpts args = removeBad opts+  where+    bad = ["-threaded", "-O"]+    removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad)++    hideAll = filter (== "-hide-all-packages") args++    srcOpts = filter (\x -> "-i" `isPrefixOf` x+                            && not ("-idist" `isPrefixOf` x)) args++    toCopy = filter (not . isSuffixOf ".hs") $+             dropWhile (not . ("-package" `isPrefixOf`)) args+    copy = map (intercalate " ") . groupBy (\_ s -> not $ "-" `isPrefixOf` s)++    opts = hideAll ++ srcOpts ++ copy toCopy+++------------------------------------------------------------------------------+-- | This function extracts the source paths from the compilation args+getSrcPaths :: [String] -> [String]+getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg+  where+    srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x)+++------------------------------------------------------------------------------+-- | This function creates the Snap handler that actually is+-- responsible for doing the dynamic loading of actions via hint,+-- given all of the configuration information that the interpreter+-- needs.  It also ensures safe concurrent access to the interpreter,+-- and caches the interpreter results for a short time before allowing+-- it to run again.+--+-- Generally, this won't be called manually.  Instead, loadSnapTH will+-- generate a call to it at compile-time, calculating all the+-- arguments from its environment.+hintSnap :: Typeable a+         => [String] -- ^ A list of command-line options for the interpreter+         -> [String] -- ^ A list of modules that need to be+                     -- interpreted. This should contain only the+                     -- modules which contain the initialization,+                     -- cleanup, and handler actions.  Everything else+                     -- they require will be loaded transitively.+         -> [String] -- ^ A list of paths to watch for updates+         -> String   -- ^ The name of the function to load+         -> a        -- ^ The value to apply the loaded function to+         -> IO (Snap (), IO ())+hintSnap opts modules srcPaths action value =+    protectedHintEvaluator initialize test loader+  where+    witness x = undefined $ x `asTypeOf` value :: HintLoadable++    -- This is somewhat fragile, and probably can be cleaned up with a+    -- future version of Typeable.  For the moment, and+    -- backwards-compatibility, this is the approach being taken.+    witnessModules = map (reverse . drop 1 . dropWhile (/= '.') . reverse) .+                     filter (elem '.') . groupBy typePart . show . typeOf $+                     witness++    typePart x y = (isAlphaNum x && isAlphaNum  y) || x == '.' || y == '.'++    interpreter = do+        loadModules . nub $ modules+        setImports . nub $ "Prelude" : witnessModules ++ modules++        f <- interpret action witness+        return $ f value++    loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter++    formatOnError (Left err) = error $ format err+    formatOnError (Right a) = a++    loader = formatOnError `fmap` protectHandlers loadInterpreter++    initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths++    test (prevTime, ts) = do+        now <- getCurrentTime+        if diffUTCTime now prevTime < 3+            then return True+            else checkTreeStatus ts+++------------------------------------------------------------------------------+-- | Convert an InterpreterError to a String for presentation+format :: InterpreterError -> String+format (UnknownError e)   = "Unknown interpreter error:\r\n\r\n" ++ e+format (NotAllowed e)     = "Interpreter action not allowed:\r\n\r\n" ++ e+format (GhcException e)   = "GHC error:\r\n\r\n" ++ e+format (WontCompile errs) = "Compile errors:\r\n\r\n" +++    (intercalate "\r\n" $ nub $ map errMsg errs)+

@@ -0,0 +1,144 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Snap.Loader.Devel.Evaluator+  ( HintLoadable+  , protectedHintEvaluator+  ) where+++import Control.Exception+import Control.Monad (when)+import Control.Monad.Trans (liftIO)++import Control.Concurrent (ThreadId, forkIO, myThreadId)+import Control.Concurrent.MVar++import Prelude hiding (catch, init, any)++import Snap.Core (Snap)+++------------------------------------------------------------------------------+-- | A type synonym to simply talking about the type loaded by hint.+type HintLoadable = IO (Snap (), IO ())+++------------------------------------------------------------------------------+-- | Convert an action to generate 'HintLoadable's into Snap and IO+-- actions that handle periodic reloading.  The resulting action will+-- share initialized state until the next execution of the input+-- action.  At this time, the cleanup action will be executed.+--+-- The first two arguments control when recompiles are done.  The+-- first argument is an action that is executed when compilation+-- starts.  The second is a function from the result of the first+-- action to an action that determines whether the value from the+-- previous compilation is still good.  This abstracts out the+-- strategy for determining when a cached result is no longer valid.+--+-- If an exception is raised during the processing of the action, it+-- will be thrown to all waiting threads, and for all requests made+-- before the recompile condition is reached.+protectedHintEvaluator :: forall a.+                          IO a+                       -> (a -> IO Bool)+                       -> IO HintLoadable+                       -> IO (Snap (), IO ())+protectedHintEvaluator start test getInternals = do+    -- The list of requesters waiting for a result.  Contains the+    -- ThreadId in case of exceptions, and an empty MVar awaiting a+    -- successful result.+    readerContainer <- newReaderContainer++    -- Contains the previous result and initialization value, and the+    -- time it was stored, if a previous result has been computed.+    -- The result stored is either the actual result and+    -- initialization result, or the exception thrown by the+    -- calculation.+    resultContainer <- newResultContainer++    -- The model used for the above MVars in the returned action is+    -- "keep them full, unless updating them."  In every case, when+    -- one of those MVars is emptied, the next action is to fill that+    -- same MVar.  This makes deadlocking on MVar wait impossible.+    let snap = do+            let waitForNewResult :: IO (Snap ())+                waitForNewResult = do+                    -- Need to calculate a new result+                    tid <- myThreadId+                    reader <- newEmptyMVar++                    readers <- takeMVar readerContainer++                    -- Some strictness is employed to ensure the MVar+                    -- isn't holding on to a chain of unevaluated thunks.+                    let pair = (tid, reader)+                        newReaders = readers `seq` pair `seq` (pair : readers)+                    putMVar readerContainer $! newReaders++                    -- If this is the first reader to queue, clean up the+                    -- previous state, if there was any, and then begin+                    -- evaluation of the new code and state.+                    when (null readers) $ do+                        let runAndFill = block $ do+                                -- run the cleanup action+                                previous <- readMVar resultContainer+                                unblock $ cleanup previous++                                -- compile the new internals and initialize+                                stateInitializer <- unblock getInternals+                                res <- unblock stateInitializer++                                let a = fst res++                                clearAndNotify (Right res)+                                               (flip putMVar a . snd)++                            killWaiting :: SomeException -> IO ()+                            killWaiting e = block $ do+                                clearAndNotify (Left e) (flip throwTo e . fst)+                                throwIO e++                            clearAndNotify r f = do+                                a <- unblock start+                                _ <- swapMVar resultContainer $ Just (r, a)+                                allReaders <- swapMVar readerContainer []+                                mapM_ f allReaders++                        _ <- forkIO $ runAndFill `catch` killWaiting+                        return ()++                    -- Wait for the evaluation of the action to complete,+                    -- and return its result.+                    takeMVar reader++            existingResult <- liftIO $ readMVar resultContainer++            getResult <- liftIO $ case existingResult of+                Just (res, a) -> do+                    -- There's an existing result.  Check for validity+                    valid <- test a+                    case (valid, res) of+                        (True, Right (x, _)) -> return x+                        (True, Left e)       -> throwIO e+                        (False, _)           -> waitForNewResult+                Nothing -> waitForNewResult+            getResult++        clean = do+             let msg = "invalid dynamic loader state.  " +++                       "The cleanup action has been executed"+             contents <- swapMVar resultContainer $ error msg+             cleanup contents++    return (snap, clean)+  where+    newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))])+    newReaderContainer = newMVar []++    newResultContainer :: IO (MVar (Maybe (Either SomeException+                                                  (Snap (), IO ()), a)))+    newResultContainer = newMVar Nothing++    cleanup (Just (Right (_, clean), _)) = clean+    cleanup _                            = return ()

@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+module Snap.Loader.Devel.Signal (protectHandlers) where++import Control.Exception (bracket)++#ifdef mingw32_HOST_OS+import GHC.ConsoleHandler as C+++saveHandlers :: IO C.Handler+saveHandlers = C.installHandler Ignore+++restoreHandlers :: C.Handler -> IO C.Handler+restoreHandlers = C.installHandler+++#else+import qualified System.Posix.Signals as S++helper :: S.Handler -> S.Signal -> IO S.Handler+helper handler signal = S.installHandler signal handler Nothing+++signals :: [S.Signal]+signals = [ S.sigQUIT+          , S.sigINT+          , S.sigHUP+          , S.sigTERM+          ]+++saveHandlers :: IO [S.Handler]+saveHandlers = mapM (helper S.Ignore) signals+++restoreHandlers :: [S.Handler] -> IO [S.Handler]+restoreHandlers h = sequence $ zipWith helper h signals+++#endif+protectHandlers :: IO a -> IO a+protectHandlers a = bracket saveHandlers restoreHandlers $ const a

@@ -0,0 +1,41 @@+module Snap.Loader.Devel.TreeWatcher+    ( TreeStatus+    , getTreeStatus+    , checkTreeStatus+    ) where++import Control.Applicative++import System.Directory+import System.Directory.Tree++import System.Time+++------------------------------------------------------------------------------+-- | An opaque representation of the contents and last modification+-- times of a forest of directory trees.+data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime]+++------------------------------------------------------------------------------+-- | Create a 'TreeStatus' for later checking with 'checkTreeStatus'+getTreeStatus :: [FilePath] -> IO TreeStatus+getTreeStatus = liftA2 (<$>) TS readModificationTimes+++------------------------------------------------------------------------------+-- | Checks that all the files present in the initial set of paths are+-- the exact set of files currently present, with unchanged modifcations times+checkTreeStatus :: TreeStatus -> IO Bool+checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths+  where+    check = and . zipWith (==) entries+++------------------------------------------------------------------------------+-- | This is the core of the functions in this module.  It converts a+-- list of filepaths into a list of 'AnchoredDirTree' annotated with+-- the modification times of the files located in those paths.+readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime]+readModificationTimes = mapM $ readDirectoryWith getModificationTime

@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell #-}+module Snap.Loader.Prod+  ( loadSnapTH+  ) where++import           Language.Haskell.TH+++------------------------------------------------------------------------------+-- | This function provides a non-magical type-compatible loader for+-- the one in Snap.Loader.Devel, allowing switching one import to+-- provide production-mode compilation.+--+-- This could be considered a TH wrapper around a function+--+-- > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ()))+-- >                        -> [String] -> IO (a, Snap (), IO ())+--+-- The third argument is unused, and only present for+-- type-compatibility with Snap.Loader.Devel+loadSnapTH :: Q Exp -> Name -> [String] -> Q Exp+loadSnapTH initializer action _additionalWatchDirs =+    [| do value <- $initializer+          (site, conf) <- $(varE action) value+          return (value, site, conf) |]

@@ -0,0 +1,330 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE TypeOperators              #-}++{-|++Snaplets allow you to build web applications out of composable parts. This+allows you to build self-contained units and glue them together to make your+overall application.++A snaplet has a few moving parts, some user-defined and some provided by the+snaplet API:++  * each snaplet has its own configuration given to it at startup.++  * each snaplet is given its own directory on the filesystem, from which it+    reads its configuration and in which it can store files.++  * each snaplet comes with an 'Initializer' which defines how to create an+    instance of the Snaplet at startup. The initializer decides how to+    interpret the snaplet configuration, which URLs to handle (and how), sets+    up the initial snaplet state, tells the snaplet runtime system how to+    clean the snaplet up, etc.++  * each snaplet contains some user-defined in-memory state; for instance, a+    snaplet that talks to a database might contain a reference to a connection+    pool. The snaplet state is an ordinary Haskell record, with a datatype+    defined by the snaplet author. The initial state record is created during+    initialization and is available to snaplet 'Handler's when serving HTTP+    requests.++NOTE: This documentation is written as a prose tutorial of the snaplets+API.  Don't be scared by the fact that it's auto-generated and is filled with+type signatures.  Just keep reading.++-}++module Snap.Snaplet+  (+  -- * Snaplet+  -- $snapletDoc+    Snaplet+  , SnapletConfig++  -- * Snaplet Helper Functions+  -- $snapletHelpers+  , snapletConfig+  , snapletValue+  , subSnaplet++  -- * Lenses+  -- $lenses++  -- * MonadSnaplet+  -- $monadSnaplet+  , MonadSnaplet(..)+  , getSnapletAncestry+  , getSnapletFilePath+  , getSnapletName+  , getSnapletDescription+  , getSnapletUserConfig+  , getSnapletRootURL++  -- * Snaplet state manipulation+  -- $snapletState+  , getSnapletState+  , putSnapletState+  , modifySnapletState+  , getsSnapletState++--  , wrap+--  , wrapTop++  -- * Initializer+  -- $initializer+  , Initializer+  , SnapletInit+  , makeSnaplet++  , nestSnaplet+  , embedSnaplet+  , nameSnaplet++  , onUnload+  , addPostInitHook+  , addPostInitHookBase+  , printInfo++  -- * Routes+  -- $routes+  , addRoutes+  , wrapHandlers++  -- * Handlers+  , Handler+  , reloadSite++  -- * Serving Applications+  , runSnaplet+  , combineConfig+  , serveSnaplet+  ) where+++import           Snap.Snaplet.Internal.Initializer+import           Snap.Snaplet.Internal.Types++-- $snapletDoc+-- The heart of the snaplets infrastructure is state management. (Note: when+-- we say \"state\" here, we mean in-memory Haskell objects, not external data+-- storage or databases; how you deal with persisted data is up to you.) Most+-- nontrivial pieces of a web application need some kind of runtime state or+-- environment data. The datatype we use to handle this is called 'Snaplet':++-- $snapletHelpers+--+-- Your web application will itself get wrapped in a 'Snaplet', and the+-- top-level user state of your application (which will likely contain other+-- snaplets nested inside it) will look something like this:+--+-- > data App = App+-- >     { _foo                :: Snaplet Foo+-- >     , _bar                :: Snaplet Bar+-- >     , _someNonSnapletData :: String+-- >     }+--+-- Every web application using snaplets has a top-most user state which+-- contains all of the application state; we call this state the \"base\"+-- state.+--+-- We provide a couple of helper functions for working with Snaplet types.++-- $lenses+-- In the example above, the @Foo@ snaplet has to be written to work with any+-- base state (otherwise it wouldn't be reusable!), but functions written to+-- work with the @Foo@ snaplet want to be able to modify the @Foo@ record+-- /within the context/ of the base state. Given that Haskell datatypes are+-- pure, how do you allow for this?+--+-- Our solution is to use /lenses/, as defined in the @data-lens@ library+-- (<http://hackage.haskell.org/package/data-lens>). A lens, notated as+-- follows:+--+-- > Lens a b+--+-- is a \"getter\" and a \"setter\" rolled up into one. The @data-lens@+-- library provides the following functions:+--+-- > getL :: (Lens a b) -> a -> b+-- > setL :: (Lens a b) -> b -> a -> a+-- > modL :: (Lens a b) -> (b -> b) -> a -> a+--+-- which allow you to get, set, and modify a value of type @b@ within the+-- context of type of type @a@. The @data-lens@ package comes with a Template+-- Haskell function called 'makeLenses', which auto-magically defines a lens+-- for every record field having a name beginning with an underscore. In the+-- @App@ example above, adding the declaration:+--+-- > makeLenses [''App]+--+-- would define lenses:+--+-- > foo                :: Lens App (Snaplet Foo)+-- > bar                :: Lens App (Snaplet Bar)+-- > someNonSnapletData :: Lens App String+--+-- The coolest thing about @data-lens@ lenses is that they /compose/, using+-- the "Control.Category"'s generalization of the @(.)@ operator. If the @Foo@+-- type had a field of type @Quux@ within it with a lens @quux :: Lens Foo+-- Quux@, then you could create a lens of type @Lens App Quux@ by composition:+--+-- > import Control.Category+-- > import Prelude hiding ((.))    -- you have to hide (.) from the Prelude+-- >                                -- to use Control.Category.(.)+-- >+-- > data Foo = Foo { _quux :: Quux }+-- > makeLenses [''Foo]+-- >+-- > -- snapletValue is defined in the framework:+-- > snapletValue :: Lens (Snaplet a) a+-- >+-- > appQuuxLens :: Lens App (Snaplet Quux)+-- > appQuuxLens = quux . snapletValue . foo+--+-- Lens composition is very similar to function composition, but it gives you+-- a composed getter and setter at the same time.++-- $monadSnaplet+-- The primary abstraction in the snaplet infrastructure is a combination of+-- the reader and state monads.  The state monad holds the top level+-- application data type (from now on referred to as the base state).  The+-- reader monad holds a lens from the base state to the current snaplet's+-- state.  This allows quux snaplet functions to access and modify the Quux+-- data structure without knowing anything about the App or Foo data+-- structures. It also lets other snaplets call functions from the quux+-- snaplet if they have the quux snaplet's lens @Lens App (Snaplet Quux)@.+-- We can view our application as a tree of snaplets and other pieces of data.+-- The lenses are like pointers to nodes of the tree. If you have a pointer to+-- a node, you can access the node and all of its children without knowing+-- anything about the rest of the tree.+--+-- Several monads use this infrastructure. These monads need at least three+-- type parameters. Two for the lens type, and the standard \'a\' denoting the+-- monad return value. You will usually see this written in type signatures as+-- \"m b v a\" or some variation. The \'m\' is the type variable of the+-- MonadSnaplet type class. \'b\' is the base state, and \'v\' is the state of+-- the current \"view\" snaplet (or simply, current state).+--+-- The MonadSnaplet type class distills the essence of the operations used+-- with this pattern.  Its functions define fundamental methods for navigating+-- snaplet trees.++-- $snapletState+-- MonadSnaplet instances will typically have @MonadState v@ instances.  We+-- provide the following convenience functions which give the equivalent to+-- @MonadState (Snaplet v)@ for the less common cases where you need to work+-- with the Snaplet wrapper.++-- $initializer+-- The Initializer monad is where your application's initialization happens.+-- Initializers are run at startup and any time a site reload is triggered.+-- The Initializer's job is to construct a snaplet's routes and initial state,+-- set up filesystem data, read config files, etc.+--+-- In order to initialize its state, a snaplet needs to initialize all the+-- @Snaplet a@ state for each of its subsnaplets.  The only way to construct+-- a @Snaplet a@ type is by calling 'nestSnaplet' or 'embedSnaplet' from+-- within an initializer.+++-- $writingSnaplets+-- When writing a snaplet, you must define an initializer function.  The+-- initializer function for the Foo snaplet (where Foo is the snaplet's+-- state type) must have a return type of @Initializer b Foo Foo@.+-- To create an initializer like this, you have to use the 'makeSnaplet'+-- function.  It takes care of the necessary internal bookkeeping needed when+-- initializing a new snaplet.  Haskell's strong type system allows us to+-- ensure that calling 'makeSnaplet' is the only way you can construct a+-- Snaplet type.+++-- $routes+-- Snaplet initializers are also responsible for setting up any routes defined+-- by the snaplet.  To do that you'll usually use either 'addRoutes' or+-- 'wrapHandlers'.+++{-+++/FIXME/: finish this section+++Discuss:++  * lenses and how snaplet apps are built out of parts.++  * the initializer type, and what you can do with it++  * layout of snaplets on disk, and how on-disk stuff can be auto-populated+    from the cabal data directory++  * the handler type, and what you can do with it+++++{FIXME: strike/rewrite these sentences. Components that do not need any kind+of state or environment are probably more appropriate as a standalone+library than as a snaplet.++We start our application by defining a data structure to hold the state.+This data structure includes the state of any snaplets (wrapped in a+Snaplet) we want to use as well as any other state we might want.}++> module MyApp where+> import Snap.Snaplet+> import Snap.Snaplet.Heist+>+> data App = App+>     { _heist       :: Snaplet (Heist App)+>     , _foo         :: Snaplet Foo+>     , _bar         :: Snaplet Bar+>     , _companyName :: String+>     }+>+> makeLenses [''App]++The next thing we need to do is define an initializer.++> app :: Initializer App App App+> app = do+>     hs <- nestSnaplet "heist" $ heistInit "templates"+>     fs <- nestSnaplet "foo" $ fooInit heist+>     bs <- nestSnaplet "" $ nameSnaplet "baz" $ barInit heist+>     addRoutes [ ("/hello", writeText "hello world")+>               ]+>     wrapHandlers (<|> with heist heistServe)+>     return $ App hs fs bs "fooCorp"++Then we define a simple main to run the application.++> main = serveSnaplet defaultConfig app++++Snaplet filesystem directory structure:++> snaplet+>   |-- snaplet.cabal+>   |-- log/+>   |-- src/+> ------------------------+>   |-- db.cfg+>   |-- snaplet.cfg+>   |-- public/+>       |-- stylesheets/+>       |-- images/+>       |-- js/+>   |-- snaplets+>       |-- subsnaplet1/+>       |-- subsnaplet2/+>   |-- templates/++-}+

@@ -0,0 +1,74 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}++{-|++  This module contains all the central authentication functionality.++  It exports a number of high-level functions to be used directly in your+  application handlers.++  We also export a number of mid-level functions that+  should be helpful when you are integrating with another way of confirming+  the authentication of login requests.++-}++module Snap.Snaplet.Auth+  (++  -- * Higher Level Handler Functions+    createUser+  , usernameExists+  , saveUser+  , destroyUser+  , loginByUsername+  , loginByRememberToken+  , forceLogin+  , logout+  , currentUser+  , isLoggedIn++  -- * Lower Level Functions+  , markAuthSuccess+  , markAuthFail+  , checkPasswordAndLogin++  -- * Types+  , AuthManager(..)+  , IAuthBackend(..)+  , AuthSettings(..)+  , defAuthSettings+  , AuthUser(..)+  , defAuthUser+  , UserId(..)+  , Password(..)+  , AuthFailure(..)+  , BackendError(..)+  , Role(..)++  -- * Other Utilities+  , withBackend+  , encryptPassword+  , checkPassword+  , authenticatePassword+  , setPassword++  -- * Handlers+  , registerUser+  , loginUser+  , logoutUser+  , requireUser++  -- * Splice helpers+  , addAuthSplices+  , ifLoggedIn+  , ifLoggedOut+  )+  where++import Snap.Snaplet.Auth.AuthManager+import Snap.Snaplet.Auth.Handlers+import Snap.Snaplet.Auth.SpliceHelpers+import Snap.Snaplet.Auth.Types+

@@ -0,0 +1,102 @@++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.Auth.AuthManager++(+  -- * AuthManager Datatype+    AuthManager(..)++  -- * Backend Typeclass+  , IAuthBackend(..)++  -- * Context-free Operations+  , buildAuthUser++) where+++import           Data.ByteString (ByteString)+import           Data.Lens.Lazy+import           Data.Time+import           Data.Text (Text)+import           Web.ClientSession++import           Snap.Snaplet+import           Snap.Snaplet.Session+import           Snap.Snaplet.Auth.Types++------------------------------------------------------------------------------+-- | Create a new user from just a username and password+--+-- May throw a "DuplicateLogin" if given username is not unique+buildAuthUser+  :: (IAuthBackend r)+  => r+  -- ^ An auth backend+  -> Text+  -- ^ Username+  -> ByteString+  -- ^ Password+  -> IO AuthUser+buildAuthUser r unm pass = do+  now <- getCurrentTime+  let au = defAuthUser {+              userLogin = unm+            , userPassword = Nothing+            , userCreatedAt = Just now+            , userUpdatedAt = Just now+            }+  au' <- setPassword au pass+  save r au'+++------------------------------------------------------------------------------+-- | All storage backends need to implement this typeclass+--+-- Backend operations may throw 'BackendError's+class IAuthBackend r where++  -- | Needs to create or update the given 'AuthUser' record+  save :: r -> AuthUser -> IO AuthUser++  lookupByUserId :: r -> UserId -> IO (Maybe AuthUser)++  lookupByLogin :: r -> Text -> IO (Maybe AuthUser)++  lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser)++  destroy :: r -> AuthUser -> IO ()+++------------------------------------------------------------------------------+-- | Abstract data type holding all necessary information for auth operation+data AuthManager b = forall r. IAuthBackend r => AuthManager {+    backend :: r+  -- ^ Storage back-end++  , session :: Lens b (Snaplet SessionManager)+  -- ^ A lens pointer to a SessionManager++  , activeUser :: Maybe AuthUser+  -- ^ A per-request logged-in user cache++  , minPasswdLen :: Int+  -- ^ Password length range++  , rememberCookieName :: ByteString+  -- ^ Cookie name for the remember token++  , rememberPeriod :: Maybe Int+  -- ^ Remember period in seconds. Defaults to 2 weeks.++  , siteKey :: Key+  -- ^ A unique encryption key used to encrypt remember cookie++  , lockout :: Maybe (Int, NominalDiffTime)+  -- ^ Lockout after x tries, re-allow entry after y seconds+  }+

@@ -0,0 +1,335 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+++module Snap.Snaplet.Auth.Backends.JsonFile+  ( initJsonFileAuthManager+  , mkJsonAuthMgr+  ) where+++import           Control.Applicative+import           Control.Monad.CatchIO (throw)+import           Control.Monad.State+import           Control.Concurrent.STM+import           Data.Aeson+import qualified Data.Attoparsec as Atto+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString as B+import qualified Data.Map as HM+import           Data.Map (Map)+import           Data.Maybe (fromJust, isJust)+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Lens.Lazy+import           Data.Time+import           Web.ClientSession+import           System.Directory++import           Snap.Snaplet+import           Snap.Snaplet.Auth.Types+import           Snap.Snaplet.Auth.AuthManager+import           Snap.Snaplet.Session++++------------------------------------------------------------------------------+-- | Initialize a JSON file backed 'AuthManager'+initJsonFileAuthManager+  :: AuthSettings+  -- ^ Authentication settings for your app+  -> Lens b (Snaplet SessionManager)+  -- ^ Lens into a 'SessionManager' auth snaplet will use+  -> FilePath+  -- ^ Where to store user data as JSON+  -> SnapletInit b (AuthManager b)+initJsonFileAuthManager s l db =+  makeSnaplet "JsonFileAuthManager"+      "A snaplet providing user authentication using a JSON-file backend"+      Nothing $ liftIO $ do+    key <- getKey (asSiteKey s)+    jsonMgr <- mkJsonAuthMgr db+    return $ AuthManager {+        backend = jsonMgr+      , session = l+      , activeUser = Nothing+      , minPasswdLen = asMinPasswdLen s+      , rememberCookieName = asRememberCookieName s+      , rememberPeriod = asRememberPeriod s+      , siteKey = key+      , lockout = asLockout s+    }+++------------------------------------------------------------------------------+-- | Load/create a datafile into memory cache and return the manager.+--+-- This data type can be used by itself for batch/non-handler processing.+mkJsonAuthMgr :: FilePath -> IO JsonFileAuthManager+mkJsonAuthMgr fp = do+  db <- loadUserCache fp+  let db' = case db of+              Left e -> error e+              Right x -> x+  cache <- newTVarIO db'+  return $ JsonFileAuthManager {+      memcache = cache+    , dbfile = fp+  }+++type UserIdCache = Map UserId AuthUser+++instance ToJSON UserIdCache where+  toJSON m = toJSON $ HM.toList m+++instance FromJSON UserIdCache where+  parseJSON = fmap HM.fromList . parseJSON+++type LoginUserCache = Map Text UserId+++type RemTokenUserCache = Map Text UserId+++-- JSON user back-end stores the user data and indexes for login and token+-- based logins.+data UserCache = UserCache {+    uidCache    :: UserIdCache          -- the actual datastore+  , loginCache  :: LoginUserCache       -- fast lookup for login field+  , tokenCache  :: RemTokenUserCache    -- fast lookup for remember tokens+  , uidCounter  :: Int                  -- user id counter+}+++defUserCache :: UserCache+defUserCache = UserCache {+    uidCache = HM.empty+  , loginCache = HM.empty+  , tokenCache = HM.empty+  , uidCounter = 0+}+++loadUserCache :: FilePath -> IO (Either String UserCache)+loadUserCache fp = do+  chk <- doesFileExist fp+  case chk of+    True -> do+      d <- B.readFile fp+      case Atto.parseOnly json d of+        Left e -> return . Left $ "Can't open JSON auth backend. Error: " ++ e+        Right v -> case fromJSON v of+          Error e -> return . Left $+              "Malformed JSON auth data store. Error: " ++ e+          Success db -> return $ Right db+    False -> do+      putStrLn "User JSON datafile not found. Creating a new one."+      return $ Right defUserCache+++data JsonFileAuthManager = JsonFileAuthManager {+    memcache :: TVar UserCache+  , dbfile :: FilePath+}+++instance IAuthBackend JsonFileAuthManager where++  save mgr u = do+    now <- getCurrentTime+    oldByLogin <- lookupByLogin mgr (userLogin u)+    oldById <- case userId u of+      Nothing -> return Nothing+      Just x -> lookupByUserId mgr x+    res <- atomically $ do+      cache <- readTVar (memcache mgr)+      res <- case userId u of+        Nothing -> create cache now oldByLogin+        Just _ -> update cache now oldById+      case res of+        Left e -> return $ Left e+        Right (cache', u') -> do+          writeTVar (memcache mgr) cache'+          return $ Right (cache', u')+    case res of+      Left e -> throw e+      Right (cache', u') -> do+        dumpToDisk cache'+        return u'+    where+      create+        :: UserCache+        -> UTCTime+        -> (Maybe AuthUser)+        -> STM (Either BackendError (UserCache, AuthUser))+      create cache now old = do+        case old of+          Just _ -> return $ Left DuplicateLogin+          Nothing -> do+            new <- do+              let uid' = UserId . showT $ uidCounter cache + 1+              let u' = u { userUpdatedAt = Just now, userId = Just uid' }+              return $ cache {+                uidCache = HM.insert uid' u' $ uidCache cache+              , loginCache = HM.insert (userLogin u') uid' $ loginCache cache+              , tokenCache = case userRememberToken u' of+                                Nothing -> tokenCache cache+                                Just x -> HM.insert x uid' $ tokenCache cache+              , uidCounter = uidCounter cache + 1+              }+            return $ Right (new, getLastUser new)+++      -- lookup old record, see what's changed and update indexes accordingly+      update+        :: UserCache+        -> UTCTime+        -> (Maybe AuthUser)+        -> STM (Either BackendError (UserCache, AuthUser))+      update cache now old =+        case old of+          Nothing -> return $ Left $+                       BackendError "User not found; should never happen"+          Just x -> do+            let oldLogin = userLogin x+            let oldToken = userRememberToken x+            let uid = fromJust $ userId u+            let newLogin = userLogin u+            let newToken = userRememberToken u+            let lc = if oldLogin /= userLogin u+                      then HM.insert newLogin uid . HM.delete oldLogin $+                               loginCache cache+                      else loginCache cache+            let tc = if oldToken /= newToken && isJust oldToken+                      then HM.delete (fromJust oldToken) $ loginCache cache+                      else tokenCache cache+            let tc' = case newToken of+                        Just t -> HM.insert t uid tc+                        Nothing -> tc+            let u' = u { userUpdatedAt = Just now }+            let new = cache {+                          uidCache = HM.insert uid u' $ uidCache cache+                        , loginCache = lc+                        , tokenCache = tc'+                      }+            return $ Right (new, u')++      -- Sync user database to disk+      -- Need to implement a mutex here; simult syncs could screw things up+      dumpToDisk c = LB.writeFile (dbfile mgr) (encode c)++      -- Get's the last added user+      getLastUser cache = maybe e id $ getUser cache uid+        where uid = UserId . showT $ uidCounter cache+              e = error "getLastUser failed. This should not happen."+++  destroy = error "JsonFile: destroy is not yet implemented"++  lookupByUserId mgr uid = withCache mgr f+    where f cache = getUser cache uid++  lookupByLogin mgr login = withCache mgr f+    where+      f cache = getUid >>= getUser cache+        where getUid = HM.lookup login (loginCache cache)++  lookupByRememberToken mgr token = withCache mgr f+    where+      f cache = getUid >>= getUser cache+        where getUid = HM.lookup token (tokenCache cache)+++withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a+withCache mgr f = atomically $ do+  cache <- readTVar $ memcache mgr+  return $ f cache+++getUser :: UserCache -> UserId -> Maybe AuthUser+getUser cache uid = HM.lookup uid (uidCache cache)+++------------------------------------------------------------------------------+-- JSON Instances+--+------------------------------------------------------------------------------+++instance ToJSON UserCache where+  toJSON uc = object+    [ "uidCache"   .= uidCache uc+    , "loginCache" .= loginCache uc+    , "tokenCache" .= tokenCache uc+    , "uidCounter" .= uidCounter uc]+++instance FromJSON UserCache where+  parseJSON (Object v) =+    UserCache+      <$> v .: "uidCache"+      <*> v .: "loginCache"+      <*> v .: "tokenCache"+      <*> v .: "uidCounter"+  parseJSON _ = error "Unexpected JSON input"++instance ToJSON AuthUser where+  toJSON u = object+    [ "uid" .= userId u+    , "login" .= userLogin u+    , "pw" .= userPassword u+    , "activated_at" .= userActivatedAt u+    , "suspended_at" .= userSuspendedAt u+    , "remember_token" .= userRememberToken u+    , "login_count" .= userLoginCount u+    , "failed_login_count" .= userFailedLoginCount u+    , "locked_until" .= userLockedOutUntil u+    , "current_login_at" .= userCurrentLoginAt u+    , "last_login_at" .= userLastLoginAt u+    , "current_ip" .= userCurrentLoginIp u+    , "last_ip" .= userLastLoginIp u+    , "created_at" .= userCreatedAt u+    , "updated_at" .= userUpdatedAt u+    , "meta" .= userMeta u ]+++instance FromJSON AuthUser where+  parseJSON (Object v) = AuthUser+    <$> v .: "uid"+    <*> v .: "login"+    <*> v .: "pw"+    <*> v .: "activated_at"+    <*> v .: "suspended_at"+    <*> v .: "remember_token"+    <*> v .: "login_count"+    <*> v .: "failed_login_count"+    <*> v .: "locked_until"+    <*> v .: "current_login_at"+    <*> v .: "last_login_at"+    <*> v .: "current_ip"+    <*> v .: "last_ip"+    <*> v .: "created_at"+    <*> v .: "updated_at"+    <*> return []+    <*> v .: "meta"+  parseJSON _ = error "Unexpected JSON input"+++instance ToJSON Password where+  toJSON (Encrypted x) = toJSON x+  toJSON (ClearText _) =+      error "ClearText passwords can't be serialized into JSON"+++instance FromJSON Password where+  parseJSON = fmap Encrypted . parseJSON+++showT :: Int -> Text+showT = T.pack . show

@@ -0,0 +1,437 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++{-|++  Pre-packaged Handlers that deal with form submissions and standard use-cases+  involving authentication.++-}++module Snap.Snaplet.Auth.Handlers where++import           Control.Applicative+import           Control.Monad.CatchIO (throw)+import           Control.Monad.State+import           Data.ByteString (ByteString)+import           Data.Lens.Lazy+import           Data.Maybe (isJust)+import           Data.Serialize hiding (get)+import           Data.Time+import           Data.Text.Encoding (decodeUtf8)+import           Data.Text (Text)+import           Web.ClientSession++import           Snap.Core+import           Snap.Snaplet+import           Snap.Snaplet.Auth.AuthManager+import           Snap.Snaplet.Auth.Types+import           Snap.Snaplet.Session+import           Snap.Snaplet.Session.Common+import           Snap.Snaplet.Session.SecureCookie++++------------------------------------------------------------------------------+-- Higher level functions+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Create a new user from just a username and password+--+-- May throw a "DuplicateLogin" if given username is not unique+createUser+  :: Text -- Username+  -> ByteString -- Password+  -> Handler b (AuthManager b) AuthUser+createUser unm pwd = withBackend (\r -> liftIO $ buildAuthUser r unm pwd)++------------------------------------------------------------------------------+-- | Check whether a user with the given username exists.+usernameExists+  :: Text+  -- ^ The username to be checked+  -> Handler b (AuthManager b) Bool+usernameExists username = withBackend $+    \r -> liftIO $ isJust <$> lookupByLogin r username++------------------------------------------------------------------------------+-- | Lookup a user by her username, check given password and perform login+loginByUsername+  :: ByteString       -- ^ Username/login for user+  -> Password         -- ^ Should be ClearText+  -> Bool             -- ^ Set remember token?+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+loginByUsername _ (Encrypted _) _ =+  error "Cannot login with encrypted password"+loginByUsername unm pwd rm = do+  sk <- gets siteKey+  cn <- gets rememberCookieName+  rp <- gets rememberPeriod+  withBackend $ loginByUsername' sk cn rp+  where+    loginByUsername' :: (IAuthBackend t)+                     => Key -> ByteString -> Maybe Int -> t+                     -> Handler b (AuthManager b)+                                (Either AuthFailure AuthUser)+    loginByUsername' sk cn rp r = do+      au <- liftIO $ lookupByLogin r (decodeUtf8 unm)+      case au of+        Nothing  -> return $ Left UserNotFound+        Just au' -> do+          res <- checkPasswordAndLogin au' pwd+          case res of+            Left e -> return $ Left e+            Right au'' -> do+              case rm of+                True -> do+                  token <- liftIO $ randomToken 64+                  setRememberToken sk cn rp token+                  let au''' = au''+                          { userRememberToken = Just (decodeUtf8 token) }+                  saveUser au'''+                  return $ Right au'''+                False -> return $ Right au''+++------------------------------------------------------------------------------+-- | Remember user from the remember token if possible and perform login+loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)+loginByRememberToken = withBackend $ \r -> do+  sk <- gets siteKey+  rc <- gets rememberCookieName+  rp <- gets rememberPeriod+  token <- getRememberToken sk rc rp+  au <- maybe (return Nothing)+              (liftIO . lookupByRememberToken r . decodeUtf8) token+  case au of+    Just au' -> forceLogin au' >> return au+    Nothing -> return Nothing+++------------------------------------------------------------------------------+-- | Logout the active user+logout :: Handler b (AuthManager b) ()+logout = do+  s <- gets session+  withTop s $ withSession s removeSessionUserId+  rc <- gets rememberCookieName+  forgetRememberToken rc+  modify (\mgr -> mgr { activeUser = Nothing } )+++------------------------------------------------------------------------------+-- | Return the current user; trying to remember from cookie if possible.+currentUser :: Handler b (AuthManager b) (Maybe AuthUser)+currentUser = cacheOrLookup $ withBackend $ \r -> do+  s <- gets session+  uid <- withTop s getSessionUserId+  case uid of+    Nothing -> loginByRememberToken+    Just uid' -> liftIO $ lookupByUserId r uid'+++------------------------------------------------------------------------------+-- | Convenience wrapper around 'rememberUser' that returns a bool result+isLoggedIn :: Handler b (AuthManager b) Bool+isLoggedIn = isJust `fmap` currentUser+++------------------------------------------------------------------------------+-- | Create or update a given user+--+-- May throw a 'BackendError' if something goes wrong.+saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser+saveUser u = withBackend $ liftIO . flip save u+++------------------------------------------------------------------------------+-- | Destroy the given user+--+-- May throw a 'BackendError' if something goes wrong.+destroyUser :: AuthUser -> Handler b (AuthManager b) ()+destroyUser u = withBackend $ liftIO . flip destroy u+++------------------------------------------------------------------------------+--  Lower level helper functions+--+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Mutate an 'AuthUser', marking failed authentication+--+-- This will save the user to the backend.+markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser+markAuthFail u = withBackend $ \r -> do+  lo <- gets lockout+  incFailCtr u >>= checkLockout lo >>= liftIO . save r+  where+    incFailCtr u' = return $ u'+                      { userFailedLoginCount = userFailedLoginCount u' + 1}+    checkLockout lo u' = case lo of+      Nothing          -> return u'+      Just (mx, wait)  ->+        if userFailedLoginCount u' >= mx+          then do+            now <- liftIO getCurrentTime+            let reopen = addUTCTime wait now+            return $ u' { userLockedOutUntil = Just reopen }+          else return u'+++------------------------------------------------------------------------------+-- | Mutate an 'AuthUser', marking successful authentication+--+-- This will save the user to the backend.+markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser+markAuthSuccess u = withBackend $ \r -> do+  incLoginCtr u >>= updateIp >>= updateLoginTS+    >>= resetFailCtr >>= liftIO . save r+  where+    incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }+    updateIp u' = do+      ip <- rqRemoteAddr `fmap` getRequest+      return $ u' { userLastLoginIp = userCurrentLoginIp u'+                  , userCurrentLoginIp = Just ip }+    updateLoginTS u' = do+      now <- liftIO getCurrentTime+      return $+        u' { userCurrentLoginAt = Just now+           , userLastLoginAt = userCurrentLoginAt u' }+    resetFailCtr u' = return $+      u' { userFailedLoginCount = 0+         , userLockedOutUntil = Nothing }+++------------------------------------------------------------------------------+-- | Authenticate and log the user into the current session if successful.+--+-- This is a mid-level function exposed to allow roll-your-own ways of looking+-- up a user from the database.+--+-- This function will:+--+-- 1. Check the password+--+-- 2. Login the user into the current session+--+-- 3. Mark success/failure of the authentication trial on the user record+checkPasswordAndLogin+  :: AuthUser               -- ^ An existing user, somehow looked up from db+  -> Password               -- ^ A ClearText password+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+checkPasswordAndLogin u pw =+  case userLockedOutUntil u of+    Just x -> do+      now <- liftIO getCurrentTime+      if now > x+        then auth u+        else return . Left $ LockedOut x+    Nothing -> auth u+  where+    auth user =+      case authenticatePassword user pw of+        Just e -> do+          markAuthFail user+          return $ Left e+        Nothing -> do+          forceLogin user+          modify (\mgr -> mgr { activeUser = Just user })+          user' <- markAuthSuccess user+          return $ Right user'+++------------------------------------------------------------------------------+-- | Login and persist the given 'AuthUser' in the active session+--+-- Meant to be used if you have other means of being sure that the person is+-- who she says she is.+forceLogin+  :: AuthUser+  -- ^ An existing user, somehow looked up from db+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+forceLogin u = do+  s <- gets session+  withSession s $ do+    case userId u of+      Just x -> do+        withTop s (setSessionUserId x)+        return $ Right u+      Nothing -> return . Left $+        AuthError "forceLogin: Can't force the login of a user without userId"+++------------------------------------------------------------------------------+-- Internal, non-exported helpers+--+------------------------------------------------------------------------------+++getRememberToken :: (Serialize t, MonadSnap m)+                 => Key+                 -> ByteString+                 -> Maybe Int+                 -> m (Maybe t)+getRememberToken sk rc rp = getSecureCookie rc sk rp+++setRememberToken :: (Serialize t, MonadSnap m)+                 => Key+                 -> ByteString+                 -> Maybe Int+                 -> t+                 -> m ()+setRememberToken sk rc rp token = setSecureCookie rc sk rp token+++forgetRememberToken :: MonadSnap m => ByteString -> m ()+forgetRememberToken rc = expireCookie rc (Just "/")+++------------------------------------------------------------------------------+-- | Set the current user's 'UserId' in the active session+setSessionUserId :: UserId -> Handler b SessionManager ()+setSessionUserId (UserId t) = setInSession "__user_id" t+++------------------------------------------------------------------------------+-- | Remove 'UserId' from active session, effectively logging the user out.+removeSessionUserId :: Handler b SessionManager ()+removeSessionUserId = deleteFromSession "__user_id"+++------------------------------------------------------------------------------+-- | Get the current user's 'UserId' from the active session+getSessionUserId :: Handler b SessionManager (Maybe UserId)+getSessionUserId = do+  uid <- getFromSession "__user_id"+  return $ uid >>= return . UserId+++------------------------------------------------------------------------------+-- | Check password for a given user.+--+-- Returns "Nothing" if check is successful and an "IncorrectPassword" error+-- otherwise+authenticatePassword+  :: AuthUser        -- ^ Looked up from the back-end+  -> Password        -- ^ Check against this password+  -> Maybe AuthFailure+authenticatePassword u pw = auth+  where+    auth = case userPassword u of+      Nothing -> Just PasswordMissing+      Just upw -> check $ checkPassword pw upw+    check b = if b then Nothing else Just IncorrectPassword+++------------------------------------------------------------------------------+-- | Wrap lookups around request-local cache+cacheOrLookup+  :: Handler b (AuthManager b) (Maybe AuthUser)+  -- ^ Lookup action to perform if request local cache is empty+  -> Handler b (AuthManager b) (Maybe AuthUser)+cacheOrLookup f = do+  au <- gets activeUser+  if isJust au+    then return au+    else do+      au' <- f+      modify (\mgr -> mgr { activeUser = au' })+      return au'+++------------------------------------------------------------------------------+-- | Register a new user by specifying login and password 'Param' fields+registerUser+  :: ByteString -- Login field+  -> ByteString -- Password field+  -> Handler b (AuthManager b) AuthUser+registerUser lf pf = do+  l <- fmap decodeUtf8 `fmap` getParam lf+  p <- getParam pf+  case liftM2 (,) l p of+    Nothing -> throw PasswordMissing+    Just (lgn, pwd) -> do+      createUser lgn pwd+++------------------------------------------------------------------------------+-- | A 'MonadSnap' handler that processes a login form.+--+-- The request paremeters are passed to 'performLogin'+loginUser+  :: ByteString+  -- ^ Username field+  -> ByteString+  -- ^ Password field+  -> Maybe ByteString+  -- ^ Remember field; Nothing if you want no remember function.+  -> (AuthFailure -> Handler b (AuthManager b) ())+  -- ^ Upon failure+  -> Handler b (AuthManager b) ()+  -- ^ Upon success+  -> Handler b (AuthManager b) ()+loginUser unf pwdf remf loginFail loginSucc = do+    username <- getParam unf+    password <- getParam pwdf+    remember <- maybe False (=="1") `fmap`+                maybe (return Nothing) getParam remf+    mMatch <- case password of+      Nothing -> return $ Left PasswordMissing+      Just password' -> do+        case username of+          Nothing -> return . Left $ AuthError "Username is missing"+          Just username' -> do+            loginByUsername username' (ClearText password') remember+    either loginFail (const loginSucc) mMatch+++------------------------------------------------------------------------------+-- | Simple handler to log the user out. Deletes user from session.+logoutUser+  :: Handler b (AuthManager b) ()+  -- ^ What to do after logging out+  -> Handler b (AuthManager b) ()+logoutUser target = logout >> target+++------------------------------------------------------------------------------+-- | Require that an authenticated 'AuthUser' is present in the current+-- session.+--+-- This function has no DB cost - only checks to see if a user_id is present+-- in the current session.+requireUser+  :: Lens b (Snaplet (AuthManager b))+  -- Lens reference to an "AuthManager"+  -> Handler b v a+  -- ^ Do this if no authenticated user is present.+  -> Handler b v a+  -- ^ Do this if an authenticated user is present.+  -> Handler b v a+requireUser auth bad good = do+  loggedIn <- withTop auth isLoggedIn+  if loggedIn then good else bad+++------------------------------------------------------------------------------+-- | Run a function on the backend, and return the result.+--+-- This uses an existential type so that the backend type doesn't+-- 'escape' AuthManager.  The reason that the type is Handler b+-- (AuthManager v) a and not a is because anything that uses the+-- backend will return an IO something, which you can liftIO, or a+-- Handler b (AuthManager v) a if it uses other handler things.+withBackend+  :: (forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a)+  -- ^ The function to run with the handler.+  -> Handler b (AuthManager v) a+withBackend f = join $ do+  (AuthManager bckend _ _ _ _ _ _ _) <- get+  return $ f bckend

@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++{-|++  Some pre-packaged splices that add convenience to a Heist-enabled+  application.++-}++module Snap.Snaplet.Auth.SpliceHelpers+  (+    addAuthSplices+  , ifLoggedIn+  , ifLoggedOut+  ) where++import           Data.Lens.Lazy+import qualified Text.XmlHtml as X+import           Text.Templating.Heist++import           Snap.Snaplet+import           Snap.Snaplet.Auth.AuthManager+import           Snap.Snaplet.Auth.Handlers+import           Snap.Snaplet.Heist+++------------------------------------------------------------------------------+-- | Add all standard auth splices to a Heist-enabled application.+--+-- This adds the following splices:+-- \<ifLoggedIn\>+-- \<ifLoggedOut\>+addAuthSplices+  :: HasHeist b+  => Lens b (Snaplet (AuthManager b))+  -- ^ A lens reference to 'AuthManager'+  -> Initializer b v ()+addAuthSplices auth = addSplices+  [ ("ifLoggedIn", ifLoggedIn auth)+  , ("ifLoggedOut", ifLoggedOut auth)+  ]+++------------------------------------------------------------------------------+-- | A splice that can be used to check for existence of a user. If a user is+-- present, this will run the contents of the node.+--+-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>+ifLoggedIn+  :: Lens b (Snaplet (AuthManager b))+  -> SnapletSplice b v+ifLoggedIn auth = do+  chk <- liftHandler $ withTop auth isLoggedIn+  case chk of+    True -> liftHeist $ getParamNode >>= return . X.childNodes+    False -> return []+++------------------------------------------------------------------------------+-- | A splice that can be used to check for absence of a user. If a user is+-- not present, this will run the contents of the node.+--+-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>+ifLoggedOut+  :: Lens b (Snaplet (AuthManager b))+  -> SnapletSplice b v+ifLoggedOut auth = do+  chk <- liftHandler $ withTop auth isLoggedIn+  case chk of+    False -> liftHeist $ getParamNode >>= return . X.childNodes+    True -> return []+

@@ -0,0 +1,175 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Snap.Snaplet.Auth.Types where++import           Control.Monad.CatchIO+import           Data.Aeson+import           Data.ByteString (ByteString)+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import           Data.Hashable (Hashable)+import           Data.Time+import           Data.Typeable+import           Data.Text (Text)+import           Crypto.PasswordStore+++------------------------------------------------------------------------------+-- | Password is clear when supplied by the user and encrypted later when+-- returned from the db.+data Password = ClearText ByteString+              | Encrypted ByteString+              deriving (Read, Show, Ord, Eq)+++------------------------------------------------------------------------------+-- Turn a 'ClearText' password into an 'Encrypted' password, ready to be+-- stuffed into a database.+encryptPassword :: Password -> IO Password+encryptPassword p@(Encrypted {}) = return p+encryptPassword (ClearText p) = do+  hashed <- makePassword p 12+  return $ Encrypted hashed+++checkPassword :: Password -> Password -> Bool+checkPassword (ClearText pw) (Encrypted pw') = verifyPassword pw pw'+checkPassword _ _ =+  error "checkPassword failed. Make sure you pass ClearText passwords"+++------------------------------------------------------------------------------+-- | Authentication failures indicate what went wrong during authentication.+-- They may provide useful information to the developer, although it is+-- generally not advisable to show the user the exact details about why login+-- failed.+data AuthFailure =+    UserNotFound+  | IncorrectPassword+  | PasswordMissing+  | LockedOut UTCTime+  -- ^ Locked out until given time+  | AuthError String+  deriving (Read, Show, Ord, Eq, Typeable)+++instance Exception AuthFailure+++------------------------------------------------------------------------------+-- | Internal representation of a 'User'. By convention, we demand that the+-- application is able to directly fetch a 'User' using this identifier.+--+-- Think of this type as a secure, authenticated user. You should normally+-- never see this type unless a user has been authenticated.+newtype UserId = UserId { unUid :: Text }+    deriving (Read,Show,Ord,Eq,FromJSON,ToJSON,Hashable)+++-- | This will be replaced by a role-based permission system.+data Role = Role ByteString+  deriving (Read,Show,Ord,Eq)+++------------------------------------------------------------------------------+-- | Type representing the concept of a User in your application.+data AuthUser = AuthUser+  { userId :: Maybe UserId+  , userLogin :: Text+  , userPassword :: Maybe Password+  , userActivatedAt :: Maybe UTCTime+  , userSuspendedAt :: Maybe UTCTime+  , userRememberToken :: Maybe Text+  , userLoginCount :: Int+  , userFailedLoginCount :: Int+  , userLockedOutUntil :: Maybe UTCTime+  , userCurrentLoginAt :: Maybe UTCTime+  , userLastLoginAt :: Maybe UTCTime+  , userCurrentLoginIp :: Maybe ByteString+  , userLastLoginIp :: Maybe ByteString+  , userCreatedAt :: Maybe UTCTime+  , userUpdatedAt :: Maybe UTCTime+  , userRoles :: [Role]+  , userMeta :: HashMap Text Value+  } deriving (Show,Eq)+++------------------------------------------------------------------------------+-- | Default AuthUser that has all empty values.+defAuthUser :: AuthUser+defAuthUser = AuthUser {+    userId = Nothing+  , userLogin = ""+  , userPassword = Nothing+  , userActivatedAt = Nothing+  , userSuspendedAt = Nothing+  , userRememberToken = Nothing+  , userLoginCount = 0+  , userFailedLoginCount = 0+  , userLockedOutUntil = Nothing+  , userCurrentLoginAt = Nothing+  , userLastLoginAt = Nothing+  , userCurrentLoginIp = Nothing+  , userLastLoginIp = Nothing+  , userCreatedAt = Nothing+  , userUpdatedAt = Nothing+  , userRoles = []+  , userMeta = HM.empty+}+++------------------------------------------------------------------------------+-- | Set a new password for the given user. Given password should be+-- clear-text; it will be encrypted into a 'Encrypted'.+setPassword :: AuthUser -> ByteString -> IO AuthUser+setPassword au pass = do+  pw <- Encrypted `fmap` (makePassword pass 12)+  return $ au { userPassword = Just pw }+++------------------------------------------------------------------------------+-- | Authetication settings defined at initialization time+data AuthSettings = AuthSettings {+    asMinPasswdLen :: Int+  -- ^ Currently not used/checked+  , asRememberCookieName :: ByteString+  -- ^ Name of the desired remember cookie+  , asRememberPeriod :: Maybe Int+  -- ^ How long to remember when the option is used in rest of the API.+  -- 'Nothing' means remember until end of session.+  , asLockout :: Maybe (Int, NominalDiffTime)+  -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration])+  , asSiteKey :: FilePath+  -- ^ Location of app's encryption key+}+++------------------------------------------------------------------------------+-- | Default settings for Auth.+--+-- > asMinPasswdLen = 8+-- > asRememberCookieName = "_remember"+-- > asRememberPeriod = Just (2*7*24*60*60) = 2 weeks+-- > asLockout = Nothing+-- > asSiteKey = "site_key.txt"+defAuthSettings :: AuthSettings+defAuthSettings = AuthSettings {+    asMinPasswdLen = 8+  , asRememberCookieName = "_remember"+  , asRememberPeriod = Just (2*7*24*60*60)+  , asLockout = Nothing+  , asSiteKey = "site_key.txt"+}+++data BackendError =+    DuplicateLogin+  | BackendError String+  deriving (Eq,Show,Read,Typeable)+++instance Exception BackendError+

@@ -0,0 +1,201 @@+{-|++The Heist snaplet makes it easy to add Heist to your application and use it in+other snaplets.++-}++module Snap.Snaplet.Heist+  (+  -- * Heist and its type class+    Heist+  , HasHeist(..)++  -- * Initializer Functions+  -- $initializerSection+  , heistInit+  , addTemplates+  , addTemplatesAt+  , modifyHeistTS+  , withHeistTS+  , addSplices++  -- * Handler Functions+  -- $handlerSection+  , render+  , renderAs+  , heistServe+  , heistServeSingle+  , heistLocal+  , withSplices+  , renderWithSplices++  -- * Writing Splices+  -- $spliceSection+  , Unclassed.SnapletHeist+  , Unclassed.SnapletSplice+  , Unclassed.liftHeist+  , Unclassed.liftHandler+  , Unclassed.liftAppHandler+  , Unclassed.liftWith+  , Unclassed.bindSnapletSplices++  , clearHeistCache+  ) where++import           Prelude hiding (id, (.))+import           Data.ByteString (ByteString)+import           Data.Lens.Lazy+import           Data.Text (Text)+import           Text.Templating.Heist++import           Snap.Snaplet++import qualified Snap.Snaplet.HeistNoClass as Unclassed+import           Snap.Snaplet.HeistNoClass (Heist, heistInit, clearHeistCache)+++------------------------------------------------------------------------------+-- | A single snaplet should never need more than one instance of Heist as a+-- subsnaplet.  This type class allows you to make it easy for other snaplets+-- to get the lens that identifies the heist snaplet.  Here's an example of+-- how the heist snaplet might be declared:+--+-- > data App = App { _heist :: Snaplet (Heist App) }+-- > mkLabels [''App]+-- >+-- > instance HasHeist App where heistLens = subSnaplet heist+-- >+-- > appInit = makeSnaplet "app" "" Nothing $ do+-- >     h <- nestSnaplet "heist" $ heistInit "templates"+-- >     addSplices myAppSplices+-- >     return $ App h+class HasHeist b where+    -- | A lens to the Heist snaplet.  The b parameter to Heist will+    -- typically be the base state of your application.+    heistLens :: Lens (Snaplet b) (Snaplet (Heist b))+++-- $initializerSection+-- This section contains functions for use in setting up your Heist state+-- during initialization.+++------------------------------------------------------------------------------+-- | Adds templates to the Heist TemplateState.  Other snaplets should use+-- this function to add their own templates.  The templates are automatically+-- read from the templates directory in the current snaplet's filesystem root.+addTemplates :: HasHeist b => ByteString -> Initializer b v ()+addTemplates pfx = withTop' heistLens (Unclassed.addTemplates pfx)+++------------------------------------------------------------------------------+-- | Adds templates to the Heist TemplateState, and lets you specify where+-- they are found in the filesystem.+addTemplatesAt :: HasHeist b => ByteString -> FilePath -> Initializer b v ()+addTemplatesAt pfx p = withTop' heistLens (Unclassed.addTemplatesAt pfx p)+++------------------------------------------------------------------------------+-- | Allows snaplets to add splices.+addSplices :: (HasHeist b)+           => [(Text, Unclassed.SnapletSplice b v)] -> Initializer b v ()+addSplices = Unclassed.addSplices' heistLens+++------------------------------------------------------------------------------+-- | More general function allowing arbitrary TemplateState modification.+-- Without this function you wouldn't be able to bind more complicated splices+-- like the cache tag.+modifyHeistTS :: (HasHeist b)+              => (TemplateState (Handler b b) -> TemplateState (Handler b b))+              -> Initializer b v ()+modifyHeistTS = Unclassed.modifyHeistTS' heistLens+++------------------------------------------------------------------------------+-- | Runs a function on with the Heist snaplet's 'TemplateState'.+withHeistTS :: (HasHeist b)+            => (TemplateState (Handler b b) -> a)+            -> Handler b v a+withHeistTS = Unclassed.withHeistTS' heistLens+++-- $handlerSection+-- This section contains functions in the 'Handler' monad that you'll use in+-- processing requests.+++------------------------------------------------------------------------------+-- | Renders a template as text\/html. If the given template is not found,+-- this returns 'empty'.+render :: HasHeist b => ByteString -> 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 -> ByteString -> Handler b v ()+renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t)+++------------------------------------------------------------------------------+-- | Analogous to 'fileServe'. If the template specified in the request path+-- is not found, it returns 'empty'.+heistServe :: HasHeist b => Handler b v ()+heistServe = withTop' heistLens Unclassed.heistServe+++------------------------------------------------------------------------------+-- | Analogous to 'fileServeSingle'. If the given template is not found,+-- this throws an error.+heistServeSingle :: HasHeist b => ByteString -> Handler b v ()+heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t)+++------------------------------------------------------------------------------+-- | Renders a template with a given set of splices.  This is syntax sugar for+-- a common combination of heistLocal, bindSplices, and render.+renderWithSplices :: HasHeist b+                  => ByteString+                  -> [(Text, Unclassed.SnapletSplice b v)]+                  -> Handler b v ()+renderWithSplices = Unclassed.renderWithSplices' heistLens+++------------------------------------------------------------------------------+-- | Runs an action with additional splices bound into the Heist+-- 'TemplateState'.+withSplices :: HasHeist b+            => [(Text, Unclassed.SnapletSplice b v)]+            -> Handler b v a+            -> Handler b v a+withSplices = Unclassed.withSplices' heistLens+++------------------------------------------------------------------------------+-- | Runs a handler with a modified 'TemplateState'.  You might want to use+-- this if you had a set of splices which were customised for a specific+-- action.  To do that you would do:+--+-- > heistLocal (bindSplices mySplices) handlerThatNeedsSplices+heistLocal :: HasHeist b+           => (TemplateState (Handler b b) -> TemplateState (Handler b b))+           -> Handler b v a+           -> Handler b v a+heistLocal = Unclassed.heistLocal' heistLens+++-- $spliceSection+-- As can be seen in the type signature of heistLocal, the internal+-- TemplateState used by the heist snaplet is parameterized by (Handler b b).+-- The reasons for this are beyond the scope of this discussion, but the+-- result is that 'lift' inside a splice only works with @Handler b b@+-- actions.  When you're writing your own snaplets you obviously would rather+-- work with @Handler b v@ so your local snaplet's state is available.  We+-- provide the SnapletHeist monad to make this possible.  The general rule is+-- that when you're using Snaplets and Heist, use SnapletHeist instead of+-- HeistT (previously called TemplateMonad) and use SnapletSplice instead of+-- Splice.+

@@ -0,0 +1,384 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE TypeSynonymInstances       #-}+module Snap.Snaplet.HeistNoClass+  ( Heist+  , heistInit+  , clearHeistCache++  , addTemplates+  , addTemplatesAt+  , modifyHeistTS+  , modifyHeistTS'+  , withHeistTS+  , withHeistTS'+  , addSplices+  , addSplices'+  , render+  , renderAs+  , heistServe+  , heistServeSingle+  , heistLocal+  , withSplices+  , renderWithSplices+  , heistLocal'+  , withSplices'+  , renderWithSplices'++  , SnapletHeist+  , SnapletSplice+  , runSnapletSplice+  , liftHeist+  , liftWith+  , liftHandler+  , liftAppHandler+  , bindSnapletSplices+  ) where++import           Prelude hiding ((.), id)+import           Control.Arrow+import           Control.Applicative+import           Control.Category+import           Control.Monad.CatchIO (MonadCatchIO)+import           Control.Monad.Reader+import           Control.Monad.State+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.UTF8 as U+import           Data.Maybe+import           Data.Monoid+import           Data.Lens.Lazy+import           Data.Text (Text)+import qualified Data.Text as T+import           System.FilePath.Posix+import           Text.Templating.Heist+import           Text.Templating.Heist.Splices.Cache++import           Snap.Snaplet+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 = Heist+    { _heistTS       :: TemplateState (Handler b b)+    , _heistCTS      :: CacheTagState+    }+++------------------------------------------------------------------------------+changeTS :: (TemplateState (Handler a a) -> TemplateState (Handler a a))+         -> Heist a+         -> Heist a+changeTS f (Heist ts cts) = Heist (f ts) cts+++------------------------------------------------------------------------------+-- | Clears data stored by the cache tag.  The cache tag automatically reloads+-- its data when the specified TTL expires, but sometimes you may want to+-- trigger a manual reload.  This function lets you do that.+clearHeistCache :: Heist b -> IO ()+clearHeistCache = clearCacheTagState . _heistCTS+++------------------------------------------------------------------------------+-- SnapletSplice functions+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | This instance is here because we don't want the heist package to depend+-- on anything from snap packages.+instance MonadSnap m => MonadSnap (HeistT m) where+    liftSnap = lift . liftSnap+++------------------------------------------------------------------------------+-- | Monad for working with Heist's API from within a snaplet.+newtype SnapletHeist b v a = SnapletHeist+    (ReaderT (Lens (Snaplet b) (Snaplet v)) (HeistT (Handler b b)) a)+  deriving ( Monad+           , Functor+           , Applicative+           , Alternative+           , MonadIO+           , MonadPlus+           , MonadReader (Lens (Snaplet b) (Snaplet v))+           , MonadCatchIO+           , MonadSnap+           )+++------------------------------------------------------------------------------+-- | Type alias for convenience.+type SnapletSplice b v = SnapletHeist b v Template+++------------------------------------------------------------------------------+-- | Runs the SnapletSplice.+runSnapletSplice :: (Lens (Snaplet b) (Snaplet v))+                 -> SnapletHeist b v a+                 -> HeistT (Handler b b) a+runSnapletSplice l (SnapletHeist m) = runReaderT m l+++withSS :: (Lens (Snaplet b) (Snaplet v) -> Lens (Snaplet b) (Snaplet v'))+       -> SnapletHeist b v' a+       -> SnapletHeist b v a+withSS f (SnapletHeist m) = SnapletHeist $ withReaderT f m+++------------------------------------------------------------------------------+-- | Lifts a HeistT action into SnapletHeist.  Use this with all the functions+-- from the Heist API.+liftHeist :: HeistT (Handler b b) a -> SnapletHeist b v a+liftHeist = SnapletHeist . lift+++------------------------------------------------------------------------------+-- | Common idiom for the combination of liftHandler and withTop.+liftWith :: (Lens (Snaplet b) (Snaplet v'))+         -> Handler b v' a+         -> SnapletHeist b v a+liftWith l = liftHeist . lift . withTop' l+++------------------------------------------------------------------------------+-- | Lifts a Handler into SnapletHeist.+liftHandler :: Handler b v a -> SnapletHeist b v a+liftHandler m = do+    l <- ask+    liftWith l m+++------------------------------------------------------------------------------+-- | Lifts a (Handler b b) into SnapletHeist.+liftAppHandler :: Handler b b a -> SnapletHeist b v a+liftAppHandler = liftHeist . lift+++instance MonadState v (SnapletHeist b v) where+    get = do+        l <- ask+        b <- liftAppHandler getSnapletState+        return $ getL (snapletValue . l) b+    put s = do+        l <- ask+        b <- liftAppHandler getSnapletState+        liftAppHandler $ putSnapletState $ setL (snapletValue . l) s b+++------------------------------------------------------------------------------+-- | MonadSnaplet instance gives us access to the snaplet infrastructure.+instance MonadSnaplet SnapletHeist where+    getLens = ask+    with' l = withSS (l .)+    withTop' l = withSS (const id) . with' l+    getOpaqueConfig = do+        l <- ask+        b <- liftAppHandler getSnapletState+        return $ getL (snapletConfig . l) b+++------------------------------------------------------------------------------+-- | SnapletSplices version of bindSplices.+bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v))+                   -> [(Text, SnapletSplice b v)]+                   -> TemplateState (Handler b b)+                   -> TemplateState (Handler b b)+bindSnapletSplices l splices =+    bindSplices $ map (second $ runSnapletSplice l) splices+++------------------------------------------------------------------------------+-- Initializer functions+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | The 'Initializer' for 'Heist'.+heistInit :: FilePath+          -> SnapletInit b (Heist b)+heistInit templateDir =+    makeSnaplet "heist" "" Nothing $ do+        (cacheFunc, cts) <- liftIO mkCacheTag+        let origTs = cacheFunc emptyTemplateState+        ts <- liftIO $ loadTemplates templateDir origTs >>=+                       either error return+        addRoutes [ ("", heistServe) ]+        printInfo $ T.pack $ unwords+            [ "...loaded"+            , (show $ length $ templateNames ts)+            , "templates"+            ]++        return $ Heist ts cts+++addTemplates :: ByteString -> Initializer b (Heist b) ()+addTemplates urlPrefix = do+    snapletPath <- getSnapletFilePath+    addTemplatesAt urlPrefix (snapletPath </> "templates")+++addTemplatesAt :: ByteString+               -> FilePath+               -> Initializer b (Heist b) ()+addTemplatesAt urlPrefix templateDir = do+    ts <- liftIO $ loadTemplates templateDir emptyTemplateState+                   >>= either error return+    printInfo $ T.pack $ unwords+        [ "...adding"+        , (show $ length $ templateNames ts)+        , "templates from"+        , templateDir+        , "with route prefix"+        , (U.toString urlPrefix) ++ "/"+        ]+    addPostInitHook $ return . changeTS+        (`mappend` addTemplatePathPrefix urlPrefix ts)+++modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))+               -> (TemplateState (Handler b b) -> TemplateState (Handler b b))+               -> Initializer b v ()+modifyHeistTS' heist f = do+    _lens <- getLens+    withTop' heist $ addPostInitHook $ return . changeTS f+++modifyHeistTS :: (Lens b (Snaplet (Heist b)))+              -> (TemplateState (Handler b b) -> TemplateState (Handler b b))+              -> Initializer b v ()+modifyHeistTS heist f = modifyHeistTS' (subSnaplet heist) f+++withHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))+             -> (TemplateState (Handler b b) -> a)+             -> Handler b v a+withHeistTS' heist f = withTop' heist $ gets (f . _heistTS)+++withHeistTS :: (Lens b (Snaplet (Heist b)))+            -> (TemplateState (Handler b b) -> a)+            -> Handler b v a+withHeistTS heist f = withHeistTS' (subSnaplet heist) f+++addSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))+            -> [(Text, SnapletSplice b v)]+            -> Initializer b v ()+addSplices' heist splices = do+    _lens <- getLens+    withTop' heist $ addPostInitHook $+        return . changeTS (bindSnapletSplices _lens splices)+++addSplices :: (Lens b (Snaplet (Heist b)))+           -> [(Text, SnapletSplice b v)]+           -> Initializer b v ()+addSplices heist splices = addSplices' (subSnaplet heist) splices+++------------------------------------------------------------------------------+-- Handler functions+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Internal helper function for rendering.+renderHelper :: Maybe MIMEType+             -> ByteString+             -> Handler b (Heist b) ()+renderHelper c t = do+    (Heist ts _) <- get+    withTop' id $ renderTemplate ts t >>= maybe pass serve+  where+    serve (b, mime) = do+        modifyResponse $ setContentType $ fromMaybe mime c+        writeBuilder b+++render :: ByteString+       -- ^ Name of the template+       -> Handler b (Heist b) ()+render t = renderHelper Nothing t+++renderAs :: ByteString+         -- ^ Content type+         -> ByteString+         -- ^ Name of the template+         -> Handler b (Heist b) ()+renderAs ct t = renderHelper (Just ct) t+++heistServe :: Handler b (Heist b) ()+heistServe =+    ifTop (render "index") <|> (render . B.pack =<< getSafePath)+++heistServeSingle :: ByteString+                 -> Handler b (Heist b) ()+heistServeSingle t =+    render t <|> error ("Template " ++ show t ++ " not found.")+++heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b)))+            -> (TemplateState (Handler b b) -> TemplateState (Handler b b))+            -> Handler b v a+            -> Handler b v a+heistLocal' heist f m = do+    hs  <- withTop' heist get+    withTop' heist $ modify $ changeTS f+    res <- m+    withTop' heist $ put hs+    return res+++heistLocal :: (Lens b (Snaplet (Heist b)))+           -> (TemplateState (Handler b b) -> TemplateState (Handler b b))+           -> Handler b v a+           -> Handler b v a+heistLocal heist f m = heistLocal' (subSnaplet heist) f m+++withSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))+             -> [(Text, SnapletSplice b v)]+             -> Handler b v a+             -> Handler b v a+withSplices' heist splices m = do+    _lens <- getLens+    heistLocal' heist (bindSnapletSplices _lens splices) m+++withSplices :: (Lens b (Snaplet (Heist b)))+            -> [(Text, SnapletSplice b v)]+            -> Handler b v a+            -> Handler b v a+withSplices heist splices m = withSplices' (subSnaplet heist) splices m+++renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))+                   -> ByteString+                   -> [(Text, SnapletSplice b v)]+                   -> Handler b v ()+renderWithSplices' heist t splices =+    withSplices' heist splices $ withTop' heist $ render t+++renderWithSplices :: (Lens b (Snaplet (Heist b)))+                  -> ByteString+                  -> [(Text, SnapletSplice b v)]+                  -> Handler b v ()+renderWithSplices heist t splices =+    renderWithSplices' (subSnaplet heist) t splices++

@@ -0,0 +1,489 @@+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE BangPatterns               #-}++module Snap.Snaplet.Internal.Initializer+  ( addPostInitHook+  , addPostInitHookBase+  , toSnapletHook+  , bracketInit+  , modifyCfg+  , nestSnaplet+  , embedSnaplet+  , makeSnaplet+  , nameSnaplet+  , onUnload+  , addRoutes+  , wrapHandlers+  , runInitializer+  , runSnaplet+  , combineConfig+  , serveSnaplet+  , printInfo+  ) where++import           Prelude hiding ((.), id, catch)+import           Control.Category+import           Control.Concurrent.MVar+import           Control.Exception (SomeException)+import           Control.Monad+import           Control.Monad.CatchIO hiding (Handler)+import           Control.Monad.Reader+import           Control.Monad.State+import           Control.Monad.Trans.Writer hiding (pass)+import           Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import           Data.Configurator+import           Data.IORef+import           Data.Maybe+import           Data.Lens.Lazy+import           Data.Text (Text)+import qualified Data.Text as T+import           Snap.Http.Server+import           Snap.Core+import           Snap.Util.GZip+import           System.Directory+import           System.Directory.Tree+import           System.FilePath.Posix+import           System.IO++import qualified Snap.Snaplet.Internal.LensT as LT+import qualified Snap.Snaplet.Internal.Lensed as L+import           Snap.Snaplet.Internal.Types+++------------------------------------------------------------------------------+-- | 'get' for InitializerState.+iGet :: Initializer b v (InitializerState b)+iGet = Initializer $ LT.getBase+++------------------------------------------------------------------------------+-- | 'modify' for InitializerState.+iModify :: (InitializerState b -> InitializerState b) -> Initializer b v ()+iModify f = Initializer $ do+    b <- LT.getBase+    LT.putBase $ f b+++------------------------------------------------------------------------------+-- | 'gets' for InitializerState.+iGets :: (InitializerState b -> a) -> Initializer b v a+iGets f = Initializer $ do+    b <- LT.getBase+    return $ f b+++------------------------------------------------------------------------------+-- | Converts a plain hook into a Snaplet hook.+toSnapletHook :: (v -> IO v) -> (Snaplet v -> IO (Snaplet v))+toSnapletHook f (Snaplet cfg val) = do+    val' <- f val+    return $! Snaplet cfg val'+++------------------------------------------------------------------------------+-- | Adds an IO action that modifies the current snaplet state to be run at+-- the end of initialization on the state that was created.  This makes it+-- easier to allow one snaplet's state to be modified by another snaplet's+-- initializer.  A good example of this is when a snaplet has templates that+-- define its views.  The Heist snaplet provides the 'addTemplates' function+-- which allows other snaplets to set up their own templates.  'addTemplates'+-- is implemented using this function.+addPostInitHook :: (v -> IO v) -> Initializer b v ()+addPostInitHook = addPostInitHook' . toSnapletHook+++addPostInitHook' :: (Snaplet v -> IO (Snaplet v)) -> Initializer b v ()+addPostInitHook' h = do+    h' <- upHook h+    addPostInitHookBase h'+++------------------------------------------------------------------------------+-- | Variant of addPostInitHook for when you have things wrapped in a Snaplet.+addPostInitHookBase :: (Snaplet b -> IO (Snaplet b))+                    -> Initializer b v ()+addPostInitHookBase = Initializer . lift . tell . Hook+++------------------------------------------------------------------------------+-- | Helper function for transforming hooks.+upHook :: (Snaplet v -> IO (Snaplet v))+       -> Initializer b v (Snaplet b -> IO (Snaplet b))+upHook h = Initializer $ do+    l <- ask+    return $ upHook' l h+++------------------------------------------------------------------------------+-- | Helper function for transforming hooks.+upHook' :: (Lens b a) -> (a -> IO a) -> b -> IO b+upHook' l h b = do+    v <- h (getL l b)+    return $ setL l v b+++------------------------------------------------------------------------------+-- | Modifies the Initializer's SnapletConfig.+modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v ()+modifyCfg f = iModify $ modL curConfig $ \c -> f c+++------------------------------------------------------------------------------+-- | If a snaplet has a filesystem presence, this function creates and copies+-- the files if they dont' already exist.+setupFilesystem :: Maybe (IO FilePath)+                -- ^ The directory where the snaplet's reference files are+                -- stored.  Nothing if the snaplet doesn't come with any files+                -- that need to be installed.+                -> FilePath+                -- ^ Directory where the files should be copied.+                -> Initializer b v ()+setupFilesystem Nothing _ = return ()+setupFilesystem (Just getSnapletDataDir) targetDir = do+    exists <- liftIO $ doesDirectoryExist targetDir+    unless exists $ do+        printInfo "...setting up filesystem"+        liftIO $ createDirectoryIfMissing True targetDir+        srcDir <- liftIO getSnapletDataDir+        (_ :/ dTree) <- liftIO $ readDirectoryWith B.readFile srcDir+        let (topDir,snapletId) = splitFileName targetDir+        _ <- liftIO $ writeDirectoryWith B.writeFile+               (topDir :/ dTree { name = snapletId })+        return ()+++------------------------------------------------------------------------------+-- | All snaplet initializers must be wrapped in a call to @makeSnaplet@,+-- which handles standardized housekeeping common to all snaplets.+-- Common usage will look something like+-- this:+--+-- @+-- fooInit :: SnapletInit b Foo+-- fooInit = makeSnaplet \"foo\" \"An example snaplet\" Nothing $ do+--     -- Your initializer code here+--     return $ Foo 42+-- @+--+-- Note that you're writing your initializer code in the Initializer monad,+-- and makeSnaplet converts it into an opaque SnapletInit type.  This allows+-- us to use the type system to ensure that the API is used correctly.+makeSnaplet :: Text+       -- ^ A default id for this snaplet.  This is only used when the+       -- end-user has not already set an id using the nameSnaplet function.+       -> Text+       -- ^ A human readable description of this snaplet.+       -> Maybe (IO FilePath)+       -- ^ The path to the directory holding the snaplet's reference+       -- filesystem content.  This will almost always be the directory+       -- returned by Cabal's getDataDir command, but it has to be passed in+       -- because it is defined in a package-specific import.  Setting this+       -- value to Nothing doesn't preclude the snaplet from having files in+       -- in the filesystem, it just means that they won't be copied there+       -- automatically.+       -> Initializer b v v+       -- ^ Snaplet initializer.+       -> SnapletInit b v+makeSnaplet snapletId desc getSnapletDataDir m = SnapletInit $ do+    modifyCfg $ \c -> if isNothing $ _scId c+        then setL scId (Just snapletId) c else c+    sid <- iGets (T.unpack . fromJust . _scId . _curConfig)+    topLevel <- iGets _isTopLevel+    unless topLevel $ modifyCfg $ \c -> setL scFilePath+        (_scFilePath c </> "snaplets" </> sid) c+    iModify (setL isTopLevel False)+    modifyCfg $ modL scUserConfig (subconfig (T.pack sid))+    modifyCfg $ setL scDescription desc+    cfg <- iGets _curConfig+    printInfo $ T.pack $ concat+      ["Initializing "+      ,sid+      ," @ /"+      ,B.unpack $ buildPath $ _scRouteContext cfg+      ]++    -- This has to happen here because it needs to be after scFilePath is set+    -- up but before snaplet.cfg is read.+    setupFilesystem getSnapletDataDir (_scFilePath cfg)++    liftIO $ addToConfig [Optional (_scFilePath cfg </> "snaplet.cfg")]+                         (_scUserConfig cfg)+    mkSnaplet m+++------------------------------------------------------------------------------+-- | 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 m = do+    res <- m+    cfg <- iGets _curConfig+    return $ Snaplet cfg res+++------------------------------------------------------------------------------+-- | Brackets an initializer computation, restoring curConfig after the+-- computation returns.+bracketInit :: Initializer b v a -> Initializer b v a+bracketInit m = do+    s <- iGet+    res <- m+    iModify (setL curConfig (_curConfig s))+    return res+++------------------------------------------------------------------------------+-- | Handles modifications to InitializerState that need to happen before a+-- snaplet is called with either nestSnaplet or embedSnaplet.+setupSnapletCall :: ByteString -> Initializer b v ()+setupSnapletCall rte = do+    curId <- iGets (fromJust . _scId . _curConfig)+    modifyCfg (modL scAncestry (curId:))+    modifyCfg (modL scId (const Nothing))+    unless (B.null rte) $ modifyCfg (modL scRouteContext (rte:))+++------------------------------------------------------------------------------+-- | Runs another snaplet's initializer and returns the initialized Snaplet+-- value.  Calling an initializer with nestSnaplet gives the nested snaplet+-- access to the same base state that the current snaplet has.  This makes it+-- possible for the child snaplet to make use of functionality provided by+-- sibling snaplets.+nestSnaplet :: ByteString+            -- ^ The root url for all the snaplet's routes.  An empty string+            -- gives the routes the same root as the parent snaplet's routes.+            -> (Lens v (Snaplet v1))+            -- ^ Lens identifying the snaplet+            -> SnapletInit b v1+            -- ^ The initializer function for the subsnaplet.+            -> Initializer b v (Snaplet v1)+nestSnaplet rte l (SnapletInit snaplet) = with l $ bracketInit $ do+    setupSnapletCall rte+    snaplet+++------------------------------------------------------------------------------+-- | Runs another snaplet's initializer and returns the initialized Snaplet+-- value.  The difference between this and nestSnaplet is the first type+-- parameter in the third argument.  The \"v1 v1\" makes the child snaplet+-- think that it is top-level, which means that it will not be able to use+-- functionality provided by snaplets included above it in the snaplet tree.+-- This strongly isolates the child snaplet, and allows you to eliminate the b+-- type variable.  The embedded snaplet can still get functionality from other+-- snaplets, but only if it nests or embeds the snaplet itself.+embedSnaplet :: ByteString+             -- ^ The root url for all the snaplet's routes.  An empty string+             -- gives the routes the same root as the parent snaplet's routes.+             --+             -- NOTE: Because of the stronger isolation provided by+             -- embedSnaplet, you should be more careful about using an empty+             -- string here.+             -> (Lens v (Snaplet v1))+             -- ^ Lens identifying the snaplet+             -> SnapletInit v1 v1+             -- ^ The initializer function for the subsnaplet.+             -> Initializer b v (Snaplet v1)+embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do+    curLens <- getLens+    setupSnapletCall rte+    chroot rte (subSnaplet l . curLens) snaplet+++------------------------------------------------------------------------------+-- | Changes the base state of an initializer.+chroot :: ByteString+       -> (Lens (Snaplet b) (Snaplet v1))+       -> Initializer v1 v1 a+       -> Initializer b v a+chroot rte l (Initializer m) = do+    curState <- iGet+    ((a,s), (Hook hook)) <- liftIO $ runWriterT $ LT.runLensT m id $+        curState {+          _handlers = [],+          _hFilter = id+        }+    let handler = chrootHandler l $ _hFilter s $ route $ _handlers s+    iModify $ modL handlers (++[(rte,handler)])+            . setL cleanup (_cleanup s)+    addPostInitHookBase $ upHook' l hook+    return a+++------------------------------------------------------------------------------+-- | Changes the base state of a handler.+chrootHandler :: (Lens (Snaplet v) (Snaplet b'))+              -> Handler b' b' a -> Handler b v a+chrootHandler l (Handler h) = Handler $ do+    s <- get+    (a, s') <- liftSnap $ L.runLensed h id (getL l s)+    modify $ setL l s'+    return a+++------------------------------------------------------------------------------+-- | Sets a snaplet's name.  All snaplets have a default name set by the+-- snaplet author.  This function allows you to override that name.  You will+-- have to do this if you have more than one instance of the same kind of+-- snaplet because snaplet names must be unique.  This function must+-- immediately surround the snaplet's initializer.  For example:+--+-- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@+nameSnaplet :: Text+            -- ^ The snaplet name+            -> SnapletInit b v+            -- ^ The snaplet initializer function+            -> SnapletInit b v+nameSnaplet nm (SnapletInit m) = SnapletInit $+    modifyCfg (setL scId (Just nm)) >> m+++------------------------------------------------------------------------------+-- | Adds routing to the current 'Handler'.  The new routes are merged with+-- the main routing section and take precedence over existing routing that was+-- previously defined.+addRoutes :: [(ByteString, Handler b v ())]+           -> Initializer b v ()+addRoutes rs = do+    l <- getLens+    ctx <- iGets (_scRouteContext . _curConfig)+    let rs' = map (\(r,h) -> (buildPath (r:ctx), withTop' l h)) rs+    iModify (\v -> modL handlers (++rs') v)+++------------------------------------------------------------------------------+-- | Wraps the snaplet's routing.  This can be used to provide a snaplet that+-- does per-request setup and cleanup, but then dispatches to the rest of the+-- application.+wrapHandlers :: (Handler b v () -> Handler b v ()) -> Initializer b v ()+wrapHandlers f0 = do+    f <- mungeFilter f0+    iModify (\v -> modL hFilter (f.) v)+++------------------------------------------------------------------------------+mungeFilter :: (Handler b v () -> Handler b v ())+            -> Initializer b v (Handler b b () -> Handler b b ())+mungeFilter f = do+    myLens <- Initializer ask+    return $ \m -> with' myLens $ f' m+  where+    f' (Handler m)       = f $ Handler $ L.withTop id m+++------------------------------------------------------------------------------+-- | Attaches an unload handler to the snaplet.  The unload handler will be+-- called when the server shuts down, or is reloaded.+onUnload :: IO () -> Initializer b v ()+onUnload m = iModify (\v -> modL cleanup (m>>) v)+++------------------------------------------------------------------------------+-- |+logInitMsg :: IORef Text -> Text -> IO ()+logInitMsg ref msg = atomicModifyIORef ref (\cur -> (cur `T.append` msg, ()))+++------------------------------------------------------------------------------+-- | Initializers should use this function for all informational or error+-- messages to be displayed to the user.  On application startup they will be+-- sent to the console.  When executed from the reloader, they will be sent+-- back to the user in the HTTP response.+printInfo :: Text -> Initializer b v ()+printInfo msg = do+    logRef <- iGets _initMessages+    liftIO $ logInitMsg logRef (msg `T.append` "\n")+++------------------------------------------------------------------------------+-- | Builds an IO reload action for storage in the SnapletState.+mkReloader :: MVar (Snaplet b)+           -> Initializer b b (Snaplet b)+           -> IO (Either String String)+mkReloader mvar i = do+    !res <- try $ runInitializer mvar i+    either bad good res+  where+    bad e = do+        return $ Left $ show (e :: SomeException)+    good (b,is) = do+        _ <- swapMVar mvar b+        msgs <- readIORef $ _initMessages is+        return $ Right $ T.unpack msgs+++------------------------------------------------------------------------------+-- | Runs a top-level snaplet in the Snap monad.+runBase :: Handler b b a+        -> MVar (Snaplet b)+        -> Snap a+runBase (Handler m) mvar = do+    !b <- liftIO (readMVar mvar)+    (!a, _) <- L.runLensed m id b+    return $! a+++------------------------------------------------------------------------------+-- |+runInitializer :: MVar (Snaplet b)+               -> Initializer b b (Snaplet b)+               -> IO (Snaplet b, InitializerState b)+runInitializer mvar b@(Initializer i) = do+    userConfig <- load [Optional "snaplet.cfg"]+    let builtinHandlers = [("/admin/reload", reloadSite)]+    let cfg = SnapletConfig [] "" Nothing "" userConfig [] (mkReloader mvar b)+    logRef <- newIORef ""+    ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $+        InitializerState True (return ()) builtinHandlers id cfg logRef+    res' <- hook res+    return (res', s)+++------------------------------------------------------------------------------+-- | Given a Snaplet initializer, produce the set of messages generated during+-- initialization, a snap handler, and a cleanup action.+runSnaplet :: SnapletInit b b -> IO (Text, Snap (), IO ())+runSnaplet (SnapletInit b) = do+    snapletMVar <- newEmptyMVar+    (siteSnaplet, is) <- runInitializer snapletMVar b+    putMVar snapletMVar siteSnaplet++    msgs <- liftIO $ readIORef $ _initMessages is+    let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar++    return (msgs, handler, _cleanup is)+++------------------------------------------------------------------------------+-- | Given a configuration and a snap handler, complete it and produce the+-- completed configuration as well as a new toplevel handler with things like+-- compression and a 500 handler set up.+combineConfig :: Config Snap a -> Snap () -> IO (Config Snap a, Snap ())+combineConfig config handler = do+    conf <- completeConfig config++    let catch500 = (flip catch $ fromJust $ getErrorHandler conf)+    let compress = if fromJust (getCompression conf)+                     then withCompression else id+    let site     = compress $ catch500 handler++    return (conf, site)+++------------------------------------------------------------------------------+-- | Serves a top-level snaplet as a web application. Reads command-line+-- arguments. FIXME: document this.+serveSnaplet :: Config Snap a -> SnapletInit b b -> IO ()+serveSnaplet startConfig initializer = do+    (msgs, handler, doCleanup) <- runSnaplet initializer++    config       <- commandLineConfig startConfig+    (conf, site) <- combineConfig config handler+    let serve = simpleHttpServe conf++    liftIO $ hPutStrLn stderr $ T.unpack msgs+    _ <- try $ serve $ site+         :: IO (Either SomeException ())+    doCleanup++

@@ -0,0 +1,105 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++module Snap.Snaplet.Internal.LensT where++import           Control.Applicative+import           Control.Category+import           Control.Monad.CatchIO+import           Control.Monad.Reader+import           Control.Monad.State.Class+import           Data.Lens.Lazy+import           Prelude hiding ((.), id, catch)+import           Snap.Core++import           Snap.Snaplet.Internal.RST+++newtype LensT b v s m a = LensT (RST (Lens b v) s m a)+  deriving ( Monad+           , MonadTrans+           , Functor+           , Applicative+           , MonadIO+           , MonadPlus+           , MonadCatchIO+           , Alternative+           , MonadReader (Lens b v)+           , MonadSnap )+++------------------------------------------------------------------------------+instance (Monad m) => MonadState v (LensT b v b m) where+    get = lGet+    put = lPut+++------------------------------------------------------------------------------+getBase :: (Monad m) => LensT b v s m s+getBase = LensT get+{-# INLINE getBase #-}+++------------------------------------------------------------------------------+putBase :: (Monad m) => s -> LensT b v s m ()+putBase = LensT . put+{-# INLINE putBase #-}+++------------------------------------------------------------------------------+lGet :: (Monad m) => LensT b v b m v+lGet = LensT $ do+           !l <- ask+           !b <- get+           return $! l ^$ b+{-# INLINE lGet #-}+++------------------------------------------------------------------------------+lPut :: (Monad m) => v -> LensT b v b m ()+lPut v = LensT $ do+             !l <- ask+             !b <- get+             put $! (l ^!= v) b+{-# INLINE lPut #-}+++------------------------------------------------------------------------------+runLensT :: (Monad m) =>+            LensT b v s m a+         -> Lens b v+         -> s+         -> m (a, s)+runLensT (LensT m) = runRST m+{-# INLINE runLensT #-}+++------------------------------------------------------------------------------+withLensT :: Monad m =>+             ((Lens b' v') -> (Lens b v))+          -> LensT b v s m a+          -> LensT b' v' s m a+withLensT f (LensT m) = LensT $ withRST f m+{-# INLINE withLensT #-}+++------------------------------------------------------------------------------+withTop :: Monad m+        => (Lens b v')+        -> LensT b v' s m a+        -> LensT b v  s m a+withTop !subLens = withLensT (const subLens)+{-# INLINE withTop #-}+++------------------------------------------------------------------------------+with :: Monad m+     => (Lens v v')+     -> LensT b v' s m a+     -> LensT b v  s m a+with !subLens = withLensT (subLens .)+{-# INLINE with #-}++

@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Snap.Snaplet.Internal.Lensed where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Data.Lens.Strict+import Control.Monad.CatchIO+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.State.Strict+import Control.Category+import Prelude hiding (catch, id, (.))+import Snap.Core+++------------------------------------------------------------------------------+newtype Lensed b v m a = Lensed+    { unlensed :: Lens b v -> v -> b -> m (a, v, b) }+++------------------------------------------------------------------------------+instance Functor m => Functor (Lensed b v m) where+    fmap f (Lensed g) = Lensed $ \l v s ->+        (\(a,v',s') -> (f a, v', s')) <$> g l v s+++------------------------------------------------------------------------------+instance (Functor m, Monad m) => Applicative (Lensed b v m) where+    pure a = Lensed $ \_ v s -> return (a, v, s)+    Lensed mf <*> Lensed ma = Lensed $ \l v s -> do+        (f, v', s') <- mf l v s+        (\(a,v'',s'') -> (f a, v'', s'')) <$> ma l v' s'+++------------------------------------------------------------------------------+instance Monad m => Monad (Lensed b v m) where+    return a = Lensed $ \_ v s -> return (a, v, s)+    Lensed g >>= k = Lensed $ \l v s -> do+        (a, v', s') <- g l v s+        unlensed (k a) l v' s'+++------------------------------------------------------------------------------+instance Monad m => MonadState v (Lensed b v m) where+    get = Lensed $ \_ v s -> return (v, v, s)+    put v' = Lensed $ \_ _ s -> return ((), v', s)+++------------------------------------------------------------------------------+instance Monad m => MonadReader (Lens b v) (Lensed b v m) where+    ask = Lensed $ \l v s -> return (l, v, s)+    local f g = do+        l' <- asks f+        withTop l' g+++------------------------------------------------------------------------------+instance MonadTrans (Lensed b v) where+    lift m = Lensed $ \_ v b -> do+                 res <- m+                 return (res, v, b)+++------------------------------------------------------------------------------+instance MonadIO m => MonadIO (Lensed b v m) where+  liftIO = lift . liftIO+++------------------------------------------------------------------------------+instance MonadCatchIO m => MonadCatchIO (Lensed b v m) where+    catch (Lensed m) f = Lensed $ \l v b -> m l v b `catch` handler l v b+      where+        handler l v b e = let (Lensed h) = f e+                          in h l v b++    block (Lensed m)   = Lensed $ \l v b -> block (m l v b)+    unblock (Lensed m) = Lensed $ \l v b -> unblock (m l v b)+++------------------------------------------------------------------------------+instance MonadPlus m => MonadPlus (Lensed b v m) where+    mzero = lift mzero+    m `mplus` n = Lensed $ \l v b ->+                  unlensed m l v b `mplus` unlensed n l v b+++------------------------------------------------------------------------------+instance (Monad m, Alternative m) => Alternative (Lensed b v m) where+    empty = lift empty+    (Lensed m) <|> (Lensed n) = Lensed $ \l v b -> m l v b <|> n l v b+++------------------------------------------------------------------------------+instance MonadSnap m => MonadSnap (Lensed b v m) where+    liftSnap = lift . liftSnap+++------------------------------------------------------------------------------+getBase :: Monad m => Lensed b v m b+getBase = Lensed $ \_ v b -> return (b, v, b)+++------------------------------------------------------------------------------+withTop :: Monad m => Lens b v' -> Lensed b v' m a -> Lensed b v m a+withTop l m = globally $ lensedAsState m l+++------------------------------------------------------------------------------+with :: Monad m => Lens v v' -> Lensed b v' m a -> Lensed b v m a+with l g = do+    l' <- asks (l .)+    withTop l' g+++------------------------------------------------------------------------------+embed :: Monad m => Lens v v' -> Lensed v v' m a -> Lensed b v m a+embed l m = locally $ lensedAsState m l+++------------------------------------------------------------------------------+globally :: Monad m => StateT b m a -> Lensed b v m a+globally (StateT f) = Lensed $ \l v s ->+                      liftM (\(a, s') -> (a, l ^$ s', s')) $ f (l ^= v $ s)+++------------------------------------------------------------------------------+locally :: Monad m => StateT v m a -> Lensed b v m a+locally (StateT f) = Lensed $ \_ v s ->+                     liftM (\(a, v') -> (a, v', s)) $ f v+++------------------------------------------------------------------------------+lensedAsState :: Monad m => Lensed b v m a -> Lens b v -> StateT b m a+lensedAsState (Lensed f) l = StateT $ \s -> do+    (a, v', s') <- f l (l ^$ s) s+    return (a, l ^= v' $ s')+++------------------------------------------------------------------------------+runLensed :: Monad m+          => Lensed t1 b m t+          -> Lens t1 b+          -> t1+          -> m (t, t1)+runLensed (Lensed f) l s = do+    (a, v', s') <- f l (l ^$ s) s+    return (a, l ^= v' $ s')+

@@ -0,0 +1,109 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++module Snap.Snaplet.Internal.RST where++import           Control.Applicative+import           Control.Category+import           Control.Monad.CatchIO+import           Control.Monad.Reader+import           Control.Monad.State.Class+import           Prelude hiding ((.), id, catch)+import           Snap.Core+++------------------------------------------------------------------------------+-- like RWST, but no writer to bog things down. Also assured strict, inlined+-- monad bind, etc+newtype RST r s m a = RST { runRST :: r -> s -> m (a, s) }+++evalRST :: Monad m => RST r s m a -> r -> s -> m a+evalRST m r s = do+    (a,_) <- runRST m r s+    return a+{-# INLINE evalRST #-}+++execRST :: Monad m => RST r s m a -> r -> s -> m s+execRST m r s = do+    (_,!s') <- runRST m r s+    return s'+{-# INLINE execRST #-}+++withRST :: Monad m => (r' -> r) -> RST r s m a -> RST r' s m a+withRST f m = RST $ \r' s -> runRST m (f r') s+{-# INLINE withRST #-}+++instance (Monad m) => MonadReader r (RST r s m) where+    ask = RST $ \r s -> return (r,s)+    local f m = RST $ \r s -> runRST m (f r) s+++instance (Functor m) => Functor (RST r s m) where+    fmap f m = RST $ \r s -> fmap (\(a,s') -> (f a, s')) $ runRST m r s+++instance (Functor m, Monad m) => Applicative (RST r s m) where+    pure = return+    (<*>) = ap+++instance (Functor m, MonadPlus m) => Alternative (RST r s m) where+    empty = mzero+    (<|>) = mplus+++instance (Monad m) => MonadState s (RST r s m) where+    get   = RST $ \_ s -> return (s,s)+    put x = RST $ \_ _ -> return ((),x)+++mapRST :: (m (a, s) -> n (b, s)) -> RST r s m a -> RST r s n b+mapRST f m = RST $ \r s -> f (runRST m r s)+++instance (MonadCatchIO m) => MonadCatchIO (RST r s m) where+    m `catch` f = RST $ \r s -> runRST m r s+                           `catch` \e -> runRST (f e) r s+    block       = mapRST block+    unblock     = mapRST unblock++instance (MonadSnap m) => MonadSnap (RST r s m) where+    liftSnap s = lift $ liftSnap s++rwsBind :: Monad m =>+           RST r s m a+        -> (a -> RST r s m b)+        -> RST r s m b+rwsBind m f = RST go+  where+    go r !s = do+        (a, !s')  <- runRST m r s+        runRST (f a) r s'+{-# INLINE rwsBind #-}++instance (Monad m) => Monad (RST r s m) where+    return a = RST $ \_ s -> return (a, s)+    (>>=)    = rwsBind+    fail msg = RST $ \_ _ -> fail msg+++instance (MonadPlus m) => MonadPlus (RST r s m) where+    mzero       = RST $ \_ _ -> mzero+    m `mplus` n = RST $ \r s -> runRST m r s `mplus` runRST n r s+++instance MonadTrans (RST r s) where+    lift m = RST $ \_ s -> do+        a <- m+        return $ s `seq` (a, s)++instance (MonadIO m) => MonadIO (RST r s m) where+    liftIO = lift . liftIO+++

@@ -0,0 +1,340 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE FlexibleInstances          #-}++module Snap.Snaplet.Internal.Types where++import           Prelude hiding ((.))+import           Control.Applicative+import           Control.Category ((.))+import           Control.Monad.CatchIO hiding (Handler)+import           Control.Monad.Reader+import           Control.Monad.State.Class+import           Control.Monad.Trans.Writer hiding (pass)+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import           Data.Configurator.Types+import           Data.IORef+import           Data.Monoid+import           Data.Lens.Lazy+import           Data.Lens.Template+import           Data.Text (Text)+import qualified Data.Text as T++import           Snap.Core+import qualified Snap.Snaplet.Internal.LensT as LT+import qualified Snap.Snaplet.Internal.Lensed as L+++------------------------------------------------------------------------------+-- | An opaque data type holding internal snaplet configuration data.  It is+-- exported publicly because the getOpaqueConfig function in MonadSnaplet+-- makes implementing new instances of MonadSnaplet more convenient.+data SnapletConfig = SnapletConfig+    { _scAncestry        :: [Text]+    , _scFilePath        :: FilePath+    , _scId              :: Maybe Text+    , _scDescription     :: Text+    , _scUserConfig      :: Config+    , _scRouteContext    :: [ByteString]+    , _reloader          :: IO (Either String String) -- might change+    }+++------------------------------------------------------------------------------+-- | Joins a reversed list of directories into a path.+buildPath :: [ByteString] -> ByteString+buildPath ps = B.intercalate "/" $ reverse ps+++------------------------------------------------------------------------------+-- | Joins a reversed list of directories into a path.+getRootURL :: SnapletConfig -> ByteString+getRootURL sc = buildPath $ _scRouteContext sc+++------------------------------------------------------------------------------+-- | Snaplet's type parameter 's' here is user-defined and can be any Haskell+-- type.  A value of type @Snaplet s@ countains a couple of things:+--+-- * a value of type @s@, called the \"user state\".+--+-- * some bookkeeping data the framework uses to plug things together, like+--   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+    }+++makeLenses [''SnapletConfig, ''Snaplet]+++------------------------------------------------------------------------------+-- | A lens referencing the opaque SnapletConfig data type held inside+-- Snaplet.+snapletConfig :: Lens (Snaplet a) SnapletConfig+++------------------------------------------------------------------------------+-- | A lens referencing the user-defined state type wrapped by a Snaplet.+snapletValue :: Lens (Snaplet a) a+++------------------------------------------------------------------------------+-- | Transforms a lens of the type you get from makeLenses to an similar lens+-- that is more suitable for internal use.+subSnaplet :: (Lens a (Snaplet b)) -> (Lens (Snaplet a) (Snaplet b))+subSnaplet = (. snapletValue)+++------------------------------------------------------------------------------+-- | The m type parameter used in the MonadSnaplet type signatures will+-- usually be either Initializer or Handler, but other monads may sometimes be+-- useful.+--+-- Minimal complete definition:+--+-- * 'withTop'', 'with'', 'getLens', and 'getOpaqueConfig'.+--+class MonadSnaplet m where+    -- | Runs a child snaplet action in the current snaplet's context.  If you+    -- think about snaplet lenses using a filesystem path metaphor, the lens+    -- supplied to this snaplet must be a relative path.  In other words, the+    -- lens's base state must be the same as the current snaplet.+    with :: (Lens v (Snaplet v'))+         -- ^ A relative lens identifying a snaplet+         -> m b v' a+         -- ^ Action from the lense's snaplet+         -> m b v a+    with = with' . subSnaplet++    -- | Like 'with' but doesn't impose the requirement that the action+    -- being run be a descendant of the current snaplet.  Using our filesystem+    -- metaphor again, the lens for this function must be an absolute+    -- path--it's base must be the same as the current base.+    withTop :: (Lens b (Snaplet v'))+            -- ^ An \"absolute\" lens identifying a snaplet+            -> m b v' a+            -- ^ Action from the lense's snaplet+            -> m b v a+    withTop l = withTop' (subSnaplet l)++    -- | A variant of 'with' accepting a lens from snaplet to snaplet.  Unlike+    -- the lens used in the above 'with' function, this lens formulation has+    -- an identity, which makes it useful in certain circumstances.  The+    -- lenses generated by 'makeLenses' will not work with this function,+    -- however the lens returned by 'getLens' will.+    --+    -- @with = with' . subSnaplet@+    with' :: (Lens (Snaplet v) (Snaplet v')) -> m b v' a -> m b v a++    -- Not providing a definition for this function in terms of withTop'+    -- allows us to avoid extra Monad type class constraints, making the type+    -- signature easier to read.+    -- with' l m = flip withTop m . (l .) =<< getLens++    -- | The absolute version of 'with''+    withTop' :: (Lens (Snaplet b) (Snaplet v')) -> m b v' a -> m b v a++    -- | Gets the lens for the current snaplet.+    getLens :: m b v (Lens (Snaplet b) (Snaplet v))++    -- | Gets the current snaplet's opaque config data type.  You'll only use+    -- this function when writing MonadSnaplet instances.+    getOpaqueConfig :: m b v SnapletConfig+    -- NOTE: We can't just use a MonadState (Snaplet v) instance for this+    -- because Initializer has SnapletConfig, but doesn't have a full Snaplet.+++------------------------------------------------------------------------------+-- | Gets a list of the names of snaplets that are direct ancestors of the+-- current snaplet.+getSnapletAncestry :: (Monad (m b v), MonadSnaplet m) => m b v [Text]+getSnapletAncestry = return . _scAncestry =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets the snaplet's path on the filesystem.+getSnapletFilePath :: (Monad (m b v), MonadSnaplet m) => m b v FilePath+getSnapletFilePath = return . _scFilePath =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets the current snaple's name.+getSnapletName :: (Monad (m b v), MonadSnaplet m) => m b v (Maybe Text)+getSnapletName = return . _scId =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets a human readable description of the snaplet.+getSnapletDescription :: (Monad (m b v), MonadSnaplet m) => m b v Text+getSnapletDescription = return . _scDescription =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets the config data structure for the current snaplet.+getSnapletUserConfig :: (Monad (m b v), MonadSnaplet m) => m b v Config+getSnapletUserConfig = return . _scUserConfig =<< getOpaqueConfig+++------------------------------------------------------------------------------+-- | Gets the base URL for the current snaplet.  Directories get added to+-- the current snaplet path by calls to 'nestSnaplet'.+getSnapletRootURL :: (Monad (m b v), MonadSnaplet m) => m b v ByteString+getSnapletRootURL = liftM getRootURL getOpaqueConfig+++------------------------------------------------------------------------------+-- | 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+-- instances.  Handler is an instance of 'MonadSnap', which means it is the+-- monad you will use to write all your application routes.  It also has a+-- 'MonadSnaplet' instance, which gives you all the functionality described+-- above.+newtype Handler b v a =+    Handler (L.Lensed (Snaplet b) (Snaplet v) Snap a)+  deriving ( Monad+           , Functor+           , Applicative+           , MonadIO+           , MonadPlus+           , MonadCatchIO+           , Alternative+           , MonadSnap)+++------------------------------------------------------------------------------+-- | Gets the @Snaplet v@ from the current snaplet's state.+getSnapletState :: Handler b v (Snaplet v)+getSnapletState = Handler get+++------------------------------------------------------------------------------+-- | Puts a new @Snaplet v@ in the current snaplet's state.+putSnapletState :: Snaplet v -> Handler b v ()+putSnapletState = Handler . put+++------------------------------------------------------------------------------+-- | Modifies the @Snaplet v@ in the current snaplet's state.+modifySnapletState :: (Snaplet v -> Snaplet v) -> Handler b v ()+modifySnapletState f = do+    s <- getSnapletState+    putSnapletState (f s)+++------------------------------------------------------------------------------+-- | Gets the @Snaplet v@ from the current snaplet's state and applies a+-- function to it.+getsSnapletState :: (Snaplet v -> b) -> Handler b1 v b+getsSnapletState f = do+    s <- getSnapletState+    return (f s)+++------------------------------------------------------------------------------+-- | The MonadState instance gives you access to the current snaplet's state.+instance MonadState v (Handler b v) where+    get = getsSnapletState _snapletValue+    put v = modifySnapletState (setL snapletValue v)+++instance MonadSnaplet Handler where+    getLens = Handler ask+    with' !l (Handler !m) = Handler $ L.with l m+    withTop' !l (Handler m) = Handler $ L.withTop l m+    getOpaqueConfig = Handler $ gets _snapletConfig+++------------------------------------------------------------------------------+-- | Handler that reloads the site.+reloadSite :: Handler b v ()+reloadSite = failIfNotLocal $ do+    cfg <- getOpaqueConfig+    !res <- liftIO $ _reloader cfg+    either bad good res+  where+    bad msg = do+        writeText $ "Error reloading site!\n\n"+        writeText $ T.pack msg+    good msg = do+        writeText $ T.pack msg+        writeText $ "Site successfully reloaded.\n"+    failIfNotLocal m = do+        rip <- liftM rqRemoteAddr getRequest+        if not $ elem rip [ "127.0.0.1"+                          , "localhost"+                          , "::1" ]+          then pass+          else m+++------------------------------------------------------------------------------+-- | Information about a partially constructed initializer.  Used to+-- automatically aggregate handlers and cleanup actions.+data InitializerState b = InitializerState+    { _isTopLevel      :: Bool+    , _cleanup         :: IO ()+    , _handlers        :: [(ByteString, Handler b b ())]+    -- ^ Handler routes built up and passed to route.+    , _hFilter         :: Handler b b () -> Handler b b ()+    -- ^ Generic filtering of handlers+    , _curConfig       :: SnapletConfig+    -- ^ This snaplet config is the incrementally built config for whatever+    -- snaplet is currently being constructed.+    , _initMessages    :: IORef Text+    }+++------------------------------------------------------------------------------+-- | Wrapper around IO actions that modify state elements created during+-- initialization.+newtype Hook a = Hook (Snaplet a -> IO (Snaplet a))+++instance Monoid (Hook a) where+    mempty = Hook return+    (Hook a) `mappend` (Hook b) = Hook (a >=> b)+++------------------------------------------------------------------------------+-- | Monad used for initializing snaplets.+newtype Initializer b v a =+    Initializer (LT.LensT (Snaplet b)+                          (Snaplet v)+                          (InitializerState b)+                          (WriterT (Hook b) IO)+                          a)+  deriving (Applicative, Functor, Monad, MonadIO)++makeLenses [''InitializerState]+++instance MonadSnaplet Initializer where+    getLens = Initializer ask+    with' !l (Initializer !m) = Initializer $ LT.with l m+    withTop' !l (Initializer m) = Initializer $ LT.withTop l m+    getOpaqueConfig = Initializer $ liftM _curConfig LT.getBase+++------------------------------------------------------------------------------+-- | 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+    }+

@@ -0,0 +1,107 @@+module Snap.Snaplet.Session++(+    SessionManager+  , withSession+  , commitSession+  , setInSession+  , getFromSession+  , deleteFromSession+  , csrfToken+  , sessionToList+  , resetSession+  , touchSession++) where++import           Control.Monad.State+import           Data.Lens.Lazy+import           Data.Text (Text)++import           Snap.Snaplet+import           Snap.Core++import           Snap.Snaplet.Session.SessionManager+                   ( SessionManager(..), ISessionManager(..) )+import qualified Snap.Snaplet.Session.SessionManager as SM++++-- | Wrap around a handler, committing any changes in the session at the end+withSession :: (Lens b (Snaplet SessionManager))+            -> Handler b v a+            -> Handler b v a+withSession l h = do+  a <- h+  withTop l commitSession+  return a+++-- | Commit changes to session within the current request cycle+commitSession :: Handler b SessionManager ()+commitSession = do+  SessionManager b <- loadSession+  liftSnap $ commit b+++-- | Set a key-value pair in the current session+setInSession :: Text -> Text -> Handler b SessionManager ()+setInSession k v = do+  SessionManager r <- loadSession+  let r' = SM.insert k v r+  put $ SessionManager r'+++-- | Get a key from the current session+getFromSession :: Text -> Handler b SessionManager (Maybe Text)+getFromSession k = do+  SessionManager r <- loadSession+  return $ SM.lookup k r+++-- | Remove a key from the current session+deleteFromSession :: Text -> Handler b SessionManager ()+deleteFromSession k = do+  SessionManager r <- loadSession+  let r' = SM.delete k r+  put $ SessionManager r'+++-- | Returns a CSRF Token unique to the current session+csrfToken :: Handler b SessionManager Text+csrfToken = do+  mgr@(SessionManager r) <- loadSession+  put mgr+  return $ SM.csrf r+++-- | Return session contents as an association list+sessionToList :: Handler b SessionManager [(Text, Text)]+sessionToList = do+  SessionManager r <- loadSession+  return $ SM.toList r+++-- | Deletes the session cookie, effectively resetting the session+resetSession :: Handler b SessionManager ()+resetSession = do+  SessionManager r <- loadSession+  r' <- liftSnap $ SM.reset r+  put $ SessionManager r'+++-- | Touch the session so the timeout gets refreshed+touchSession :: Handler b SessionManager ()+touchSession = do+  SessionManager r <- loadSession+  let r' = SM.touch r+  put $ SessionManager r'+++-- | Load the session into the manager+loadSession :: Handler b SessionManager SessionManager+loadSession = do+  SessionManager r <- get+  r' <- liftSnap $ load r+  return $ SessionManager r'+

@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Snap.Snaplet.Session.Backends.CookieSession++( initCookieSessionManager ) where++import           Control.Monad.Reader+import           Data.ByteString (ByteString)+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           Web.ClientSession++import           Snap.Core (Snap)+import           Snap.Snaplet+import           Snap.Snaplet.Session.Common (mkCSRFToken)+import           Snap.Snaplet.Session.SessionManager+import           Snap.Snaplet.Session.SecureCookie+++-- | Session data are kept in a 'HashMap' for this backend+type Session = HashMap Text Text+++-- | This is what the 'Payload' will be for the CookieSession backend+data CookieSession = CookieSession+  { csCSRFToken :: Text+  , csSession :: Session+} deriving (Eq, Show)+++instance Serialize CookieSession where+  put (CookieSession a b) = S.put (a,b)+  get                     = (\(a,b) -> CookieSession a b) `fmap` S.get++instance (Serialize k, Serialize v, Hashable k, Eq k) =>+  Serialize (HashMap k v) where+  put = S.put . HM.toList+  get = HM.fromList `fmap` S.get+++mkCookieSession :: IO CookieSession+mkCookieSession = do+  t <- liftIO $ mkCSRFToken+  return $ CookieSession t HM.empty+++-- | The manager data type to be stuffed into 'SessionManager'+data CookieSessionManager = CookieSessionManager {+    session :: Maybe CookieSession+  -- ^ Per request cache for 'CookieSession'++  , siteKey :: Key+  -- ^ A long encryption key used for secure cookie transport++  , cookieName :: ByteString+  -- ^ Cookie name for the session system++  , timeOut :: Maybe Int+  -- ^ Session cookies will be considered "stale" after this many seconds.+} deriving (Show,Typeable)+++loadDefSession :: CookieSessionManager -> IO CookieSessionManager+loadDefSession mgr@(CookieSessionManager ses _ _ _) = do+  case ses of+    Nothing -> do+      ses' <- mkCookieSession+      return $ mgr { session = Just ses' }+    Just _ -> return mgr+++modSession :: (Session -> Session) -> CookieSession -> CookieSession+modSession f (CookieSession t ses) = CookieSession t (f ses)+++-- | Initialize a cookie-backed session, returning a 'SessionManager' to be+-- stuffed inside your application's state. This 'SessionManager' will enable+-- the use of all session storage functionality defined in+-- 'Snap.Snaplet.Session'+initCookieSessionManager+  :: FilePath             -- ^ Path to site-wide encryption key+  -> ByteString           -- ^ Session cookie name+  -> Maybe Int            -- ^ Session time-out (replay attack protection)+  -> SnapletInit b SessionManager+initCookieSessionManager fp cn to =+  makeSnaplet "CookieSession" "A snaplet providing sessions via HTTP cookies."+         Nothing $ liftIO $ do+    key <- getKey fp+    return . SessionManager $ CookieSessionManager Nothing key cn to+++instance ISessionManager CookieSessionManager where+  load mgr@(CookieSessionManager r _ _ _) = do+    case r of+      Just _ -> return mgr+      Nothing -> do+        pl <- getPayload mgr+        case pl of+          Nothing -> liftIO $ loadDefSession mgr+          Just (Payload x) -> do+            let c = S.decode x+            case c of+              Left _ -> liftIO $ loadDefSession mgr+              Right cs -> return $ mgr { session = Just cs }++  commit mgr@(CookieSessionManager r _ _ _) = do+    pl <- case r of+      Just r' -> return . Payload $ S.encode r'+      Nothing -> liftIO mkCookieSession >>= return . Payload . S.encode+    setPayload mgr pl++  reset mgr = do+    cs <- liftIO mkCookieSession+    return $ mgr { session = Just cs }++  touch = id++  insert k v mgr@(CookieSessionManager r _ _ _) = case r of+    Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }+    Nothing -> mgr++  lookup k (CookieSessionManager r _ _ _) = r >>= HM.lookup k . csSession++  delete k mgr@(CookieSessionManager r _ _ _) = case r of+    Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }+    Nothing -> mgr++  csrf (CookieSessionManager r _ _ _) = case r of+    Just r' -> csCSRFToken r'+    Nothing -> ""++  toList (CookieSessionManager r _ _ _) = case r of+    Just r' -> HM.toList . csSession $ r'+    Nothing -> []++++-- | A session payload to be stored in a SecureCookie.+newtype Payload = Payload ByteString+  deriving (Eq, Show, Ord, Serialize)+++-- | Get the current client-side value+getPayload :: CookieSessionManager -> Snap (Maybe Payload)+getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr)+++-- | Set the client-side value+setPayload :: CookieSessionManager -> Payload -> Snap ()+setPayload mgr x =+    setSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr) x++

@@ -0,0 +1,41 @@+{-|++  This module contains functionality common among multiple back-ends.++-}++module Snap.Snaplet.Session.Common where+++import           Numeric+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+import           Data.Text (Text)+import           System.Random.MWC+++------------------------------------------------------------------------------+-- | Generates a random salt of given length+randomToken :: Int -> IO ByteString+randomToken n =+  let+    mk :: GenIO -> IO Int+    mk gen = uniformR (0,15) gen+  in do+    is <- withSystemRandom $ \gen -> sequence . take n . repeat $ mk gen+    return . B.pack . concat . map (flip showHex "") $ is+++------------------------------------------------------------------------------+-- | Generate a randomized CSRF token+mkCSRFToken :: IO Text+mkCSRFToken = T.decodeUtf8 `fmap` randomToken 40+++instance Serialize Text where+  put = S.put . T.encodeUtf8+  get = T.decodeUtf8 `fmap` S.get+

@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}+{-|++  This is a support module meant to back all session back-end implementations.++  It gives us an encrypted and timestamped cookie that can store an arbitrary+  serializable payload. For security, it will:++    * Encrypt its payload together with a timestamp.++    * Check the timestamp for session expiration everytime you read from the+    cookie. This will limit intercept-and-replay attacks by disallowing+    cookies older than the timeout threshold.++-}++module Snap.Snaplet.Session.SecureCookie where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans++import Data.ByteString (ByteString)+import Data.Time+import Data.Time.Clock.POSIX++import Data.Serialize+import Web.ClientSession++import Snap.Core++++------------------------------------------------------------------------------+-- | Serialize UTCTime+instance Serialize UTCTime where+    put t = put (round (utcTimeToPOSIXSeconds t) :: Integer)+    get   = posixSecondsToUTCTime . fromInteger <$> get+++------------------------------------------------------------------------------+-- | Arbitrary payload with timestamp.+type SecureCookie t = (UTCTime, t)+++------------------------------------------------------------------------------+-- Get the payload back+getSecureCookie :: (MonadSnap m, Serialize t)+                => ByteString       -- ^ Cookie name+                -> Key              -- ^ Encryption key+                -> Maybe Int        -- ^ Timeout in seconds+                -> m (Maybe t)+getSecureCookie name key timeout = do+    rqCookie <- getCookie name+    rspCookie <- getResponseCookie name `fmap` getResponse+    let ck = rspCookie `mplus` rqCookie+    let val = fmap cookieValue ck >>= decrypt key >>= return . decode+    let val' = val >>= either (const Nothing) Just+    case val' of+      Nothing -> return Nothing+      Just (ts, t) -> do+        to <- checkTimeout timeout ts+        return $ case to of+          True -> Nothing+          False -> Just t+++------------------------------------------------------------------------------+-- | Inject the payload+setSecureCookie :: (MonadSnap m, Serialize t)+                => ByteString       -- ^ Cookie name+                -> Key              -- ^ Encryption key+                -> Maybe Int        -- ^ Max age in seconds+                -> t                -- ^ Serializable payload+                -> m ()+setSecureCookie name key to val = do+    t <- liftIO getCurrentTime+    let expire = to >>= Just . flip addUTCTime t . fromIntegral+    val' <- liftIO . encryptIO key . encode $ (t, val)+    let nc = Cookie name val' expire Nothing (Just "/") False True+    modifyResponse $ addResponseCookie nc+++------------------------------------------------------------------------------+-- | Validate session against timeout policy.+--+-- * If timeout is set to 'Nothing', never trigger a time-out.+-- * Othwerwise, do a regular time-out check based on current time and given+-- timestamp.+checkTimeout :: (MonadSnap m) => Maybe Int -> UTCTime -> m Bool+checkTimeout Nothing _ = return False+checkTimeout (Just x) t0 =+  let x' = fromIntegral x+  in do+      t1 <- liftIO getCurrentTime+      return $ t1 > addUTCTime x' t0

@@ -0,0 +1,49 @@+{-# LANGUAGE ExistentialQuantification #-}++module Snap.Snaplet.Session.SessionManager where++import           Data.Text (Text)+import           Prelude hiding (lookup)++import           Snap.Core (Snap)+++-- | Any Haskell record that is a member of the 'ISessionManager' typeclass+-- can be stuffed inside a 'SessionManager' to enable all session-related+-- functionality.+data SessionManager = forall a. ISessionManager a => SessionManager a+++class ISessionManager r where++  -- | Load a session from given payload.+  --+  -- Will always be called before any other operation. If possible, cache and+  -- do nothing when called multiple times within the same request cycle.+  load :: r -> Snap r++  -- | Commit session, return a possibly updated paylaod+  commit :: r -> Snap ()++  -- | Reset session+  reset :: r -> Snap r++  -- | Touch session+  touch :: r -> r++  -- | Insert a key-value pair into session+  insert :: Text -> Text -> r -> r++  -- | Lookup a key in session+  lookup :: Text -> r -> (Maybe Text)++  -- | Delete a key in session+  delete :: Text -> r -> r++  -- | Return a session-specific CSRF protection token. See 'mkCSRFToken' for+  -- help in creating the value.+  csrf :: r -> Text++  -- | Return all key-value pairs as an association list+  toList :: r -> [(Text,Text)]+

@@ -19,8 +19,9 @@  ------------------------------------------------------------------------------ -- Creates a value tDir :: ([String], [(String, String)])-$(buildData "tDirBareBones" "barebones")-$(buildData "tDirDefault"   "default")+buildData "tDirBareBones" "barebones"+buildData "tDirDefault" "default"+buildData "tDirTutorial" "tutorial"  ------------------------------------------------------------------------------ usage :: String@@ -41,9 +42,30 @@   -------------------------------------------------------------------------------data InitFlag = InitBareBones-              | InitHelp-              | InitExtensions+initUsage :: String+initUsage = unlines+    [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter"+    , ""+    , "Usage:"+    , ""+    , "  snap init [type]"+    , ""+    , "    [type] can be one of:"+    , "      default   - A default project using snaplets and heist"+    , "      barebones - A barebones project with minimal dependencies"+    , "      tutorial  - The literate Haskell tutorial project"+    , ""+    , "  If [type] is omitted, the default project is generated."+    ]+++printUsage :: [String] -> IO ()+printUsage ("init":_) = putStrLn initUsage+printUsage _ = putStrLn usage++------------------------------------------------------------------------------+-- Only one option for now+data Option = Help   deriving (Show, Eq)  @@ -65,42 +87,43 @@ initProject :: [String] -> IO () initProject args = do     case getOpt Permute options args of-      (flags, _, [])-        | InitHelp `elem` flags -> do putStrLn initUsage-                                      exitFailure-        | otherwise             -> init' flags+      (flags, other, [])+        | Help `elem` flags -> do printUsage other+                                  exitFailure+        | otherwise         -> go other+      (_, other, errs) -> do putStrLn $ concat errs+                             printUsage other+                             exitFailure -      (_, _, errs) -> do putStrLn $ concat errs-                         putStrLn initUsage-                         exitFailure   where-    initUsage = usageInfo "Usage\n  snap init\n\nOptions:" options-     options =-        [ Option ['b'] ["barebones"]  (NoArg InitBareBones)-                 "Depend only on -core and -server"-        , Option ['h'] ["help"]       (NoArg InitHelp)+        [ Option ['h'] ["help"]       (NoArg Help)                  "Print this message"-        , Option ['e'] ["extensions"] (NoArg InitExtensions)-                 "Depend on snap w/ extensions (default)"         ] -    init' flags = do+    go ("init":rest) = init' rest+    go _ = do+        putStrLn "Error: Invalid action!"+        putStrLn usage+        exitFailure++    init' args' = do         cur <- getCurrentDirectory         let dirs = splitDirectories cur             projName = last dirs             setup' = setup projName-        case flags of-          (_:_) | InitBareBones  `elem` flags -> setup' tDirBareBones-                | InitExtensions `elem` flags -> setup' tDirDefault-          _                                   -> setup' tDirDefault+        case args' of+          []            -> setup' tDirDefault+          ["barebones"] -> setup' tDirBareBones+          ["default"]   -> setup' tDirDefault+          ["tutorial"]  -> setup' tDirTutorial+          _             -> do+            putStrLn initUsage+            exitFailure   ------------------------------------------------------------------------------ main :: IO () main = do     args <- getArgs-    case args of-        ("init":args') -> initProject args'-        _              -> do putStrLn usage-                             exitFailure+    initProject args

@@ -7,6 +7,7 @@ import           Language.Haskell.TH import           Language.Haskell.TH.Syntax import           System.Directory.Tree+import           System.FilePath ------------------------------------------------------------------------------  @@ -30,19 +31,18 @@ -- encountered and a list of filenames and content strings. readTree :: FilePath -> IO ([DirData], [FileData]) readTree dir = do-    d <- readDirectory $ dir ++ "/."+    d <- readDirectory $ dir </> "."     let ps = zipPaths $ "" :/ (free d)         fd = F.foldr (:) [] ps-        dirs = tail . getDirs [] $ free d--    return (dirs, fd)+        dirs = getDirs [] $ free d+    return (drop 1 dirs, fd)   ------------------------------------------------------------------------------ -- Calls readTree and returns it's value in a quasiquote. dirQ :: FilePath -> Q Exp dirQ tplDir = do-    d <- runIO . readTree $ "project_template/" ++ tplDir+    d <- runIO . readTree $ "project_template" </> tplDir     lift d  

@@ -1,21 +0,0 @@-#!/bin/sh--set -e--if [ -z "$DEBUG" ]; then-    export DEBUG=testsuite-fi--SUITE=./dist/build/testsuite/testsuite--if [ ! -f $SUITE ]; then-    cat <<EOF-Testsuite executable not found, please run:-    cabal configure -ftest-then-    cabal build-EOF-    exit;-fi--./dist/build/testsuite/testsuite -j1 $*

@@ -0,0 +1,62 @@+#!/bin/sh++set -e++if [ -z "$DEBUG" ]; then+    export DEBUG=snap-testsuite+fi++SUITE=./dist/build/snap-testsuite/snap-testsuite++rm -f snap-testsuite.tix++if [ ! -f $SUITE ]; then+    cat <<EOF+Testsuite executable not found, please run:+    cabal configure+then+    cabal build+EOF+    exit;+fi++$SUITE $*++killall -HUP snap-testsuite++DIR=dist/hpc++rm -Rf $DIR+mkdir -p $DIR++EXCLUDES='Main+Blackbox.App+Blackbox.BarSnaplet+Blackbox.Common+Blackbox.EmbeddedSnaplet+Blackbox.FooSnaplet+Blackbox.Tests+Blackbox.Types+Snap.Snaplet.Internal.Lensed.Tests+Snap.Snaplet.Internal.LensT.Tests+Snap.Snaplet.Internal.RST.Tests+Snap.Snaplet.Internal.Tests+Snap.TestCommon+'++EXCL=""++for m in $EXCLUDES; do+    EXCL="$EXCL --exclude=$m"+done++rm -f non-cabal-appdir/templates/bad.tpl+rm -f non-cabal-appdir/templates/good.tpl+rm -fr non-cabal-appdir/snaplets/foosnaplet++hpc markup $EXCL --destdir=$DIR snap-testsuite >/dev/null 2>&1++cat <<EOF++Test coverage report written to $DIR.+EOF

@@ -3,23 +3,107 @@ build-type:     Simple cabal-version:  >= 1.6 -Executable testsuite-  hs-source-dirs:  suite+Executable snap-testsuite+  hs-source-dirs:  ../src suite   main-is:         TestSuite.hs    build-depends:-    QuickCheck >= 2.3.0.2,-    base >= 4 && < 5,-    bytestring == 0.9.*,+    Glob                       >= 0.5 && < 0.7,+    HUnit                      >= 1.2 && < 2,+    MonadCatchIO-transformers  >= 0.2 && < 0.3,+    QuickCheck                 >= 2.3.0.2,+    attoparsec                 (>= 0.8   && < 0.10),+    base                       >= 4 && < 5,+    bytestring                 >= 0.9 && < 0.10,+    containers                 >= 0.3,+    data-lens                  >= 2.0.1 && < 2.1,+    data-lens-template         >= 2.1.1 && < 2.2,     directory,+    directory-tree             >= 0.10 && < 0.11,     filepath,-    Glob == 0.5.*,-    HUnit >= 1.2 && < 2,-    http-enumerator >= 0.7 && <0.8,-    process == 1.*,-    test-framework >= 0.3.1 && <0.5,-    test-framework-hunit >= 0.2.5 && < 0.3,-    test-framework-quickcheck2 >= 0.2.6 && < 0.3-    -  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded+    heist                      >= 0.6 && < 0.7,+    http-enumerator            >= 0.6.5.3 && < 0.8,+    mtl                        >= 2,+    process                    == 1.*,+    snap-core                  >= 0.6 && < 0.7,+    snap-server                >= 0.6 && < 0.7,+    test-framework             >= 0.4 && < 0.5,+    test-framework-hunit       >= 0.2.5 && < 0.3,+    test-framework-quickcheck2 >= 0.2.6 && < 0.3,+    text                       >= 0.11 && < 0.12,+    transformers               >= 0.2,+    unix                       >= 2.2.0.0 && < 2.6,+    utf8-string                >= 0.3   && < 0.4,+    template-haskell+-- FIXME++  ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded                -fno-warn-unused-do-bind+++Executable app+  hs-source-dirs:  ../src suite+  main-is:         AppMain.hs++  build-depends:+    MonadCatchIO-transformers  >= 0.2 && < 0.3,+    attoparsec                 (>= 0.8   && < 0.10),+    base                       >= 4 && < 5,+    bytestring                 >= 0.9 && < 0.10,+    cereal                     >= 0.3,+    clientsession              >= 0.6.0,+    configurator               == 0.1.*,+    containers                 >= 0.3,+    data-lens                  >= 2.0.1 && < 2.1,+    data-lens-template         >= 2.1.1 && < 2.2,+    directory,+    directory-tree             >= 0.10 && < 0.11,+    filepath,+    hashable                   >= 1.1,+    heist                      >= 0.6 && < 0.7,+    mtl                        >= 2,+    mwc-random                 >= 0.8,+    process                    == 1.*,+    snap-core                  >= 0.6 && < 0.7,+    snap-server                >= 0.6 && < 0.7,+    syb                        >= 0.1,+    time                       >= 1.1,+    text                       >= 0.11 && < 0.12,+    transformers               >= 0.2,+    unordered-containers       >= 0.1.4,+    utf8-string                >= 0.3   && < 0.4,+    template-haskell+    --FIXME++  ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded+               -fno-warn-unused-do-bind++Executable nesttest+  hs-source-dirs:  ../src suite+  main-is:         NestTest.hs++  build-depends:+    MonadCatchIO-transformers  >= 0.2 && < 0.3,+    attoparsec                 (>= 0.8   && < 0.10),+    base                       >= 4 && < 5,+    bytestring                 >= 0.9 && < 0.10,+    containers                 >= 0.3,+    data-lens                  >= 2.0.1 && < 2.1,+    data-lens-template         >= 2.1 && < 2.2,+    directory,+    directory-tree             >= 0.10 && < 0.11,+    filepath,+    heist                      >= 0.6 && < 0.7,+    mtl                        >= 2,+    process                    == 1.*,+    snap-core                  >= 0.6 && < 0.7,+    snap-server                >= 0.6 && < 0.7,+    text                       >= 0.11 && < 0.12,+    transformers               >= 0.2,+    utf8-string                >= 0.3   && < 0.4,+    template-haskell+    --FIXME++  ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded+               -fno-warn-unused-do-bind+

@@ -16,7 +16,9 @@ import System.FilePath.Glob import System.Process hiding (cwd) +import SafeCWD + testGeneratedProject :: String  -- ^ project name and directory                      -> String  -- ^ arguments to @snap init@                      -> String  -- ^ arguments to @cabal install@@@ -24,23 +26,28 @@                      -> IO ()   -- ^ action to run when the server goes up                      -> IO () testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort-                     testAction = bracket initialize cleanup (const testAction)-  where-    initialize = do-        cwd <- getCurrentDirectory-        let projectPath = cwd </> projName-        flip onException (setCurrentDirectory cwd >>-                          removeDirectoryRecursive projectPath) $ do-            makeWorkDirectory projectPath-            setCurrentDirectory projectPath+                     testAction = do+    cwd <- getCurrentDirectory+    let segments = reverse $ splitPath cwd+        projectPath = cwd </> "test-snap-exe" </> projName+        snapRoot = joinPath $ reverse $ drop 1 segments+        snapRepos = joinPath $ reverse $ drop 2 segments++        sandbox = cwd </> "test-cabal-dev"++        cabalDevArgs = "-s " ++ sandbox++        args = cabalDevArgs ++ " " ++ cabalInstallArgs ++        initialize = do             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   =  "../.."+            snapCoreSrc   <- fromEnv "SNAP_CORE_SRC" $ snapRepos </> "snap-core"+            snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $ snapRepos </> "snap-server"+            xmlhtmlSrc    <- fromEnv "XMLHTML_SRC" $ snapRepos </> "xmlhtml"+            heistSrc      <- fromEnv "HEIST_SRC" $ snapRepos </> "heist"+            let snapSrc   =  snapRoot              forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap" ]                   (pkgCleanUp sandbox)@@ -56,24 +63,32 @@             putStrLn $ "Running \"" ++ cmd ++ "\""             pHandle <- runCommand cmd             waitABit-            return (cwd, projectPath, pHandle)+            return pHandle +        findSnap = do+            home <- fromEnv "HOME" "."+            p1 <- gimmeIfExists $ snapRoot </> "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])++    putStrLn $ "Changing directory to "++projectPath+    inDir True projectPath $ bracket initialize cleanup (const testAction)+    removeDirectoryRecursiveSafe projectPath+  where+     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+    cleanup pHandle = do         terminateProcess pHandle         waitForProcess pHandle-        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@@ -83,23 +98,11 @@             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     putStrLn $ "Running \"" ++ s ++ "\""@@ -107,9 +110,3 @@   where     check ExitSuccess = return ()     check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"---makeWorkDirectory :: FilePath -> IO ()-makeWorkDirectory p = do-    doesDirectoryExist p >>= flip when (removeDirectoryRecursive p)-    createDirectory p

@@ -2,34 +2,83 @@  module Main where +import           Control.Concurrent+import           Control.Exception import           Control.Monad import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import qualified Network.HTTP.Enumerator as HTTP-import           Test.Framework (defaultMain, Test)+import           Snap.Http.Server.Config+import           Snap.Snaplet+import           System.Posix.Process+import           System.Posix.Types+--import           Test.Framework (defaultMain, Test)+import           Test.Framework import           Test.Framework.Providers.HUnit import           Test.HUnit hiding (Test, path) +import           Snap.Http.Server (simpleHttpServe)+import           Blackbox.App+import qualified Blackbox.Tests+import qualified Snap.Snaplet.Internal.Lensed.Tests+import qualified Snap.Snaplet.Internal.LensT.Tests+import qualified Snap.Snaplet.Internal.RST.Tests+import qualified Snap.Snaplet.Internal.Tests import           Snap.TestCommon +import SafeCWD+++------------------------------------------------------------------------------ main :: IO ()-main = defaultMain tests-  where tests = [ testBarebones+main = do+    Blackbox.Tests.remove "non-cabal-appdir/templates/bad.tpl"+    Blackbox.Tests.remove "non-cabal-appdir/templates/good.tpl"+    Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet"++    inDir False "non-cabal-appdir" startServer+    threadDelay $ 2*10^(6::Int)+    defaultMain tests++  where tests = [ internalServerTests                 , testDefault+                , testBarebones+                , testTutorial                 ]  +internalServerTests :: Test+internalServerTests =+    testGroup "internal server tests"+        [ Blackbox.Tests.tests+        , Snap.Snaplet.Internal.Lensed.Tests.tests+        , Snap.Snaplet.Internal.LensT.Tests.tests+        , Snap.Snaplet.Internal.RST.Tests.tests+        , Snap.Snaplet.Internal.Tests.tests+        ]++startServer :: IO ProcessID+startServer = forkProcess $ serve (setPort 9753 defaultConfig) app+  where+    serve config initializer = do+        (_, handler, doCleanup) <- runSnaplet initializer+        (conf, site)            <- combineConfig config handler+        _ <- try $ simpleHttpServe conf $ site+             :: IO (Either SomeException ())+        doCleanup++ testBarebones :: Test testBarebones = testCase "snap/barebones" go   where     go = testGeneratedProject "barebonesTest"-                              "-b"+                              "barebones"                               ""                               port                               testIt     port = 9990     testIt = do-        body <- HTTP.simpleHttp "http://127.0.0.1:9990"+        body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)         assertEqual "server not up" "hello world" body  @@ -44,9 +93,22 @@     port = 9991     testIt = do         body <- liftM (S.concat . L.toChunks) $-                HTTP.simpleHttp "http://127.0.0.1:9991"+                HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)         assertBool "response contains phrase 'it works!'"                    $ "It works!" `S.isInfixOf` body  --- TODO: test hint code here+testTutorial :: Test+testTutorial = testCase "snap/tutorial" go+  where+    go = testGeneratedProject "tutorialTest"+                              "tutorial"+                              ""+                              port+                              testIt+    port = 9992+    testIt = do+        body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)++"/hello"+        assertEqual "server not up" "hello world" body++