packages feed

snap 0.7 → 0.8.0

raw patch · 83 files changed

+3325/−1671 lines, 83 filesdep −Cryptodep −safedep −skeindep ~aesondep ~filepathdep ~heist

Dependencies removed: Crypto, safe, skein

Dependency ranges changed: aeson, filepath, heist, mwc-random, old-time, snap-core, snap-server, stm, template-haskell, unordered-containers

Files

project_template/barebones/foo.cabal view
@@ -19,8 +19,8 @@     bytestring >= 0.9.1 && < 0.10,     MonadCatchIO-transformers >= 0.2.1 && < 0.3,     mtl >= 2 && < 3,-    snap-core   == 0.7.*,-    snap-server == 0.7.*+    snap-core   == 0.8.*,+    snap-server == 0.8.*    if impl(ghc >= 6.12.0)     ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
project_template/default/foo.cabal view
@@ -26,9 +26,9 @@     heist >= 0.7 && < 0.8,     MonadCatchIO-transformers >= 0.2.1 && < 0.3,     mtl >= 2 && < 3,-    snap == 0.7.*,-    snap-core   == 0.7.*,-    snap-server == 0.7.*,+    snap == 0.8.*,+    snap-core   == 0.8.*,+    snap-server == 0.8.*,     text >= 0.11 && < 0.12,     time >= 1.1 && < 1.5,     xmlhtml == 0.1.*
− project_template/default/resources/static/screen.css 
@@ -1,26 +0,0 @@-html {-   padding: 0;-   margin: 0;-   background-color: #ffffff;-   font-family: Verdana, Helvetica, sans-serif;-}-body {-   padding: 0;-   margin: 0;-}-a {-   text-decoration: underline;-}-a :hover {-   cursor: pointer;-   text-decoration: underline;-}-img {-   border: none;-}-#content {-   padding-left: 1em;-}-#info {-   font-size: 60%;-}
− project_template/default/resources/templates/echo.tpl 
@@ -1,13 +0,0 @@-<html>-  <head>-    <title>Echo Page</title>-  </head>-  <body>-    <div id="content">-      <h1>Is there an echo in here?</h1>-    </div>-    <p>You wanted me to say this?</p>-    <p>"<message/>"</p>-    <p><a href="/">Return</a></p>-  </body>-</html>
− project_template/default/resources/templates/index.tpl 
@@ -1,32 +0,0 @@-<html>-  <head>-    <title>Snap web server</title>-    <link rel="stylesheet" type="text/css" href="/screen.css"/>-  </head>-  <body>-    <div id="content">-      <h1>It works!</h1>-      <p>-        This is a simple demo page served using-        <a href="http://snapframework.com/docs/tutorials/heist">Heist</a>-        and the <a href="http://snapframework.com/">Snap</a> web framework.-      </p>-      <p>-        Echo test:-        <a href="/echo/cats">cats</a>-        <a href="/echo/dogs">dogs</a>-        <a href="/echo/fish">fish</a>-      </p>-      <table id="info">-        <tr>-          <td>Config generated at:</td>-          <td><start-time/></td>-        </tr>-        <tr>-          <td>Page generated at:</td>-          <td><current-time/></td>-        </tr>-      </table>-    </div>-  </body>-</html>
+ project_template/default/snaplets/heist/templates/echo.tpl view
@@ -0,0 +1,13 @@+<html>+  <head>+    <title>Echo Page</title>+  </head>+  <body>+    <div id="content">+      <h1>Is there an echo in here?</h1>+    </div>+    <p>You wanted me to say this?</p>+    <p>"<message/>"</p>+    <p><a href="/">Return</a></p>+  </body>+</html>
+ project_template/default/snaplets/heist/templates/index.tpl view
@@ -0,0 +1,32 @@+<html>+  <head>+    <title>Snap web server</title>+    <link rel="stylesheet" type="text/css" href="/screen.css"/>+  </head>+  <body>+    <div id="content">+      <h1>It works!</h1>+      <p>+        This is a simple demo page served using+        <a href="http://snapframework.com/docs/tutorials/heist">Heist</a>+        and the <a href="http://snapframework.com/">Snap</a> web framework.+      </p>+      <p>+        Echo test:+        <a href="/echo/cats">cats</a>+        <a href="/echo/dogs">dogs</a>+        <a href="/echo/fish">fish</a>+      </p>+      <table id="info">+        <tr>+          <td>Config generated at:</td>+          <td><start-time/></td>+        </tr>+        <tr>+          <td>Page generated at:</td>+          <td><current-time/></td>+        </tr>+      </table>+    </div>+  </body>+</html>
project_template/default/src/Application.hs view
@@ -1,29 +1,30 @@ {-# LANGUAGE TemplateHaskell #-} -{---This module defines our application's state type and an alias for its handler-monad.---}-+------------------------------------------------------------------------------+-- | This module defines our application's state type and an alias for its+--   handler monad.+-- module Application where +------------------------------------------------------------------------------ import Data.Lens.Template import Data.Time.Clock- import Snap.Snaplet import Snap.Snaplet.Heist +------------------------------------------------------------------------------ data App = App     { _heist :: Snaplet (Heist App)     , _startTime :: UTCTime     } -type AppHandler = Handler App App- makeLens ''App  instance HasHeist App where     heistLens = subSnaplet heist+++------------------------------------------------------------------------------+type AppHandler = Handler App App+
project_template/default/src/Main.hs view
@@ -1,18 +1,15 @@-{-# LANGUAGE CPP #-}+{-# 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@@ -22,65 +19,60 @@ #endif  -{-|--This is the entry point for this web server application.  It supports-easily switching between interpreting source and running statically-compiled code.--In either mode, the generated program should be run from the root of-the project tree.  When it is run, it locates its templates, static-content, and source files in development mode, relative to the current-working directory.--When compiled with the development flag, only changes to the-libraries, your cabal file, or this file should require a recompile to-be picked up.  Everything else is interpreted at runtime.  There are a-few consequences of this.--First, this is much slower.  Running the interpreter takes a-significant chunk of time (a couple tenths of a second on the author's-machine, at this time), regardless of the simplicity of the loaded-code.  In order to recompile and re-load server state as infrequently-as possible, the source directories are watched for updates, as are-any extra directories specified below.--Second, the generated server binary is MUCH larger, since it links in-the GHC API (via the hint library).--Third, and the reason you would ever want to actually compile with-development mode, is that it enables a faster development cycle. You-can simply edit a file, save your changes, and hit reload to see your-changes reflected immediately.--When this is compiled without the development flag, all the actions-are statically compiled in.  This results in faster execution, a-smaller binary size, and having to recompile the server for any code-change.---}+------------------------------------------------------------------------------+-- | This is the entry point for this web server application. It supports+-- easily switching between interpreting source and running statically compiled+-- code.+--+-- In either mode, the generated program should be run from the root of the+-- project tree. When it is run, it locates its templates, static content, and+-- source files in development mode, relative to the current working directory.+--+-- When compiled with the development flag, only changes to the libraries, your+-- cabal file, or this file should require a recompile to be picked up.+-- Everything else is interpreted at runtime. There are a few consequences of+-- this.+--+-- First, this is much slower. Running the interpreter takes a significant+-- chunk of time (a couple tenths of a second on the author's machine, at this+-- time), regardless of the simplicity of the loaded code. In order to+-- recompile and re-load server state as infrequently as possible, the source+-- directories are watched for updates, as are any extra directories specified+-- below.+--+-- Second, the generated server binary is MUCH larger, since it links in the+-- GHC API (via the hint library).+--+-- Third, and the reason you would ever want to actually compile with+-- development mode, is that it enables a faster development cycle. You can+-- simply edit a file, save your changes, and hit reload to see your changes+-- reflected immediately.+--+-- When this is compiled without the development flag, all the actions are+-- statically compiled in. This results in faster execution, a smaller binary+-- size, and having to recompile the server for any code 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.+    -- 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"])+                                          ["snaplets/heist/templates"])      _ <- try $ httpServe conf $ site :: IO (Either SomeException ())     cleanup  --- | 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+------------------------------------------------------------------------------+-- | 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@@ -89,16 +81,15 @@ getConf = commandLineConfig defaultConfig  --- | 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.+------------------------------------------------------------------------------+-- | 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.+-- 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.
project_template/default/src/Site.hs view
@@ -1,17 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} -{-|--This is where all the routes and handlers are defined for your site. The-'app' function is the initializer that combines everything together and-is exported by this module.---}-+------------------------------------------------------------------------------+-- | This module is where all the routes and handlers are defined for your+--   site. The 'app' function is the initializer that combines everything+--   together and is exported by this module.+-- module Site   ( app   ) where +------------------------------------------------------------------------------ import           Control.Applicative import           Control.Monad.Trans import           Control.Monad.State@@ -26,7 +24,7 @@ import           Snap.Util.FileServe import           Text.Templating.Heist import           Text.XmlHtml hiding (render)-+------------------------------------------------------------------------------ import           Application  @@ -77,7 +75,7 @@ routes = [ ("/",            index)          , ("/echo/:stuff", echo)          , ("", with heist heistServe)-         , ("", serveDirectory "resources/static")+         , ("", serveDirectory "static")          ]  ------------------------------------------------------------------------------@@ -85,7 +83,7 @@ app :: SnapletInit App App app = makeSnaplet "app" "An snaplet example application." Nothing $ do     sTime <- liftIO getCurrentTime-    h <- nestSnaplet "heist" heist $ heistInit "resources/templates"+    h <- nestSnaplet "heist" heist $ heistInit "templates"     addRoutes routes     return $ App h sTime
+ project_template/default/static/screen.css view
@@ -0,0 +1,26 @@+html {+   padding: 0;+   margin: 0;+   background-color: #ffffff;+   font-family: Verdana, Helvetica, sans-serif;+}+body {+   padding: 0;+   margin: 0;+}+a {+   text-decoration: underline;+}+a :hover {+   cursor: pointer;+   text-decoration: underline;+}+img {+   border: none;+}+#content {+   padding-left: 1em;+}+#info {+   font-size: 60%;+}
project_template/tutorial/foo.cabal view
@@ -19,9 +19,9 @@     bytestring >= 0.9.1 && < 0.10,     MonadCatchIO-transformers >= 0.2.1 && < 0.3,     mtl >= 2 && < 3,-    snap        == 0.7.*,-    snap-core   == 0.7.*,-    snap-server == 0.7.*+    snap        == 0.8.*,+    snap-core   == 0.8.*,+    snap-server == 0.8.*    if impl(ghc >= 6.12.0)     ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
snap.cabal view
@@ -1,5 +1,5 @@ name:           snap-version:        0.7+version:        0.8.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@@ -24,9 +24,9 @@   project_template/default/foo.cabal,   project_template/default/log/access.log,   project_template/default/log/error.log,-  project_template/default/resources/static/screen.css,-  project_template/default/resources/templates/echo.tpl,-  project_template/default/resources/templates/index.tpl,+  project_template/default/static/screen.css,+  project_template/default/snaplets/heist/templates/echo.tpl,+  project_template/default/snaplets/heist/templates/index.tpl,   project_template/default/src/Application.hs,   project_template/default/src/Main.hs,   project_template/default/src/Site.hs,@@ -40,8 +40,38 @@   extra/logo.gif,   test/snap-testsuite.cabal,   test/runTestsAndCoverage.sh,+  test/suite/TestSuite.hs,+  test/suite/NestTest.hs,   test/suite/Snap/TestCommon.hs,-  test/suite/TestSuite.hs+  test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs,+  test/suite/Snap/Snaplet/Internal/RST/Tests.hs,+  test/suite/Snap/Snaplet/Internal/Tests.hs,+  test/suite/Snap/Snaplet/Internal/LensT/Tests.hs,+  test/suite/Blackbox/Types.hs,+  test/suite/Blackbox/FooSnaplet.hs,+  test/suite/Blackbox/BarSnaplet.hs,+  test/suite/Blackbox/Common.hs,+  test/suite/Blackbox/EmbeddedSnaplet.hs,+  test/suite/Blackbox/Tests.hs,+  test/suite/Blackbox/App.hs,+  test/suite/SafeCWD.hs,+  test/suite/AppMain.hs,+  test/non-cabal-appdir/db.cfg,+  test/non-cabal-appdir/bad.tpl,+  test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl,+  test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl,+  test/non-cabal-appdir/snaplets/baz/snaplet.cfg,+  test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl,+  test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl,+  test/non-cabal-appdir/snaplets/heist/templates/index.tpl,+  test/non-cabal-appdir/snaplets/heist/templates/session.tpl,+  test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl,+  test/non-cabal-appdir/snaplets/heist/templates/page.tpl,+  test/non-cabal-appdir/good.tpl,+  test/non-cabal-appdir/log/placeholder,+  test/non-cabal-appdir/snaplet.cfg,+  test/foosnaplet/templates/foopage.tpl,+  test/foosnaplet/snaplet.cfg  Flag hint   Description: Support dynamic project reloading via hint@@ -59,16 +89,17 @@     Snap.Snaplet.Auth,     Snap.Snaplet.Auth.Backends.JsonFile,     Snap.Snaplet.Session,+    Snap.Snaplet.Session.Common,     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,+    Control.Access.RoleBased.Checker,+    Control.Access.RoleBased.Role,+    Control.Access.RoleBased.Types,+    Control.Access.RoleBased.Internal.Role,+    Control.Access.RoleBased.Internal.RoleMap,+    Control.Access.RoleBased.Internal.Rule,+    Control.Access.RoleBased.Internal.Types,     Snap.Snaplet.Auth.AuthManager,     Snap.Snaplet.Auth.Types,     Snap.Snaplet.Auth.Handlers,@@ -79,7 +110,6 @@     Snap.Snaplet.Internal.Lensed,     Snap.Snaplet.Internal.RST,     Snap.Snaplet.Internal.Types-    Snap.Snaplet.Session.Common,     Snap.Snaplet.Session.SecureCookie,     Snap.Snaplet.Session.SessionManager @@ -99,9 +129,8 @@       unix                    >= 2.2.0.0 && < 2.6    build-depends:-    Crypto                    >= 4.2      && < 4.3,     MonadCatchIO-transformers >= 0.2      && < 0.3,-    aeson                     >= 0.4      && < 0.5,+    aeson                     >= 0.6      && < 0.7,     attoparsec                >= 0.10     && < 0.11,     base                      >= 4        && < 5,     bytestring                >= 0.9.1    && < 0.10,@@ -113,25 +142,22 @@     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,+    filepath                  >= 1.1      && < 1.4,     hashable                  >= 1.1      && < 1.2,-    heist                     >= 0.7      && < 0.8,+    heist                     >= 0.7      && < 0.9,     logict                    >= 0.4.2    && < 0.6,     mtl                       >  2.0      && < 2.1,-    mwc-random                >= 0.8      && < 0.11,-    old-time                  >= 1.0      && < 1.1,+    mwc-random                >= 0.8      && < 0.13,     pwstore-fast              >= 2.2      && < 2.3,-    safe                      >= 0.3      && < 0.4,-    skein                     >= 0.1.0.3  && < 0.2,-    snap-core                 >= 0.7      && < 0.8,-    snap-server               >= 0.7      && < 0.8,-    stm                       >= 2.2      && < 2.3,+    snap-core                 >= 0.8      && < 0.9,+    snap-server               >= 0.8      && < 0.9,+    stm                       >= 2.2      && < 2.4,     syb                       >= 0.1      && < 0.4,-    template-haskell          >= 2.2      && < 2.7,+    template-haskell          >= 2.2      && < 2.8,     text                      >= 0.11     && < 0.12,     time                      >= 1.1      && < 1.5,     transformers              >= 0.2      && < 0.3,-    unordered-containers      >= 0.1.4    && < 0.2,+    unordered-containers      >= 0.1.4    && < 0.3,     utf8-string               >= 0.3      && < 0.4,     vector                    >= 0.7.1    && < 0.10,     vector-algorithms         >= 0.4      && < 0.6,@@ -175,10 +201,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.7     && < 0.8,-    template-haskell    >= 2.2     && < 2.7,+    filepath            >= 1.1     && < 1.4,+    old-time            >= 1.0     && < 1.2,+    snap-server         >= 0.8     && < 0.9,+    template-haskell    >= 2.2     && < 2.8,     text                >= 0.11    && < 0.12    ghc-prof-options: -prof -auto-all
+ src/Control/Access/RoleBased/Checker.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}++module Control.Access.RoleBased.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           Control.Access.RoleBased.Internal.RoleMap (RoleMap)+import qualified Control.Access.RoleBased.Internal.RoleMap as RM+import           Control.Access.RoleBased.Internal.Types+import           Control.Access.RoleBased.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"
+ src/Control/Access/RoleBased/Internal/Role.hs view
@@ -0,0 +1,87 @@+module Control.Access.RoleBased.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]+    }
+ src/Control/Access/RoleBased/Internal/RoleMap.hs view
@@ -0,0 +1,60 @@+module Control.Access.RoleBased.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           Control.Access.RoleBased.Role+import           Control.Access.RoleBased.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
+ src/Control/Access/RoleBased/Internal/Rule.hs view
@@ -0,0 +1,37 @@+module Control.Access.RoleBased.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           Control.Access.RoleBased.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
+ src/Control/Access/RoleBased/Internal/Types.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++module Control.Access.RoleBased.Internal.Types+  ( module Control.Access.RoleBased.Internal.Role+  , module Control.Access.RoleBased.Internal.Rule+  , RoleMonad(..)+  , RuleChecker(..)+  ) where++------------------------------------------------------------------------------+import           Control.Applicative+import           Control.Monad.Reader+import           Control.Monad.Logic+------------------------------------------------------------------------------+import           Control.Access.RoleBased.Internal.Role+import           Control.Access.RoleBased.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)+
+ src/Control/Access/RoleBased/Role.hs view
@@ -0,0 +1,25 @@+module Control.Access.RoleBased.Role where++------------------------------------------------------------------------------+import qualified Data.HashMap.Strict as M+import           Control.Access.RoleBased.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
+ src/Control/Access/RoleBased/Types.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++module Control.Access.RoleBased.Types+  ( Role(..)                    -- fixme: remove (..)+  , RoleValue(..)               -- fixme+  , RoleValueMeta(..)+  , RoleDataDefinition(..)+  , RoleMetadata(..)+  , Rule+  , RuleChecker+  ) where++import Control.Access.RoleBased.Internal.Types
− src/Data/RBAC/Checker.hs 
@@ -1,223 +0,0 @@-{-# 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"
− src/Data/RBAC/Internal/Role.hs 
@@ -1,81 +0,0 @@-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]-    }
− src/Data/RBAC/Internal/RoleMap.hs 
@@ -1,58 +0,0 @@-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
− src/Data/RBAC/Internal/Rule.hs 
@@ -1,31 +0,0 @@-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
− src/Data/RBAC/Internal/Types.hs 
@@ -1,33 +0,0 @@-{-# 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)-
− src/Data/RBAC/Role.hs 
@@ -1,24 +0,0 @@-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
− src/Data/RBAC/Types.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}--module Data.RBAC.Types-  ( Role(..)                    -- fixme: remove (..)-  , RoleValue(..)               -- fixme-  , RoleValueMeta(..)-  , RoleDataDefinition(..)-  , RoleMetadata(..)-  , Rule-  , RuleChecker-  ) where--import Data.RBAC.Internal.Types
src/Snap/Loader/Devel.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE CPP             #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}++------------------------------------------------------------------------------ -- | 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@@ -9,22 +11,18 @@   ( loadSnapTH   ) where +------------------------------------------------------------------------------ #ifdef HINT_ENABLED import           Control.Monad (liftM2)- import           Data.Char (isAlphaNum) import           Data.List import           Data.Maybe (maybeToList) import           Data.Time.Clock (diffUTCTime, getCurrentTime) import           Data.Typeable- import           Language.Haskell.Interpreter hiding (lift, liftIO, typeOf) import           Language.Haskell.Interpreter.Unsafe- import           Language.Haskell.TH- import           System.Environment (getArgs)- import           Snap.Core import           Snap.Loader.Devel.Signal import           Snap.Loader.Devel.Evaluator@@ -33,49 +31,48 @@ import           Language.Haskell.TH #endif + --------------------------------------------------------------------------------- | This function derives all the information necessary to use the--- interpreter from the compile-time environment, and compiles it in--- to the generated code.+-- | This 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.+-- 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.+-- 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+-- This will handle reloading the application successfully in most cases. The+-- cases in which it is certain to fail are those involving changing the types+-- of the initializer or the load function, or changing the compiler options+-- required, such as by changing/adding dependencies in the project's .cabal+-- file. In those cases, a full recompile will be needed.+--+loadSnapTH :: Q Exp      -- ^ the initializer expression+           -> Name       -- ^ the name of the load function+           -> [String]   -- ^ a list of directories to watch in addition+                         --   to those containing code            -> Q Exp #ifndef HINT_ENABLED-loadSnapTH _ _ _ = fail $ "Snap was built without hint support.  Hint " ++-                   "support is necessary for development mode.  " ++-                   "Please reinstall snap with hint support.\n\n " ++-                   "  cabal install snap -fhint\n\n"+loadSnapTH _ _ _ = fail $+                   concat [ "Snap was built without hint support.  Hint "+                          , "support is necessary for development mode.  "+                          , "Please reinstall snap with hint support.\n\n "+                          , "  cabal install snap -fhint\n\n" ] #else loadSnapTH initializer action additionalWatchDirs = do     args <- runIO getArgs -    let opts = getHintOpts args+    let opts     = getHintOpts args         srcPaths = additionalWatchDirs ++ getSrcPaths args      -- The first line is an extra type check to ensure the arguments@@ -97,21 +94,32 @@ getHintOpts :: [String] -> [String] getHintOpts args = removeBad opts   where-    bad = ["-threaded", "-O"]+    --------------------------------------------------------------------------+    bad       = ["-threaded", "-O"]++    --------------------------------------------------------------------------     removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad) -    hideAll = filter (== "-hide-all-packages") args+    --------------------------------------------------------------------------+    hideAll   = filter (== "-hide-all-packages") args -    srcOpts = filter (\x -> "-i" `isPrefixOf` x-                            && not ("-idist" `isPrefixOf` x)) 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)+    --------------------------------------------------------------------------+    toCopy    = filter (not . isSuffixOf ".hs") $+                dropWhile (not . ("-package" `isPrefixOf`)) args -    opts = hideAll ++ srcOpts ++ copy toCopy+    --------------------------------------------------------------------------+    copy      = map (intercalate " ")+                    . groupBy (\_ s -> not $ "-" `isPrefixOf` s) +    --------------------------------------------------------------------------+    opts      = concat [hideAll, srcOpts, copy toCopy] + ------------------------------------------------------------------------------ -- | This function extracts the source paths from the compilation args getSrcPaths :: [String] -> [String]@@ -121,41 +129,50 @@   --------------------------------------------------------------------------------- | 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.+-- | 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.+-- 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+         => [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.+    --------------------------------------------------------------------------+    -- 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@@ -163,15 +180,20 @@         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
src/Snap/Loader/Devel/Evaluator.hs view
@@ -5,16 +5,13 @@   , 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)  @@ -24,43 +21,41 @@   --------------------------------------------------------------------------------- | 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.+-- | 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.+-- 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.+-- 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.+    -- 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.+    -- 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.+    -- 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@@ -132,6 +127,7 @@              cleanup contents      return (snap, clean)+   where     newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))])     newReaderContainer = newMVar []
src/Snap/Loader/Devel/Signal.hs view
@@ -1,27 +1,37 @@ {-# LANGUAGE CPP #-} module Snap.Loader.Devel.Signal (protectHandlers) where +------------------------------------------------------------------------------ import Control.Exception (bracket) + #ifdef mingw32_HOST_OS-import GHC.ConsoleHandler as C +                                 -------------+                                 -- windows --+                                 -------------+------------------------------------------------------------------------------+import GHC.ConsoleHandler as C  saveHandlers :: IO C.Handler saveHandlers = C.installHandler Ignore - restoreHandlers :: C.Handler -> IO C.Handler restoreHandlers = C.installHandler+------------------------------------------------------------------------------   #else++                                  -----------+                                  -- posix --+                                  -----------+------------------------------------------------------------------------------ import qualified System.Posix.Signals as S  helper :: S.Handler -> S.Signal -> IO S.Handler helper handler signal = S.installHandler signal handler Nothing - signals :: [S.Signal] signals = [ S.sigQUIT           , S.sigINT@@ -29,15 +39,19 @@           , S.sigTERM           ] - saveHandlers :: IO [S.Handler] saveHandlers = mapM (helper S.Ignore) signals - restoreHandlers :: [S.Handler] -> IO [S.Handler] restoreHandlers h = sequence $ zipWith helper h signals-+------------------------------------------------------------------------------  #endif++                                  ----------+                                  -- both --+                                  ----------+------------------------------------------------------------------------------ protectHandlers :: IO a -> IO a protectHandlers a = bracket saveHandlers restoreHandlers $ const a+------------------------------------------------------------------------------
src/Snap/Loader/Devel/TreeWatcher.hs view
@@ -1,14 +1,13 @@ module Snap.Loader.Devel.TreeWatcher-    ( TreeStatus-    , getTreeStatus-    , checkTreeStatus-    ) where+  ( TreeStatus+  , getTreeStatus+  , checkTreeStatus+  ) where +------------------------------------------------------------------------------ import Control.Applicative- import System.Directory import System.Directory.Tree- import System.Time
src/Snap/Loader/Prod.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE TemplateHaskell #-}+ module Snap.Loader.Prod   ( loadSnapTH   ) where +------------------------------------------------------------------------------ import           Language.Haskell.TH
src/Snap/Snaplet.hs view
@@ -100,6 +100,7 @@   -- * Handlers   , Handler   , reloadSite+  , bracketHandler    -- * Serving Applications   , runSnaplet
src/Snap/Snaplet/Auth.hs view
@@ -1,22 +1,21 @@ {-# 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.+{-# 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@@ -53,6 +52,8 @@   , checkPassword   , authenticatePassword   , setPassword+  , encrypt+  , verify    -- * Handlers   , registerUser@@ -64,9 +65,11 @@   , addAuthSplices   , ifLoggedIn   , ifLoggedOut+  , loggedInUser   )   where +------------------------------------------------------------------------------ import Snap.Snaplet.Auth.AuthManager import Snap.Snaplet.Auth.Handlers import Snap.Snaplet.Auth.SpliceHelpers
src/Snap/Snaplet/Auth/AuthManager.hs view
@@ -1,52 +1,49 @@--{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveDataTypeable #-}+------------------------------------------------------------------------------+-- | Internal module exporting AuthManager implementation.+--+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings          #-}  module Snap.Snaplet.Auth.AuthManager--(-  -- * AuthManager Datatype+  ( -- * AuthManager Datatype     AuthManager(..) -  -- * Backend Typeclass-  , IAuthBackend(..)--  -- * Context-free Operations-  , buildAuthUser--) where+    -- * Backend Typeclass+    , IAuthBackend(..) +    -- * Context-free Operations+    , buildAuthUser+  ) where +------------------------------------------------------------------------------ import           Data.ByteString (ByteString) import           Data.Lens.Lazy-import           Data.Time import           Data.Text (Text)+import           Data.Time import           Web.ClientSession  import           Snap.Snaplet import           Snap.Snaplet.Session+import           Snap.Snaplet.Session.Common import           Snap.Snaplet.Auth.Types + --------------------------------------------------------------------------------- | Create a new user from just a username and password+-- | Creates a new user from 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 :: 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+              userLogin     = unm+            , userPassword  = Nothing             , userCreatedAt = Just now             , userUpdatedAt = Just now             }@@ -59,44 +56,45 @@ -- -- 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 ()+  -- | Create or update the given 'AuthUser' record.  If the 'userId' in the+  -- 'AuthUser' already exists in the database, then that user's information+  -- should be updated.  If it does not exist, then a new user should be+  -- created.+  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+      backend               :: r+        -- ^ Storage back-end -  , session :: Lens b (Snaplet SessionManager)-  -- ^ A lens pointer to a SessionManager+    , session               :: Lens b (Snaplet SessionManager)+        -- ^ A lens pointer to a SessionManager -  , activeUser :: Maybe AuthUser-  -- ^ A per-request logged-in user cache+    , activeUser            :: Maybe AuthUser+        -- ^ A per-request logged-in user cache -  , minPasswdLen :: Int-  -- ^ Password length range+    , minPasswdLen          :: Int+        -- ^ Password length range -  , rememberCookieName :: ByteString-  -- ^ Cookie name for the remember token+    , rememberCookieName    :: ByteString+        -- ^ Cookie name for the remember token -  , rememberPeriod :: Maybe Int-  -- ^ Remember period in seconds. Defaults to 2 weeks.+    , rememberPeriod        :: Maybe Int+        -- ^ Remember period in seconds. Defaults to 2 weeks. -  , siteKey :: Key-  -- ^ A unique encryption key used to encrypt remember cookie+    , 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-  }+    , lockout               :: Maybe (Int, NominalDiffTime)+        -- ^ Lockout after x tries, re-allow entry after y seconds++    , randomNumberGenerator :: RNG+        -- ^ Random number generator+    }
src/Snap/Snaplet/Auth/Backends/JsonFile.hs view
@@ -32,35 +32,39 @@ import           Snap.Snaplet.Auth.Types import           Snap.Snaplet.Auth.AuthManager import           Snap.Snaplet.Session+import           Snap.Snaplet.Session.Common    ------------------------------------------------------------------------------ -- | 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-    }+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 = do+    makeSnaplet+        "JsonFileAuthManager"+        "A snaplet providing user authentication using a JSON-file backend"+        Nothing $ liftIO $ do+            rng <- liftIO mkRNG+            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+                       , randomNumberGenerator = rng+                       }   ------------------------------------------------------------------------------@@ -71,51 +75,55 @@ mkJsonAuthMgr fp = do   db <- loadUserCache fp   let db' = case db of-              Left e -> error e+              Left e  -> error e               Right x -> x   cache <- newTVarIO db'-  return $ JsonFileAuthManager {++  return $! JsonFileAuthManager {       memcache = cache-    , dbfile = fp+    , 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+------------------------------------------------------------------------------+-- | 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+    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+    uidCache   = HM.empty   , loginCache = HM.empty   , tokenCache = HM.empty   , uidCounter = 0 }  +------------------------------------------------------------------------------ loadUserCache :: FilePath -> IO (Either String UserCache) loadUserCache fp = do   chk <- doesFileExist fp@@ -123,117 +131,136 @@     True -> do       d <- B.readFile fp       case Atto.parseOnly json d of-        Left e -> return . Left $ "Can't open JSON auth backend. Error: " ++ e+        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+          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+  , dbfile   :: FilePath }  -instance IAuthBackend JsonFileAuthManager where--  save mgr u = do-    now <- getCurrentTime+------------------------------------------------------------------------------+jsonFileSave :: JsonFileAuthManager -> AuthUser -> IO AuthUser+jsonFileSave mgr u = do+    now        <- getCurrentTime     oldByLogin <- lookupByLogin mgr (userLogin u)-    oldById <- case userId u of-      Nothing -> return Nothing-      Just x -> lookupByUserId mgr x+    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+      res   <- case userId u of+                 Nothing -> create cache now oldByLogin+                 Just _  -> update cache now oldById       case res of-        Left e -> return $ Left e+        Left e             -> return $! Left e         Right (cache', u') -> do           writeTVar (memcache mgr) cache'-          return $ Right (cache', u')+          return $! Right $! (cache', u')+     case res of-      Left e -> throw e+      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)+        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')+    --------------------------------------------------------------------------+    -- 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 -      -- 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)+          let lc       = if oldLogin /= userLogin u+                           then HM.insert newLogin uid $+                                HM.delete oldLogin $+                                loginCache cache+                           else loginCache cache -      -- 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."+          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)++    --------------------------------------------------------------------------+    -- Gets 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."+++------------------------------------------------------------------------------+instance IAuthBackend JsonFileAuthManager where+  save = jsonFileSave+   destroy = error "JsonFile: destroy is not yet implemented"    lookupByUserId mgr uid = withCache mgr f-    where f cache = getUser cache uid+    where+      f cache = getUser cache uid    lookupByLogin mgr login = withCache mgr f     where@@ -243,33 +270,42 @@   lookupByRememberToken mgr token = withCache mgr f     where       f cache = getUid >>= getUser cache-        where getUid = HM.lookup token (tokenCache 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+  return $! f cache  +------------------------------------------------------------------------------ getUser :: UserCache -> UserId -> Maybe AuthUser getUser cache uid = HM.lookup uid (uidCache cache)   --------------------------------------------------------------------------------- JSON Instances----------------------------------------------------------------------------------+showT :: Int -> Text+showT = T.pack . show  +                             --------------------+                             -- JSON Instances --+                             --------------------++------------------------------------------------------------------------------ instance ToJSON UserCache where   toJSON uc = object-    [ "uidCache"   .= uidCache uc+    [ "uidCache"   .= uidCache   uc     , "loginCache" .= loginCache uc     , "tokenCache" .= tokenCache uc-    , "uidCounter" .= uidCounter uc]+    , "uidCounter" .= uidCounter uc+    ]  +------------------------------------------------------------------------------ instance FromJSON UserCache where   parseJSON (Object v) =     UserCache@@ -279,57 +315,4 @@       <*> 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
src/Snap/Snaplet/Auth/Handlers.hs view
@@ -1,29 +1,29 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE Rank2Types #-}--{-|--  Pre-packaged Handlers that deal with form submissions and standard use-cases-  involving authentication.+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE Rank2Types                #-} --}+------------------------------------------------------------------------------+-- | 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           Control.Monad.Trans.Error+import           Control.Monad.Trans.Maybe import           Data.ByteString (ByteString) import           Data.Lens.Lazy-import           Data.Maybe (isJust)+import           Data.Maybe (fromMaybe, 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@@ -31,119 +31,136 @@ import           Snap.Snaplet.Session import           Snap.Snaplet.Session.Common import           Snap.Snaplet.Session.SecureCookie--- --------------------------------------------------------------------------------- Higher level functions-------------------------------------------------------------------------------  +                         ----------------------------+                         -- 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+-- 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+--+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 :: 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+loginByUsername unm pwd shouldRemember = 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+    --------------------------------------------------------------------------+    loginByUsername' :: (IAuthBackend t) =>+                        Key+                     -> ByteString+                     -> Maybe Int+                     -> t+                     -> Handler b (AuthManager b) (Either AuthFailure AuthUser)+    loginByUsername' sk cn rp r =+        liftIO (lookupByLogin r $ decodeUtf8 unm) >>=+        maybe (return $! Left UserNotFound) found++      where+        ----------------------------------------------------------------------+        found user = checkPasswordAndLogin user pwd >>=+                     either (return . Left) matched++        ----------------------------------------------------------------------+        matched user+            | shouldRemember = do+                  token <- gets randomNumberGenerator >>=+                           liftIO . randomToken 64+                   setRememberToken sk cn rp token-                  let au''' = au''-                          { userRememberToken = Just (decodeUtf8 token) }-                  saveUser au'''-                  return $ Right au'''-                False -> return $ Right au'' +                  let user' = user {+                                userRememberToken = Just (decodeUtf8 token)+                              } +                  saveUser user'+                  return $! Right user'++            | otherwise = return $ Right user++ ------------------------------------------------------------------------------ -- | 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+loginByRememberToken = withBackend $ \impl -> do+    key         <- gets siteKey+    cookieName_ <- gets rememberCookieName+    period      <- gets rememberPeriod +    runMaybeT $ do+        token <- MaybeT $ getRememberToken key cookieName_ period+        user  <- MaybeT $ liftIO $ lookupByRememberToken impl+                                 $ decodeUtf8 token+        lift $ forceLogin user+        return user + ------------------------------------------------------------------------------ -- | 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 } )+    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'+    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+isLoggedIn = isJust <$> 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 @@ -152,62 +169,78 @@ -- | 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-----------------------------------------------------------------------------------+                      -----------------------------------+                      --  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+    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'+    --------------------------------------------------------------------------+    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+markAuthSuccess u = withBackend $ \r ->+                        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 }+        ip <- rqRemoteAddr <$> 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 }+        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. --@@ -221,24 +254,27 @@ -- 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+    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 })@@ -251,27 +287,27 @@ -- -- 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 :: 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"+    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----------------------------------------------------------------------------------+                     ------------------------------------+                     -- Internal, non-exported helpers --+                     ------------------------------------  +------------------------------------------------------------------------------ getRememberToken :: (Serialize t, MonadSnap m)                  => Key                  -> ByteString@@ -280,6 +316,7 @@ getRememberToken sk rc rp = getSecureCookie rc sk rp  +------------------------------------------------------------------------------ setRememberToken :: (Serialize t, MonadSnap m)                  => Key                  -> ByteString@@ -289,12 +326,14 @@ 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 @@ -307,6 +346,7 @@  ------------------------------------------------------------------------------ -- | Get the current user's 'UserId' from the active session+-- getSessionUserId :: Handler b SessionManager (Maybe UserId) getSessionUserId = do   uid <- getFromSession "__user_id"@@ -318,53 +358,56 @@ -- -- 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 :: 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+    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'+    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+  :: 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+    l <- fmap decodeUtf8 <$> getParam lf+    p <- getParam pf+    case liftM2 (,) l p of+      Nothing         -> throw PasswordMissing+      Just (lgn, pwd) -> createUser lgn pwd   ------------------------------------------------------------------------------ -- | A 'MonadSnap' handler that processes a login form. -- -- The request paremeters are passed to 'performLogin'+-- loginUser   :: ByteString   -- ^ Username field@@ -378,26 +421,29 @@   -- ^ 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+    runErrorT go >>= either loginFail (const loginSucc) +  where+    go = do+        mbUsername <- getParam unf+        mbPassword <- getParam pwdf+        remember   <- (runMaybeT $ do+                           field <- MaybeT $ return remf+                           value <- MaybeT $ getParam field+                           return $ value == "1"+                      ) >>= return . fromMaybe False ++        password <- maybe (throwError PasswordMissing) return mbPassword+        username <- maybe (fail "Username is missing") return mbUsername+        lift $ loginByUsername username (ClearText password) remember++ ------------------------------------------------------------------------------ -- | 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 :: Handler b (AuthManager b) ()   -- ^ What to do after logging out+           -> Handler b (AuthManager b) () logoutUser target = logout >> target  @@ -407,17 +453,17 @@ -- -- 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 :: 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+    loggedIn <- withTop auth isLoggedIn+    if loggedIn then good else bad   ------------------------------------------------------------------------------@@ -428,10 +474,11 @@ -- (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.+--+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+  (AuthManager backend_ _ _ _ _ _ _ _ _) <- get+  return $ f backend_
src/Snap/Snaplet/Auth/SpliceHelpers.hs view
@@ -15,6 +15,7 @@     addAuthSplices   , ifLoggedIn   , ifLoggedOut+  , loggedInUser   ) where  import           Data.Lens.Lazy@@ -24,6 +25,7 @@ import           Snap.Snaplet import           Snap.Snaplet.Auth.AuthManager import           Snap.Snaplet.Auth.Handlers+import           Snap.Snaplet.Auth.Types import           Snap.Snaplet.Heist  @@ -41,6 +43,7 @@ addAuthSplices auth = addSplices   [ ("ifLoggedIn", ifLoggedIn auth)   , ("ifLoggedOut", ifLoggedOut auth)+  , ("loggedInUser", loggedInUser auth)   ]  @@ -49,9 +52,7 @@ -- 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 :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v ifLoggedIn auth = do   chk <- liftHandler $ withTop auth isLoggedIn   case chk of@@ -64,12 +65,18 @@ -- 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 :: 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 [] ++-------------------------------------------------------------------------------+-- | A splice that will simply print the current user's login, if+-- there is one.+loggedInUser :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v+loggedInUser auth = do+  u <- liftHandler $ withTop auth currentUser+  liftHeist $ maybe (return []) (textSplice . userLogin) u
src/Snap/Snaplet/Auth/Types.hs view
@@ -1,20 +1,23 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings          #-}  module Snap.Snaplet.Auth.Types where +------------------------------------------------------------------------------+import           Control.Applicative import           Control.Monad.CatchIO+import           Control.Monad.Trans.Error+import           Crypto.PasswordStore 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.ByteString       (ByteString)+import           Data.HashMap.Strict   (HashMap)+import qualified Data.HashMap.Strict   as HM+import           Data.Hashable         (Hashable) import           Data.Time+import           Data.Text             (Text) import           Data.Typeable-import           Data.Text (Text)-import           Crypto.PasswordStore   ------------------------------------------------------------------------------@@ -22,21 +25,45 @@ -- returned from the db. data Password = ClearText ByteString               | Encrypted ByteString-              deriving (Read, Show, Ord, Eq)+  deriving (Read, Show, Ord, Eq)   --------------------------------------------------------------------------------- Turn a 'ClearText' password into an 'Encrypted' password, ready to be--- stuffed into a database.+-- | Default strength level to pass into makePassword.+defaultStrength :: Int+defaultStrength = 12+++-------------------------------------------------------------------------------+-- | The underlying encryption function, in case you need it for+-- external processing.+encrypt :: ByteString -> IO ByteString+encrypt = flip makePassword defaultStrength+++-------------------------------------------------------------------------------+-- | The underlying verify function, in case you need it for external+-- processing.+verify +    :: ByteString               -- ^ Cleartext+    -> ByteString               -- ^ Encrypted reference+    -> Bool+verify = verifyPassword +++------------------------------------------------------------------------------+-- | 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+encryptPassword (ClearText p)    = Encrypted `fmap` encrypt p   +------------------------------------------------------------------------------ checkPassword :: Password -> Password -> Bool-checkPassword (ClearText pw) (Encrypted pw') = verifyPassword pw pw'+checkPassword (ClearText pw) (Encrypted pw') = verify pw pw'+checkPassword (ClearText pw) (ClearText pw') = pw == pw'+checkPassword (Encrypted pw) (Encrypted pw') = pw == pw' checkPassword _ _ =   error "checkPassword failed. Make sure you pass ClearText passwords" @@ -46,18 +73,17 @@ -- 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+data AuthFailure = UserNotFound+                 | IncorrectPassword+                 | PasswordMissing+                 | LockedOut UTCTime    -- ^ Locked out until given time+                 | AuthError String   deriving (Read, Show, Ord, Eq, Typeable) - instance Exception AuthFailure +instance Error AuthFailure where+    strMsg = AuthError  ------------------------------------------------------------------------------ -- | Internal representation of a 'User'. By convention, we demand that the@@ -66,59 +92,61 @@ -- 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)+  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)+  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)+    { 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-}+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+    }   ------------------------------------------------------------------------------@@ -126,24 +154,28 @@ -- 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 }+    pw <- Encrypted <$> makePassword pass defaultStrength+    return $! au { userPassword = Just pw }   ------------------------------------------------------------------------------ -- | Authetication settings defined at initialization time data AuthSettings = AuthSettings {-    asMinPasswdLen :: Int-  -- ^ Currently not used/checked+    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+    -- ^ 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 }  @@ -157,19 +189,89 @@ -- > asSiteKey = "site_key.txt" defAuthSettings :: AuthSettings defAuthSettings = AuthSettings {-    asMinPasswdLen = 8+    asMinPasswdLen       = 8   , asRememberCookieName = "_remember"-  , asRememberPeriod = Just (2*7*24*60*60)-  , asLockout = Nothing-  , asSiteKey = "site_key.txt"+  , asRememberPeriod     = Just (2*7*24*60*60)+  , asLockout            = Nothing+  , asSiteKey            = "site_key.txt" }  -data BackendError =-    DuplicateLogin-  | BackendError String+------------------------------------------------------------------------------+data BackendError = DuplicateLogin+                  | BackendError String   deriving (Eq,Show,Read,Typeable) - instance Exception BackendError ++                             --------------------+                             -- JSON Instances --+                             --------------------++------------------------------------------------------------------------------+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+    , "roles"              .= userRoles             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"+    <*> v .:? "roles" .!= []+    <*> 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+++------------------------------------------------------------------------------+instance ToJSON Role where+  toJSON (Role x) = toJSON x+++------------------------------------------------------------------------------+instance FromJSON Role where+  parseJSON = fmap Role . parseJSON
src/Snap/Snaplet/Heist.hs view
@@ -1,9 +1,7 @@-{-|--The Heist snaplet makes it easy to add Heist to your application and use it in-other snaplets.---}+------------------------------------------------------------------------------+-- | The Heist snaplet makes it easy to add Heist to your application and use+-- it in other snaplets.+--  module Snap.Snaplet.Heist   (@@ -44,17 +42,20 @@   , 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-                                           ,heistInit', clearHeistCache)+import           Snap.Snaplet.HeistNoClass ( Heist+                                           , heistInit+                                           , heistInit'+                                           , clearHeistCache+                                           )   ------------------------------------------------------------------------------@@ -84,19 +85,23 @@   --------------------------------------------------------------------------------- | Adds templates to the Heist TemplateState.  Other snaplets should use+-- | Adds templates to the Heist HeistState.  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-             -- ^ Path to templates (also the url prefix for their routes)+             -- ^ The url prefix for the template routes              -> 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.+-- | Adds templates to the Heist HeistState, and lets you specify where+-- they are found in the filesystem.  Note that the path to the template+-- directory is an absolute path.  This allows you more flexibility in where+-- your templates are located, but means that you have to explicitly call+-- getSnapletFilePath if you want your snaplet to use templates within its+-- normal directory structure. addTemplatesAt :: HasHeist b                => ByteString                -- ^ URL prefix for template routes@@ -116,21 +121,21 @@   --------------------------------------------------------------------------------- | More general function allowing arbitrary TemplateState modification.+-- | More general function allowing arbitrary HeistState 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))-              -- ^ TemplateState modifying function+              => (HeistState (Handler b b) -> HeistState (Handler b b))+              -- ^ HeistState modifying function               -> Initializer b v () modifyHeistTS = Unclassed.modifyHeistTS' heistLens   --------------------------------------------------------------------------------- | Runs a function on with the Heist snaplet's 'TemplateState'.+-- | Runs a function on with the Heist snaplet's 'HeistState'. withHeistTS :: (HasHeist b)-            => (TemplateState (Handler b b) -> a)-            -- ^ TemplateState function to run+            => (HeistState (Handler b b) -> a)+            -- ^ HeistState function to run             -> Handler b v a withHeistTS = Unclassed.withHeistTS' heistLens @@ -193,7 +198,7 @@  ------------------------------------------------------------------------------ -- | Runs an action with additional splices bound into the Heist--- 'TemplateState'.+-- 'HeistState'. withSplices :: HasHeist b             => [(Text, Unclassed.SnapletSplice b v)]             -- ^ Splices to bind@@ -204,14 +209,14 @@   --------------------------------------------------------------------------------- | Runs a handler with a modified 'TemplateState'.  You might want to use+-- | Runs a handler with a modified 'HeistState'.  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))-           -- ^ TemplateState modifying function+           => (HeistState (Handler b b) -> HeistState (Handler b b))+           -- ^ HeistState modifying function            -> Handler b v a             -- ^ Handler to run            -> Handler b v a@@ -220,7 +225,7 @@  -- $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).+-- HeistState 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
src/Snap/Snaplet/HeistNoClass.hs view
@@ -68,14 +68,15 @@ -- 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)+    { _heistTS       :: HeistState (Handler b b)     , _heistCTS      :: CacheTagState     }   -------------------------------------------------------------------------------changeTS :: (TemplateState (Handler a a) -> TemplateState (Handler a a))+changeTS :: (HeistState (Handler a a) -> HeistState (Handler a a))          -> Heist a          -> Heist a changeTS f (Heist ts cts) = Heist (f ts) cts@@ -85,24 +86,26 @@ -- | 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--------------------------------------------------------------------------------+                         -----------------------------+                         -- 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@@ -119,17 +122,20 @@  ------------------------------------------------------------------------------ -- | 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@@ -139,12 +145,14 @@ ------------------------------------------------------------------------------ -- | 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@@ -153,6 +161,7 @@  ------------------------------------------------------------------------------ -- | Lifts a Handler into SnapletHeist.+-- liftHandler :: Handler b v a -> SnapletHeist b v a liftHandler m = do     l <- ask@@ -161,10 +170,12 @@  ------------------------------------------------------------------------------ -- | 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@@ -178,6 +189,7 @@  ------------------------------------------------------------------------------ -- | MonadSnaplet instance gives us access to the snaplet infrastructure.+-- instance MonadSnaplet SnapletHeist where     getLens = ask     with' l = withSS (l .)@@ -190,121 +202,144 @@  ------------------------------------------------------------------------------ -- | SnapletSplices version of bindSplices.+-- bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v))                    -> [(Text, SnapletSplice b v)]-                   -> TemplateState (Handler b b)-                   -> TemplateState (Handler b b)+                   -> HeistState (Handler b b)+                   -> HeistState (Handler b b) bindSnapletSplices l splices =     bindSplices $ map (second $ runSnapletSplice l) splices  ---------------------------------------------------------------------------------- Initializer functions--------------------------------------------------------------------------------+                          ---------------------------+                          -- Initializer functions --+                          ---------------------------  --------------------------------------------------------------------------------- | The 'Initializer' for 'Heist'.  This function is a convenience wrapper--- around `heistInit'` that uses the default `emptyTemplateState` from Heist--- and sets up routes for all the templates.-heistInit :: FilePath-           -- ^ Path to templates+-- | The 'Initializer' for 'Heist'. This function is a convenience wrapper+-- around `heistInit'` that uses the default `mempty` HeistState and sets up+-- routes for all the templates.+--+heistInit :: FilePath                 -- ^ Path to templates           -> SnapletInit b (Heist b) heistInit templateDir = do     makeSnaplet "heist" "" Nothing $ do-        hs <- heistInitWorker templateDir emptyTemplateState+        hs <- heistInitWorker templateDir defaultHeistState         addRoutes [ ("", heistServe) ]         return hs   ------------------------------------------------------------------------------ -- | A lower level 'Initializer' for 'Heist'.  This initializer requires you--- to specify the initial TemplateState.  It also does not add any routes for+-- to specify the initial HeistState.  It also does not add any routes for -- templates, allowing you complete control over which templates get routed.+-- heistInit' :: FilePath            -- ^ Path to templates-           -> TemplateState (Handler b b)-           -- ^ Initial TemplateState+           -> HeistState (Handler b b)+           -- ^ Initial HeistState            -> SnapletInit b (Heist b)-heistInit' templateDir initialTemplateState =+heistInit' templateDir initialHeistState =     makeSnaplet "heist" "" Nothing $-        heistInitWorker templateDir initialTemplateState+        heistInitWorker templateDir initialHeistState   ------------------------------------------------------------------------------ -- | Internal worker function used by variantsof heistInit.  This is necessary -- because of the divide between SnapletInit and Initializer.+-- heistInitWorker :: FilePath-                -> TemplateState (Handler b b)+                -> HeistState (Handler b b)                 -> Initializer b v (Heist b)-heistInitWorker templateDir initialTemplateState = do+heistInitWorker templateDir initialHeistState = do     (cacheFunc, cts) <- liftIO mkCacheTag-    let origTs = cacheFunc initialTemplateState-    ts <- liftIO $ loadTemplates templateDir origTs >>=+    let origTs = cacheFunc initialHeistState+    snapletPath <- getSnapletFilePath+    let tDir = snapletPath </> templateDir+    ts <- liftIO $ loadTemplates tDir origTs >>=                    either error return     printInfo $ T.pack $ unwords         [ "...loaded"         , (show $ length $ templateNames ts)-        , "templates"+        , "templates from"+        , tDir         ]      return $ Heist ts cts  +------------------------------------------------------------------------------+-- | Adds templates to the Heist HeistState.  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 :: ByteString-             -- ^ Path to templates (also the url prefix for their routes)+             -- ^ The url prefix for the template routes              -> Initializer b (Heist b) () addTemplates urlPrefix = do     snapletPath <- getSnapletFilePath     addTemplatesAt urlPrefix (snapletPath </> "templates")  +------------------------------------------------------------------------------+-- | Adds templates to the Heist HeistState, and lets you specify where+-- they are found in the filesystem.  Note that the path to the template+-- directory is an absolute path.  This allows you more flexibility in where+-- your templates are located, but means that you have to explicitly call+-- getSnapletFilePath if you want your snaplet to use templates within its+-- normal directory structure. addTemplatesAt :: ByteString                -- ^ URL prefix for template routes                -> FilePath                -- ^ Path to templates                -> Initializer b (Heist b) () addTemplatesAt urlPrefix templateDir = do-    ts <- liftIO $ loadTemplates templateDir emptyTemplateState+    ts <- liftIO $ loadTemplates templateDir mempty                    >>= either error return+    rootUrl <- getSnapletRootURL+    let fullPrefix = U.toString rootUrl </> U.toString urlPrefix     printInfo $ T.pack $ unwords         [ "...adding"         , (show $ length $ templateNames ts)         , "templates from"         , templateDir         , "with route prefix"-        , (U.toString urlPrefix) ++ "/"+        , fullPrefix ++ "/"         ]     addPostInitHook $ return . changeTS-        (`mappend` addTemplatePathPrefix urlPrefix ts)+        (`mappend` addTemplatePathPrefix (U.fromString fullPrefix) ts)  +------------------------------------------------------------------------------ modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))-               -> (TemplateState (Handler b b) -> TemplateState (Handler b b))+               -> (HeistState (Handler b b) -> HeistState (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))+              -> (HeistState (Handler b b) -> HeistState (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)+             -> (HeistState (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)+            -> (HeistState (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 ()@@ -314,16 +349,16 @@         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--------------------------------------------------------------------------------+                            -----------------------+                            -- Handler functions --+                            -----------------------  ------------------------------------------------------------------------------ -- | Internal helper function for rendering.@@ -339,12 +374,14 @@         writeBuilder b  +------------------------------------------------------------------------------ render :: ByteString        -- ^ Name of the template        -> Handler b (Heist b) () render t = renderHelper Nothing t  +------------------------------------------------------------------------------ renderAs :: ByteString          -- ^ Content type          -> ByteString@@ -353,19 +390,22 @@ 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))+            -> (HeistState (Handler b b) -> HeistState (Handler b b))             -> Handler b v a             -> Handler b v a heistLocal' heist f m = do@@ -376,13 +416,15 @@     return res  +------------------------------------------------------------------------------ heistLocal :: (Lens b (Snaplet (Heist b)))-           -> (TemplateState (Handler b b) -> TemplateState (Handler b b))+           -> (HeistState (Handler b b) -> HeistState (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@@ -392,6 +434,7 @@     heistLocal' heist (bindSnapletSplices _lens splices) m  +------------------------------------------------------------------------------ withSplices :: (Lens b (Snaplet (Heist b)))             -> [(Text, SnapletSplice b v)]             -> Handler b v a@@ -399,6 +442,7 @@ withSplices heist splices m = withSplices' (subSnaplet heist) splices m  +------------------------------------------------------------------------------ renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))                    -> ByteString                    -> [(Text, SnapletSplice b v)]@@ -407,6 +451,7 @@     withSplices' heist splices $ withTop' heist $ render t  +------------------------------------------------------------------------------ renderWithSplices :: (Lens b (Snaplet (Heist b)))                   -> ByteString                   -> [(Text, SnapletSplice b v)]
src/Snap/Snaplet/Internal/Initializer.hs view
@@ -146,11 +146,15 @@         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 })+        liftIO $ readDirectoryWith (doCopy srcDir targetDir) srcDir         return ()+  where+    doCopy srcRoot targetRoot filename = do+        createDirectoryIfMissing True directory+        copyFile filename to+      where+        to = targetRoot </> makeRelative srcRoot filename+        directory = dropFileName to   ------------------------------------------------------------------------------@@ -286,7 +290,7 @@              -> Initializer b v (Snaplet v1) embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do     curLens <- getLens-    setupSnapletCall rte+    setupSnapletCall ""     chroot rte (subSnaplet l . curLens) snaplet  @@ -381,7 +385,11 @@ -- | 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)+onUnload m = do+    cleanupRef <- iGets _cleanup+    liftIO $ atomicModifyIORef cleanupRef f+  where+    f curCleanup = (curCleanup >> m, ())   ------------------------------------------------------------------------------@@ -403,19 +411,18 @@  ------------------------------------------------------------------------------ -- | Builds an IO reload action for storage in the SnapletState.-mkReloader :: MVar (Snaplet b)+mkReloader :: FilePath+           -> 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+           -> IO (Either Text Text)+mkReloader cwd mvar i = do+    !res <- runInitializer' mvar i cwd+    either (return . Left) 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+        return $ Right msgs   ------------------------------------------------------------------------------@@ -430,35 +437,65 @@   --------------------------------------------------------------------------------- |+-- | Internal function for running Initializers.  If any exceptions were+-- thrown by the initializer, this function catches them, runs any cleanup+-- actions that had been registered, and returns an expanded error message+-- containing the exception details as well as all messages generated by the+-- initializer before the exception was thrown. runInitializer :: MVar (Snaplet b)                -> Initializer b b (Snaplet b)-               -> IO (Snaplet b, InitializerState b)-runInitializer mvar b@(Initializer i) = do+               -> IO (Either Text (Snaplet b, InitializerState b))+runInitializer mvar b = getCurrentDirectory >>= runInitializer' mvar b+++------------------------------------------------------------------------------+runInitializer' :: MVar (Snaplet b)+                -> Initializer b b (Snaplet b)+                -> FilePath+                -> IO (Either Text (Snaplet b, InitializerState b))+runInitializer' mvar b@(Initializer i) cwd = do     userConfig <- load [Optional "snaplet.cfg"]     let builtinHandlers = [("/admin/reload", reloadSite)]-    let cfg = SnapletConfig [] "" Nothing "" userConfig [] Nothing-                            (mkReloader mvar b)+    let cfg = SnapletConfig [] cwd Nothing "" userConfig [] Nothing+                            (mkReloader cwd 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)+    cleanupRef <- newIORef (return ()) +    let body = do+            ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $+                InitializerState True cleanupRef builtinHandlers id cfg logRef+            res' <- hook res+            return $ Right (res', s) +        handler e = do+            join $ readIORef cleanupRef+            logMessages <- readIORef logRef++            return $ Left $ T.unlines+                [ "Initializer threw an exception..."+                , T.pack $ show (e :: SomeException)+                , ""+                , "...but before it died it generated the following output:"+                , logMessages+                ]++    catch body handler++ ------------------------------------------------------------------------------ -- | 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)+    eRes <- runInitializer snapletMVar b+    let go (siteSnaplet,is) = do+        putMVar snapletMVar siteSnaplet+        msgs <- liftIO $ readIORef $ _initMessages is+        let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar+        cleanupAction <- readIORef $ _cleanup is+        return (msgs, handler, cleanupAction)+    either (error . ('\n':) . T.unpack) go eRes   ------------------------------------------------------------------------------@@ -486,6 +523,7 @@      config       <- commandLineConfig startConfig     (conf, site) <- combineConfig config handler+    createDirectoryIfMissing False "log"     let serve = simpleHttpServe conf      liftIO $ hPutStrLn stderr $ T.unpack msgs
src/Snap/Snaplet/Internal/Types.hs view
@@ -43,7 +43,7 @@     , _scRoutePattern    :: Maybe ByteString     -- ^ Holds the actual route pattern passed to addRoutes for the current     -- handler.  Nothing during initialization and before route dispatech.-    , _reloader          :: IO (Either String String) -- might change+    , _reloader          :: IO (Either Text Text) -- might change     }  @@ -281,11 +281,13 @@   where     bad msg = do         writeText $ "Error reloading site!\n\n"-        writeText $ T.pack msg+        writeText msg     good msg = do-        writeText $ T.pack msg+        writeText msg         writeText $ "Site successfully reloaded.\n"     failIfNotLocal m = do+        -- TODO/FIXME: grave error here; this code needs to check if we're+        -- behind a proxy.         rip <- liftM rqRemoteAddr getRequest         if not $ elem rip [ "127.0.0.1"                           , "localhost"@@ -295,11 +297,35 @@   ------------------------------------------------------------------------------+-- | This function brackets a Handler action in resource acquisition and+-- release.  Like 'bracketSnap',  this is provided because MonadCatchIO's+-- 'bracket' function doesn't work properly in the case of a short-circuit+-- return from the action being bracketed.+--+-- In order to prevent confusion regarding the effects of the+-- aquisition and release actions on the Handler state, this function+-- doesn't accept Handler actions for the acquire or release actions.+--+-- This function will run the release action in all cases where the+-- acquire action succeeded.  This includes the following behaviors+-- from the bracketed Snap action.+--+-- 1. Normal completion+--+-- 2. Short-circuit completion, either from calling 'fail' or 'finishWith'+--+-- 3. An exception being thrown.+bracketHandler :: IO a -> (a -> IO x) -> (a -> Handler b v c) -> Handler b v c+bracketHandler begin end f = Handler . L.Lensed $ \l v b -> do+    bracketSnap begin end $ \a -> case f a of Handler m -> L.unlensed m l v b+++------------------------------------------------------------------------------ -- | Information about a partially constructed initializer.  Used to -- automatically aggregate handlers and cleanup actions. data InitializerState b = InitializerState     { _isTopLevel      :: Bool-    , _cleanup         :: IO ()+    , _cleanup         :: IORef (IO ())     , _handlers        :: [(ByteString, Handler b b ())]     -- ^ Handler routes built up and passed to route.     , _hFilter         :: Handler b b () -> Handler b b ()
src/Snap/Snaplet/Session.hs view
@@ -1,7 +1,5 @@ module Snap.Snaplet.Session--(-    SessionManager+  ( SessionManager   , withSession   , commitSession   , setInSession@@ -11,97 +9,116 @@   , sessionToList   , resetSession   , touchSession--) where+  ) where +------------------------------------------------------------------------------ import           Control.Monad.State import           Data.Lens.Lazy import           Data.Text (Text)--import           Snap.Snaplet import           Snap.Core-+------------------------------------------------------------------------------+import           Snap.Snaplet 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))+--+withSession :: Lens b (Snaplet SessionManager)             -> Handler b v a             -> Handler b v a withSession l h = do-  a <- h-  withTop l commitSession-  return a+    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+    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'+    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+    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'+    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+    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+    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'+    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'+    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'+    SessionManager r <- get+    r' <- liftSnap $ load r+    return $ SessionManager r'
src/Snap/Snaplet/Session/Backends/CookieSession.hs view
@@ -1,11 +1,14 @@+------------------------------------------------------------------------------ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE DeriveDataTypeable         #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Snap.Snaplet.Session.Backends.CookieSession--( initCookieSessionManager ) where+  ( initCookieSessionManager+  ) where +------------------------------------------------------------------------------+import           Control.Applicative import           Control.Monad.Reader import           Data.ByteString (ByteString) import           Data.Generics@@ -15,146 +18,172 @@ import           Data.Serialize (Serialize) import qualified Data.Serialize as S import           Data.Text (Text)-import           Web.ClientSession- import           Snap.Core (Snap)+import           Web.ClientSession+------------------------------------------------------------------------------ import           Snap.Snaplet-import           Snap.Snaplet.Session.Common (mkCSRFToken)+import           Snap.Snaplet.Session.Common 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)+    { 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+    put (CookieSession a b) = S.put (a,b)+    get                     = uncurry CookieSession <$> 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+instance (Serialize k, Serialize v, Hashable k,+          Eq k) => Serialize (HashMap k v) where+    put = S.put . HM.toList+    get = HM.fromList <$> S.get  -mkCookieSession :: IO CookieSession-mkCookieSession = do-  t <- liftIO $ mkCSRFToken-  return $ CookieSession t HM.empty+------------------------------------------------------------------------------+mkCookieSession :: RNG -> IO CookieSession+mkCookieSession rng = do+    t <- liftIO $ mkCSRFToken rng+    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)+      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.+    , randomNumberGenerator :: RNG+        -- ^ handle to a random number generator+} deriving (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+loadDefSession mgr@(CookieSessionManager ses _ _ _ rng) =+    case ses of+      Nothing -> do ses' <- mkCookieSession rng+                    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+    :: 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+    makeSnaplet "CookieSession"+                "A snaplet providing sessions via HTTP cookies."+                Nothing $ liftIO $ do+        key <- getKey fp+        rng <- liftIO mkRNG+        return $! SessionManager $ CookieSessionManager Nothing key cn to rng  +------------------------------------------------------------------------------ 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+    --------------------------------------------------------------------------+    load mgr@(CookieSessionManager r _ _ _ _) =+        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 } -  reset mgr = do-    cs <- liftIO mkCookieSession-    return $ mgr { session = Just cs }+    --------------------------------------------------------------------------+    commit mgr@(CookieSessionManager r _ _ _ rng) = do+        pl <- case r of+                Just r' -> return . Payload $ S.encode r'+                Nothing -> liftIO (mkCookieSession rng) >>=+                           return . Payload . S.encode+        setPayload mgr pl -  touch = id+    --------------------------------------------------------------------------+    reset mgr = do+        cs <- liftIO $ mkCookieSession (randomNumberGenerator mgr)+        return $ mgr { session = Just cs } -  insert k v mgr@(CookieSessionManager r _ _ _) = case r of-    Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }-    Nothing -> mgr+    --------------------------------------------------------------------------+    touch = id -  lookup k (CookieSessionManager r _ _ _) = r >>= HM.lookup k . csSession+    --------------------------------------------------------------------------+    insert k v mgr@(CookieSessionManager r _ _ _ _) = case r of+        Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' }+        Nothing -> mgr -  delete k mgr@(CookieSessionManager r _ _ _) = case r of-    Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }-    Nothing -> mgr+    --------------------------------------------------------------------------+    lookup k (CookieSessionManager r _ _ _ _) = r >>= HM.lookup k . csSession -  csrf (CookieSessionManager r _ _ _) = case r of-    Just r' -> csCSRFToken r'-    Nothing -> ""+    --------------------------------------------------------------------------+    delete k mgr@(CookieSessionManager r _ _ _ _) = case r of+        Just r' -> mgr { session = Just $ modSession (HM.delete k) r' }+        Nothing -> mgr -  toList (CookieSessionManager r _ _ _) = case r of-    Just r' -> HM.toList . csSession $ r'-    Nothing -> []+    --------------------------------------------------------------------------+    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--+setPayload mgr x = setSecureCookie (cookieName mgr) (siteKey mgr)+                                   (timeOut mgr) x
src/Snap/Snaplet/Session/Common.hs view
@@ -1,41 +1,66 @@-{-|--  This module contains functionality common among multiple back-ends.---}--module Snap.Snaplet.Session.Common where+------------------------------------------------------------------------------+-- | This module contains functionality common among multiple back-ends.+-- +module Snap.Snaplet.Session.Common+  ( RNG+  , mkRNG+  , withRNG+  , randomToken+  , mkCSRFToken+  ) where -import           Numeric+------------------------------------------------------------------------------+import           Control.Applicative+import           Control.Concurrent+import           Control.Monad import           Data.Serialize import qualified Data.Serialize as S import           Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.Text.Encoding as T import           Data.Text (Text)+import           Numeric import           System.Random.MWC   ------------------------------------------------------------------------------+-- | High speed, mutable random number generator state+newtype RNG = RNG (MVar GenIO)++------------------------------------------------------------------------------+-- | Perform given action, mutating the RNG state+withRNG :: RNG+        -> (GenIO -> IO a)+        -> IO a+withRNG (RNG rng) m = withMVar rng m+++------------------------------------------------------------------------------+-- | Create a new RNG+mkRNG :: IO RNG+mkRNG = withSystemRandom (newMVar >=> return . RNG)+++------------------------------------------------------------------------------ -- | 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+randomToken :: Int -> RNG -> IO ByteString+randomToken n rng = do+    is <- withRNG rng $ \gen -> sequence . take n . repeat $ mk gen     return . B.pack . concat . map (flip showHex "") $ is+  where+    mk :: GenIO -> IO Int+    mk = uniformR (0,15)   ------------------------------------------------------------------------------ -- | Generate a randomized CSRF token-mkCSRFToken :: IO Text-mkCSRFToken = T.decodeUtf8 `fmap` randomToken 40+mkCSRFToken :: RNG -> IO Text+mkCSRFToken rng = T.decodeUtf8 <$> randomToken 40 rng  +------------------------------------------------------------------------------ instance Serialize Text where-  put = S.put . T.encodeUtf8-  get = T.decodeUtf8 `fmap` S.get+    put = S.put . T.encodeUtf8+    get = T.decodeUtf8 <$> S.get
src/Snap/Snaplet/Session/SecureCookie.hs view
@@ -1,34 +1,29 @@ {-# 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.---}+------------------------------------------------------------------------------+-- | 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-+import Web.ClientSession   ------------------------------------------------------------------------------@@ -52,17 +47,17 @@                 -> m (Maybe t) getSecureCookie name key timeout = do     rqCookie <- getCookie name-    rspCookie <- getResponseCookie name `fmap` getResponse+    rspCookie <- getResponseCookie name <$> 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+          to <- checkTimeout timeout ts+          return $ case to of+            True -> Nothing+            False -> Just t   ------------------------------------------------------------------------------@@ -85,12 +80,11 @@ -- | 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.+--+-- * Otherwise, 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+checkTimeout (Just x) t0 = do+    t1 <- liftIO getCurrentTime+    return $ t1 > addUTCTime (fromIntegral x) t0
src/Snap/Starter.hs view
@@ -13,8 +13,7 @@ import           System.Console.GetOpt import           System.FilePath --------------------------------------------------------------------------------import Snap.StarterTH+import           Snap.StarterTH   ------------------------------------------------------------------------------@@ -23,6 +22,7 @@ buildData "tDirDefault" "default" buildData "tDirTutorial" "tutorial" + ------------------------------------------------------------------------------ usage :: String usage = unlines@@ -59,59 +59,72 @@     ]  +------------------------------------------------------------------------------ printUsage :: [String] -> IO () printUsage ("init":_) = putStrLn initUsage printUsage _ = putStrLn usage + ------------------------------------------------------------------------------ -- Only one option for now data Option = Help   deriving (Show, Eq)  +------------------------------------------------------------------------------ setup :: String -> ([FilePath], [(String, String)]) -> IO () setup projName tDir = do     mapM createDirectory (fst tDir)     mapM_ write (snd tDir)   where+    --------------------------------------------------------------------------     write (f,c) =         if isSuffixOf "foo.cabal" f           then writeFile (projName ++ ".cabal") (insertProjName $ T.pack c)           else writeFile f c++    --------------------------------------------------------------------------     isNameChar c = isAlphaNum c || c == '-'++    --------------------------------------------------------------------------     insertProjName c = T.unpack $ T.replace                            (T.pack "projname")                            (T.pack $ filter isNameChar projName) c + ------------------------------------------------------------------------------ initProject :: [String] -> IO () initProject args = do     case getOpt Permute options args of       (flags, other, [])-        | Help `elem` flags -> do printUsage other-                                  exitFailure-        | otherwise         -> go other+          | Help `elem` flags -> printUsage other >> exitFailure+          | otherwise         -> go other+       (_, other, errs) -> do putStrLn $ concat errs                              printUsage other                              exitFailure    where+    --------------------------------------------------------------------------     options =         [ Option ['h'] ["help"]       (NoArg Help)                  "Print this message"         ] +    --------------------------------------------------------------------------     go ("init":rest) = init' rest     go _ = do         putStrLn "Error: Invalid action!"         putStrLn usage         exitFailure +    --------------------------------------------------------------------------     init' args' = do         cur <- getCurrentDirectory-        let dirs = splitDirectories cur+        let dirs     = splitDirectories cur             projName = last dirs-            setup' = setup projName+            setup'   = setup projName+         case args' of           []            -> setup' tDirDefault           ["barebones"] -> setup' tDirBareBones
src/Snap/StarterTH.hs view
@@ -14,11 +14,12 @@ ------------------------------------------------------------------------------ -- Convenience types type FileData = (String, String)-type DirData = FilePath+type DirData  = FilePath   --------------------------------------------------------------------------------- Gets all the directorys in a DirTree+-- Gets all the directories in a DirTree+-- getDirs :: [FilePath] -> DirTree a -> [FilePath] getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) :                            concatMap (getDirs (n:prefix)) c@@ -29,6 +30,7 @@ ------------------------------------------------------------------------------ -- Reads a directory and returns a tuple of the list of all directories -- encountered and a list of filenames and content strings.+-- readTree :: FilePath -> IO ([DirData], [FileData]) readTree dir = do     d <- readDirectory $ dir </> "."@@ -39,7 +41,8 @@   --------------------------------------------------------------------------------- Calls readTree and returns it's value in a quasiquote.+-- Calls readTree and returns its value in a quasiquote.+-- dirQ :: FilePath -> Q Exp dirQ tplDir = do     d <- runIO . readTree $ "project_template" </> tplDir@@ -49,10 +52,11 @@ ------------------------------------------------------------------------------ -- Creates a declaration assigning the specified name the value returned by -- dirQ.+-- buildData :: String -> FilePath -> Q [Dec] buildData dirName tplDir = do-    let dir = mkName dirName-+    let dir  = mkName dirName     typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |]-    v <- valD (varP dir) (normalB $ dirQ tplDir) []+    v       <- valD (varP dir) (normalB $ dirQ tplDir) []+     return [typeSig, v]
+ test/foosnaplet/snaplet.cfg view
@@ -0,0 +1,2 @@+fooSnapletField = "fooValue"+
+ test/foosnaplet/templates/foopage.tpl view
@@ -0,0 +1,1 @@+foo template page
+ test/non-cabal-appdir/bad.tpl view
@@ -0,0 +1,1 @@+<bad template
+ test/non-cabal-appdir/db.cfg view
@@ -0,0 +1,3 @@+dbServer = "localhost"+dbPort   = 1234+
+ test/non-cabal-appdir/good.tpl view
@@ -0,0 +1,1 @@+Good template
+ test/non-cabal-appdir/log/placeholder view
+ test/non-cabal-appdir/snaplet.cfg view
@@ -0,0 +1,6 @@+topConfigField = "topConfigValue"++db  {+import "db.cfg"+}+
+ test/non-cabal-appdir/snaplets/baz/snaplet.cfg view
@@ -0,0 +1,2 @@+barSnapletField = "barValue"+
+ test/non-cabal-appdir/snaplets/baz/templates/bazconfig.tpl view
@@ -0,0 +1,1 @@+baz config page <appconfig/> <fooconfig/>
+ test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl view
@@ -0,0 +1,1 @@+baz template page <barsplice/>
+ test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl view
@@ -0,0 +1,1 @@+This is an extra template
+ test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl view
@@ -0,0 +1,1 @@+embedded snaplet page <asplice/>
+ test/non-cabal-appdir/snaplets/heist/templates/index.tpl view
@@ -0,0 +1,1 @@+index page
+ test/non-cabal-appdir/snaplets/heist/templates/page.tpl view
@@ -0,0 +1,8 @@+<html>+<head>+<title>Example App</title>+</head>+<body>+<content/>+</body>+</html>
+ test/non-cabal-appdir/snaplets/heist/templates/session.tpl view
@@ -0,0 +1,1 @@+<session/>
+ test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl view
@@ -0,0 +1,1 @@+splice page <appsplice/>
test/runTestsAndCoverage.sh view
@@ -22,8 +22,6 @@  $SUITE $* -killall -HUP snap-testsuite- DIR=dist/hpc  rm -Rf $DIR@@ -50,8 +48,8 @@     EXCL="$EXCL --exclude=$m" done -rm -f non-cabal-appdir/templates/bad.tpl-rm -f non-cabal-appdir/templates/good.tpl+rm -f non-cabal-appdir/snaplets/heist/templates/bad.tpl+rm -f non-cabal-appdir/snaplets/heist/templates/good.tpl rm -fr non-cabal-appdir/snaplets/foosnaplet  hpc markup $EXCL --destdir=$DIR snap-testsuite >/dev/null 2>&1
test/snap-testsuite.cabal view
@@ -8,34 +8,33 @@   main-is:         TestSuite.hs    build-depends:-    Glob                       >= 0.5 && < 0.7,-    HUnit                      >= 1.2 && < 2,-    MonadCatchIO-transformers  >= 0.2 && < 0.3,+    Glob                       >= 0.5     && < 0.8,+    HUnit                      >= 1.2     && < 2,+    MonadCatchIO-transformers  >= 0.2     && < 0.3,     QuickCheck                 >= 2.3.0.2,-    attoparsec                 >= 0.10 && <0.11,-    base                       >= 4 && < 5,-    bytestring                 >= 0.9 && < 0.10,+    attoparsec                 >= 0.10    && <0.11,+    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,+    data-lens                  >= 2.0.1   && < 2.1,+    data-lens-template         >= 2.1.1   && < 2.2,     directory,-    directory-tree             >= 0.10 && < 0.11,+    directory-tree             >= 0.10    && < 0.11,     filepath,-    heist                      >= 0.7 && < 0.8,+    heist                      >= 0.7     && < 0.9,     http-enumerator            >= 0.7.1.7 && < 0.8,     mtl                        >= 2,     process                    == 1.*,-    snap-core                  >= 0.7 && < 0.8,-    snap-server                >= 0.7 && < 0.8,-    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,+    snap-core                  >= 0.8     && < 0.9,+    snap-server                >= 0.8     && < 0.9,+    test-framework             >= 0.5     && < 0.6,+    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,+    utf8-string                >= 0.3     && < 0.4,     template-haskell--- FIXME    extensions:     BangPatterns,@@ -65,32 +64,32 @@   main-is:         AppMain.hs    build-depends:-    MonadCatchIO-transformers  >= 0.2 && < 0.3,-    attoparsec                 >= 0.10 && <0.11,-    base                       >= 4 && < 5,-    bytestring                 >= 0.9 && < 0.10,+    MonadCatchIO-transformers  >= 0.2     && < 0.3,+    attoparsec                 >= 0.10    && <0.11,+    base                       >= 4       && < 5,+    bytestring                 >= 0.9     && < 0.10,     cereal                     >= 0.3,     clientsession              >= 0.7.3.6 && <0.8,-    configurator               >= 0.1 && < 0.3,+    configurator               >= 0.1     && < 0.3,     containers                 >= 0.3,-    data-lens                  >= 2.0.1 && < 2.1,-    data-lens-template         >= 2.1.1 && < 2.2,+    data-lens                  >= 2.0.1   && < 2.1,+    data-lens-template         >= 2.1.1   && < 2.2,     directory,-    directory-tree             >= 0.10 && < 0.11,+    directory-tree             >= 0.10    && < 0.11,     filepath,     hashable                   >= 1.1,-    heist                      >= 0.7 && < 0.8,+    heist                      >= 0.7     && < 0.9,     mtl                        >= 2,     mwc-random                 >= 0.8,     process                    == 1.*,-    snap-core                  >= 0.7 && < 0.8,-    snap-server                >= 0.7 && < 0.8,+    snap-core                  >= 0.8     && < 0.9,+    snap-server                >= 0.8     && < 0.9,     syb                        >= 0.1,     time                       >= 1.1,-    text                       >= 0.11 && < 0.12,+    text                       >= 0.11    && < 0.12,     transformers               >= 0.2,     unordered-containers       >= 0.1.4,-    utf8-string                >= 0.3   && < 0.4,+    utf8-string                >= 0.3     && < 0.4,     template-haskell     --FIXME @@ -121,26 +120,25 @@   main-is:         NestTest.hs    build-depends:-    MonadCatchIO-transformers  >= 0.2 && < 0.3,-    attoparsec                 >= 0.10 && <0.11,-    base                       >= 4 && < 5,-    bytestring                 >= 0.9 && < 0.10,+    MonadCatchIO-transformers  >= 0.2   && < 0.3,+    attoparsec                 >= 0.10  && <0.11,+    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,+    data-lens-template         >= 2.1   && < 2.2,     directory,-    directory-tree             >= 0.10 && < 0.11,+    directory-tree             >= 0.10  && < 0.11,     filepath,-    heist                      >= 0.7 && < 0.8,+    heist                      >= 0.7   && < 0.9,     mtl                        >= 2,     process                    == 1.*,-    snap-core                  >= 0.7 && < 0.8,-    snap-server                >= 0.7 && < 0.8,-    text                       >= 0.11 && < 0.12,+    snap-core                  >= 0.8   && < 0.9,+    snap-server                >= 0.8   && < 0.9,+    text                       >= 0.11  && < 0.12,     transformers               >= 0.2,     utf8-string                >= 0.3   && < 0.4,     template-haskell-    --FIXME    extensions:     BangPatterns,
+ test/suite/AppMain.hs view
@@ -0,0 +1,9 @@+module Main where++import           Snap.Http.Server.Config+import           Snap.Snaplet++import           Blackbox.App++main :: IO ()+main = serveSnaplet defaultConfig app
+ test/suite/Blackbox/App.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Blackbox.App where++import Prelude hiding (lookup)++import Control.Applicative+import Control.Monad.Trans+import Data.Lens.Lazy+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Configurator+import Snap.Core+import Snap.Util.FileServe++import Snap.Snaplet+import Snap.Snaplet.Heist+import qualified Snap.Snaplet.HeistNoClass as HNC+import Text.Templating.Heist++import Blackbox.Common+import Blackbox.BarSnaplet+import Blackbox.FooSnaplet+import Blackbox.EmbeddedSnaplet+import Blackbox.Types+import Snap.Snaplet.Session+import Snap.Snaplet.Session.Backends.CookieSession+++routeWithSplice :: Handler App App ()+routeWithSplice = do+    str <- with foo getFooField+    writeText $ T.pack $ "routeWithSplice: "++str++routeWithConfig :: Handler App App ()+routeWithConfig = do+    cfg <- getSnapletUserConfig+    val <- liftIO $ lookup cfg "topConfigField"+    writeText $ "routeWithConfig: " `T.append` fromJust val+++sessionDemo :: Handler App App ()+sessionDemo = withSession session $ do+  with session $ do+    curVal <- getFromSession "foo"+    case curVal of+      Nothing -> do+        setInSession "foo" "bar"+      Just _ -> return ()+  list <- with session $ (T.pack . show) `fmap` sessionToList+  csrf <- with session $ (T.pack . show) `fmap` csrfToken+  HNC.renderWithSplices heist "session"+    [ ("session", liftHeist $ textSplice list)+    , ("csrf", liftHeist $ textSplice csrf) ]++sessionTest :: Handler App App ()+sessionTest = withSession session $ do+  q <- getParam "q"+  val <- case q of+    Just x -> do+      let x' = T.decodeUtf8 x+      with session $ setInSession "test" x'+      return x'+    Nothing -> maybe "" id `fmap` with session (getFromSession "test")+  writeText val++fooMod :: FooSnaplet -> FooSnaplet+fooMod f = f { fooField = fooField f ++ "z" }++app :: SnapletInit App App+app = makeSnaplet "app" "Test application" Nothing $ do+    hs <- nestSnaplet "heist" heist $ heistInit "templates"+    fs <- nestSnaplet "foo" foo fooInit+    bs <- nestSnaplet "" bar $ nameSnaplet "baz" $ barInit foo+    sm <- nestSnaplet "session" session $+          initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60))+    ns <- embedSnaplet "embed" embedded embeddedInit+    addSplices+        [("appsplice", liftHeist $ textSplice "contents of the app splice")]+    HNC.addSplices heist+        [("appconfig", shConfigSplice)]+    addRoutes [ ("/hello", writeText "hello world")+              , ("/routeWithSplice", routeWithSplice)+              , ("/routeWithConfig", routeWithConfig)+              , ("/public", serveDirectory "public")+              , ("/sessionDemo", sessionDemo)+              , ("/sessionTest", sessionTest)+              ]+    wrapHandlers (<|> heistServe)+    return $ App hs (modL snapletValue fooMod fs) bs sm ns+++
+ test/suite/Blackbox/BarSnaplet.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+module Blackbox.BarSnaplet where++import Prelude hiding (lookup)++import Control.Monad.State+import qualified Data.ByteString as B+import Data.Configurator+import Data.Lens.Lazy+import Data.Lens.Template+import Data.Maybe+import Data.Text (Text)+import Snap.Snaplet+import Snap.Snaplet.Heist+import Snap.Core+import Text.Templating.Heist++import Blackbox.Common+import Blackbox.FooSnaplet++data BarSnaplet b = BarSnaplet+    { _barField :: String+    , fooLens  :: Lens b (Snaplet FooSnaplet)+    }++makeLens ''BarSnaplet++barsplice :: [(Text, SnapletHeist b v Template)]+barsplice = [("barsplice", liftHeist $ textSplice "contents of the bar splice")]++barInit :: HasHeist b+        => Lens b (Snaplet FooSnaplet)+        -> SnapletInit b (BarSnaplet b)+barInit l = makeSnaplet "barsnaplet" "An example snaplet called bar." Nothing $ do+    config <- getSnapletUserConfig+    addTemplates ""+    rootUrl <- getSnapletRootURL+    addRoutes [("barconfig", liftIO (lookup config "barSnapletField") >>= writeLBS . fromJust)+              ,("barrooturl", writeBS $ "url" `B.append` rootUrl)+              ,("bazpage2",   renderWithSplices "bazpage" barsplice)+              ,("bazpage3",   heistServeSingle "bazpage")+              ,("bazpage4",   renderAs "text/html" "bazpage")+              ,("bazpage5",   renderWithSplices "bazpage"+                                [("barsplice", shConfigSplice)])+              ,("bazbadpage", heistServeSingle "cpyga")+              ,("bar/handlerConfig", handlerConfig)+              ]+    return $ BarSnaplet "bar snaplet data string" l+
+ test/suite/Blackbox/Common.hs view
@@ -0,0 +1,23 @@+module Blackbox.Common where++import qualified Data.Text as T+import Snap.Core+import Snap.Snaplet+import Snap.Snaplet.Heist+import Text.Templating.Heist++genericConfigString :: (MonadSnaplet m, Monad (m b v)) => m b v T.Text+genericConfigString = do+    a <- getSnapletAncestry+    b <- getSnapletFilePath+    c <- getSnapletName+    d <- getSnapletDescription+    e <- getSnapletRootURL+    return $ T.pack $ show (a,b,c,d,e)++handlerConfig :: Handler b v ()+handlerConfig = writeText =<< genericConfigString++shConfigSplice :: SnapletSplice b v+shConfigSplice = liftHeist . textSplice =<< genericConfigString+
+ test/suite/Blackbox/EmbeddedSnaplet.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Blackbox.EmbeddedSnaplet where++import Prelude hiding ((.))+import Control.Monad.State+import Data.Lens.Lazy+import Data.Lens.Template+import qualified Data.Text as T+import System.FilePath.Posix++import Snap.Snaplet+import Snap.Snaplet.Heist+import Text.Templating.Heist++-- If we universally quantify EmbeddedSnaplet to get rid of the type parameter+-- mkLabels throws an error "Can't reify a GADT data constructor"+data EmbeddedSnaplet = EmbeddedSnaplet+    { _embeddedHeist :: Snaplet (Heist EmbeddedSnaplet)+    , _embeddedVal :: Int+    }++makeLenses [''EmbeddedSnaplet]++instance HasHeist EmbeddedSnaplet where+    heistLens = subSnaplet embeddedHeist++embeddedInit :: SnapletInit EmbeddedSnaplet EmbeddedSnaplet+embeddedInit = makeSnaplet "embedded" "embedded snaplet" Nothing $ do+    hs <- nestSnaplet "heist" embeddedHeist $ heistInit "templates"++    -- This is the implementation of addTemplates, but we do it here manually+    -- to test coverage for addTemplatesAt.+    snapletPath <- getSnapletFilePath+    addTemplatesAt "onemoredir" (snapletPath </> "extra-templates")++    embeddedLens <- getLens+    addRoutes [("aoeuhtns", withSplices+                    [("asplice", embeddedSplice embeddedLens)]+                    (render "embeddedpage"))+              ]+    return $ EmbeddedSnaplet hs 42+++embeddedSplice :: (Lens (Snaplet b) (Snaplet EmbeddedSnaplet))+              -> SnapletHeist b v Template+embeddedSplice embeddedLens = do+    val <- liftWith embeddedLens $ gets _embeddedVal+    liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val)+
+ test/suite/Blackbox/FooSnaplet.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+module Blackbox.FooSnaplet where++import Prelude hiding (lookup)+import Control.Monad.State+import Data.Configurator+import Data.Maybe+import qualified Data.Text as T+import Snap.Snaplet+import Snap.Snaplet.Heist+import Snap.Core+import Text.Templating.Heist++import Blackbox.Common++data FooSnaplet = FooSnaplet { fooField :: String }++fooInit :: HasHeist b => SnapletInit b FooSnaplet+fooInit = makeSnaplet "foosnaplet" "A demonstration snaplet called foo."+    (Just $ return "../foosnaplet") $ do+    config <- getSnapletUserConfig+    addTemplates ""+    addSplices+        [("foosplice", liftHeist $ textSplice "contents of the foo splice")]+    rootUrl <- getSnapletRootURL+    fp <- getSnapletFilePath+    name <- getSnapletName+    addSplices [("fooconfig", shConfigSplice)]+    addRoutes [("fooConfig", liftIO (lookup config "fooSnapletField") >>= writeLBS . fromJust)+              ,("fooRootUrl", writeBS rootUrl)+              ,("fooSnapletName", writeText $ fromMaybe "empty snaplet name" name)+              ,("fooFilePath", writeText $ T.pack fp)+              ,("handlerConfig", handlerConfig)+              ]+    return $ FooSnaplet "foo snaplet data string"++getFooField :: Handler b FooSnaplet String+getFooField = gets fooField+
+ test/suite/Blackbox/Tests.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Blackbox.Tests+  ( tests+  , remove+  , removeDir+  ) where++------------------------------------------------------------------------------+import           Control.Exception              (catch, throwIO)+import           Control.Monad+import           Control.Monad.Trans+import qualified Data.ByteString.Char8          as S+import qualified Data.ByteString.Lazy.Char8     as L+import           Data.Text.Lazy                 (Text)+import qualified Data.Text.Lazy.Encoding        as T+import qualified Network.HTTP.Enumerator        as HTTP+import           Prelude                        hiding (catch)+import           System.Directory+import           System.FilePath+import           Test.Framework                 (Test, testGroup)+import           Test.Framework.Providers.HUnit+import           Test.HUnit                     hiding (Test, path)++------------------------------------------------------------------------------+-- TODO: fix all the hardcoded ports and strings in here, order the functions+-- non-randomly+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+testName :: String -> String+testName uri = "internal/" ++ uri++------------------------------------------------------------------------------+requestTest :: String -> Text -> Test+requestTest url desired = testCase (testName url) $ requestTest' url desired+++------------------------------------------------------------------------------+assertRelativelyTheSame :: FilePath -> FilePath -> IO ()+assertRelativelyTheSame p expected = do+    b <- makeRelativeToCurrentDirectory p+    assertEqual ("expected " ++ expected) expected b+++------------------------------------------------------------------------------+testServerUri :: String+testServerUri = "http://127.0.0.1:9753"+++------------------------------------------------------------------------------+grab :: MonadIO m => String -> m L.ByteString+grab path = liftIO $ HTTP.simpleHttp $ testServerUri ++ path+++------------------------------------------------------------------------------+fooConfigPathTest :: Test+fooConfigPathTest = testCase (testName "foo/fooFilePath") $ do+    b <- liftM L.unpack $ grab "/foo/fooFilePath"+    assertRelativelyTheSame b "non-cabal-appdir/snaplets/foosnaplet"+++------------------------------------------------------------------------------+testWithCwd :: String+            -> (String -> L.ByteString -> Assertion)+            -> Test+testWithCwd uri f = testCase (testName uri) $+                    testWithCwd' uri f+++------------------------------------------------------------------------------+testWithCwd' :: String+             -> (String -> L.ByteString -> Assertion)+             -> Assertion+testWithCwd' uri f = do+    b   <- grab slashUri+    cwd <- getCurrentDirectory++    f cwd b++  where+    slashUri = "/" ++ uri+++------------------------------------------------------------------------------+fooHandlerConfigTest :: Test+fooHandlerConfigTest = testWithCwd "foo/handlerConfig" $ \cwd b -> do+    let response = L.fromChunks [ "([\"app\"],\""+                                , S.pack cwd+                                , "/non-cabal-appdir/snaplets/foosnaplet\","+                                , "Just \"foosnaplet\",\"A demonstration "+                                , "snaplet called foo.\",\"foo\")" ]+    assertEqual "" response b+++------------------------------------------------------------------------------+barHandlerConfigTest :: Test+barHandlerConfigTest = testWithCwd "bar/handlerConfig" $ \cwd b -> do+    let response = L.fromChunks [ "([\"app\"],\""+                                , S.pack cwd+                                , "/non-cabal-appdir/snaplets/baz\","+                                , "Just \"baz\",\"An example snaplet called "+                                , "bar.\",\"\")" ]+    assertEqual "" response b+++------------------------------------------------------------------------------+-- bazpage5 uses barsplice bound by renderWithSplices at request time+bazpage5Test :: Test+bazpage5Test = testWithCwd "bazpage5" $ \cwd b -> do+    let response = L.fromChunks [ "baz template page ([\"app\"],\""+                                , S.pack cwd+                                , "/non-cabal-appdir/snaplets/baz\","+                                , "Just \"baz\",\"An example snaplet called "+                                , "bar.\",\"\")\n" ]+    assertEqual "" response b+++------------------------------------------------------------------------------+-- bazconfig uses two splices, appconfig and fooconfig. appconfig is bound with+-- the non type class version of addSplices in the main app initializer.+-- fooconfig is bound by addSplices in fooInit.+bazConfigTest :: Test+bazConfigTest = testWithCwd "bazconfig" $ \cwd b -> do+    let response = L.fromChunks [+                     "baz config page ([],\""+                   , S.pack cwd+                   , "/non-cabal-appdir\",Just \"app\","+                   , "\"Test application\",\"\") "+                   , "([\"app\"],\""+                   , S.pack cwd+                   , "/non-cabal-appdir/snaplets/foosnaplet\","+                   , "Just \"foosnaplet\",\"A demonstration snaplet "+                   , "called foo.\",\"foo\")\n"+                   ]++    assertEqual "" response b+++------------------------------------------------------------------------------+expect404 :: String -> IO ()+expect404 url = action `catch` h+  where+    action = do+        HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url+        assertFailure "expected 404"++    h e@(HTTP.StatusCodeException c _) | c == 404  = return ()+                                       | otherwise = throwIO e+    h e                                            = throwIO e+++------------------------------------------------------------------------------+request404Test :: String -> Test+request404Test url = testCase (testName url) $ expect404 url+++------------------------------------------------------------------------------+requestTest' :: String -> Text -> IO ()+requestTest' url desired = do+    actual <- HTTP.simpleHttp $ "http://127.0.0.1:9753/" ++ url+    assertEqual url desired (T.decodeUtf8 actual)+++------------------------------------------------------------------------------+requestNoError :: String -> Text -> Test+requestNoError url desired =+    testCase (testName url) $ requestNoError' url desired+++------------------------------------------------------------------------------+requestNoError' :: String -> Text -> IO ()+requestNoError' url desired = do+    let fullUrl = "http://127.0.0.1:9753/" ++ url+    url' <- HTTP.parseUrl fullUrl+    HTTP.Response _ _ b <- liftIO $ HTTP.withManager $ HTTP.httpLbsRedirect url'+    assertEqual fullUrl desired (T.decodeUtf8 b)+++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "non-cabal-tests"+    [ requestTest "hello" "hello world"+    , requestTest "index" "index page\n"+    , requestTest "" "index page\n"+    , requestTest "splicepage" "splice page contents of the app splice\n"+    , requestTest "routeWithSplice" "routeWithSplice: foo snaplet data stringz"+    , requestTest "routeWithConfig" "routeWithConfig: topConfigValue"+    , requestTest "foo/foopage" "foo template page\n"+    , requestTest "foo/fooConfig" "fooValue"+    , requestTest "foo/fooRootUrl" "foo"+    , requestTest "barconfig" "barValue"+    , requestTest "bazpage" "baz template page <barsplice></barsplice>\n"+    , requestTest "bazpage2" "baz template page contents of the bar splice\n"+    , requestTest "bazpage3" "baz template page <barsplice></barsplice>\n"+    , requestTest "bazpage4" "baz template page <barsplice></barsplice>\n"+    , requestTest "barrooturl" "url"+    , requestNoError "bazbadpage" "A web handler threw an exception. Details:\nTemplate \"cpyga\" not found."+    , requestTest "foo/fooSnapletName" "foosnaplet"++    , fooConfigPathTest++    -- Test the embedded snaplet+    , requestTest "embed/heist/embeddedpage" "embedded snaplet page <asplice></asplice>\n"+    , requestTest "embed/aoeuhtns" "embedded snaplet page splice value42\n"+    , requestTest "embed/heist/onemoredir/extra" "This is an extra template\n"++    -- This set of tests highlights the differences in the behavior of the+    -- get... functions from MonadSnaplet.+    , fooHandlerConfigTest+    , barHandlerConfigTest+    , bazpage5Test+    , bazConfigTest+    , requestTest "sessionDemo" "[(\"foo\",\"bar\")]\n"+    , reloadTest+    ]++remove :: FilePath -> IO ()+remove f = do+    exists <- doesFileExist f+    when exists $ removeFile f+++removeDir :: FilePath -> IO ()+removeDir d = do+    exists <- doesDirectoryExist d+    when exists $ removeDirectoryRecursive "non-cabal-appdir/snaplets/foosnaplet"+++------------------------------------------------------------------------------+reloadTest :: Test+reloadTest = testCase "internal/reload-test" $ do+    let goodTplOrig = "non-cabal-appdir" </> "good.tpl"+    let badTplOrig  = "non-cabal-appdir" </> "bad.tpl"+    let goodTplNew  = "non-cabal-appdir" </> "snaplets"  </> "heist"+                                         </> "templates" </> "good.tpl"+    let badTplNew   = "non-cabal-appdir" </> "snaplets"  </> "heist"+                                         </> "templates" </> "bad.tpl"++    goodExists <- doesFileExist goodTplNew+    badExists  <- doesFileExist badTplNew++    assertBool "good.tpl exists" (not goodExists)+    assertBool "bad.tpl exists" (not badExists)+    expect404 "bad"++    copyFile badTplOrig badTplNew+    expect404 "good"+    expect404 "bad"++    testWithCwd' "admin/reload" $ \cwd' b -> do+        let cwd = S.pack cwd'+        let response =+                L.fromChunks [ "Error reloading site!\n\nInitializer "+                             , "threw an exception...\n"+                             , cwd+                             , "/non-cabal-appdir/snaplets/heist"+                             , "/templates/bad.tpl \""+                             , cwd+                             , "/non-cabal-appdir/snaplets/heist/templates"+                             , "/bad.tpl\" (line 2, column 1):\nunexpected "+                             , "end of input\nexpecting \"=\", \"/\" or "+                             , "\">\"\n\n\n...but before it died it generated "+                             , "the following output:\nInitializing app @ /\n"+                             , "Initializing heist @ /heist\n\n" ]+        assertEqual "admin/reload" response b++    remove badTplNew+    copyFile goodTplOrig goodTplNew++    testWithCwd' "admin/reload" $ \cwd' b -> do+        let cwd = S.pack cwd'+        let response =+                L.fromChunks [ "Initializing app @ /\n"+                             , "Initializing heist @ /heist\n"+                             , "...loaded 5 templates from "+                             , cwd+                             , "/non-cabal-appdir/snaplets/heist/templates\n"+                             , "Initializing foosnaplet @ /foo\n"+                             , "...adding 1 templates from "+                             , cwd+                             , "/non-cabal-appdir/snaplets/foosnaplet"+                             , "/templates with route prefix foo/\n"+                             , "Initializing baz @ /\n"+                             , "...adding 2 templates from "+                             , cwd+                             , "/non-cabal-appdir/snaplets/baz/templates "+                             , "with route prefix /\n"+                             , "Initializing CookieSession @ /session\n"+                             , "Initializing embedded @ /\n"+                             , "Initializing heist @ /heist\n"+                             , "...loaded 1 templates from "+                             , cwd+                             , "/non-cabal-appdir/snaplets/embedded"+                             , "/snaplets/heist/templates\n"+                             , "...adding 1 templates from "+                             , cwd+                             , "/non-cabal-appdir/snaplets/embedded"+                             , "/extra-templates with route prefix "+                             , "onemoredir/\n"+                             , "Site successfully reloaded.\n"+                             ]++        assertEqual "admin/reload" response b++    requestTest' "good" "Good template\n"+
+ test/suite/Blackbox/Types.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Blackbox.Types where+++import Data.Lens.Template++import Snap.Snaplet+import Snap.Snaplet.Heist++import Blackbox.FooSnaplet+import Blackbox.BarSnaplet+import Blackbox.EmbeddedSnaplet+import Snap.Snaplet.Session+++data App = App+    { _heist :: Snaplet (Heist App)+    , _foo :: Snaplet FooSnaplet+    , _bar :: Snaplet (BarSnaplet App)+    , _session :: Snaplet SessionManager+    , _embedded :: Snaplet EmbeddedSnaplet+    }++makeLenses [''App]++instance HasHeist App where heistLens = subSnaplet heist+
+ test/suite/NestTest.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Main where++import Prelude hiding ((.))+import Control.Monad.State+import Data.Lens.Lazy+import Data.Lens.Template+import qualified Data.Text as T+import           Snap.Http.Server.Config+import Snap.Core+import Snap.Util.FileServe++import Snap.Snaplet+import Snap.Snaplet.Heist+import Text.Templating.Heist++-- If we universally quantify FooSnaplet to get rid of the type parameter+-- mkLabels throws an error "Can't reify a GADT data constructor"+data FooSnaplet = FooSnaplet+    { _fooHeist :: Snaplet (Heist FooSnaplet)+    , _fooVal :: Int+    }++makeLenses [''FooSnaplet]++instance HasHeist FooSnaplet where+    heistLens = subSnaplet fooHeist++fooInit :: SnapletInit FooSnaplet FooSnaplet+fooInit = makeSnaplet "foosnaplet" "foo snaplet" Nothing $ do+    hs <- nestSnaplet "heist" fooHeist $ heistInit "templates"+    addTemplates "foo"+    rootUrl <- getSnapletRootURL+    fooLens <- getLens+    addRoutes [("fooRootUrl", writeBS rootUrl)+              ,("aoeuhtns", renderWithSplices "foo/foopage"+                    [("asplice", fooSplice fooLens)])+              ,("", heistServe)+              ]+    return $ FooSnaplet hs 42+++--fooSplice :: (Lens (Snaplet b) (Snaplet (FooSnaplet b)))+--          -> SnapletSplice (Handler b b)+fooSplice :: (Lens (Snaplet b) (Snaplet FooSnaplet))+          -> SnapletHeist b v Template+fooSplice fooLens = do+    val <- liftWith fooLens $ gets _fooVal+    liftHeist $ textSplice $ T.pack $ "splice value" ++ (show val)++------------------------------------------------------------------------------++data App = App+    { _foo :: Snaplet (FooSnaplet)+    }++makeLenses [''App]++app :: SnapletInit App App+app = makeSnaplet "app" "nested snaplet application" Nothing $ do+    fs <- embedSnaplet "foo" foo fooInit+    addRoutes [ ("/hello", writeText "hello world")+              , ("/public", serveDirectory "public")+              ]+    return $ App fs++main :: IO ()+main = serveSnaplet defaultConfig app+
+ test/suite/SafeCWD.hs view
@@ -0,0 +1,30 @@+module SafeCWD+  ( inDir+  , removeDirectoryRecursiveSafe+  ) where++import Control.Concurrent.QSem+import Control.Exception+import Control.Monad+import System.Directory+import System.IO.Unsafe++sem :: QSem+sem = unsafePerformIO $ newQSem 1++inDir :: Bool -> FilePath -> IO a -> IO a+inDir startClean dir action = bracket before after (const action)+  where+    before = do+        waitQSem sem+        cwd <- getCurrentDirectory+        when startClean $ removeDirectoryRecursiveSafe dir+        createDirectoryIfMissing True dir+        setCurrentDirectory dir+        return cwd+    after cwd = do+        setCurrentDirectory cwd+        signalQSem sem++removeDirectoryRecursiveSafe p =+    doesDirectoryExist p >>= flip when (removeDirectoryRecursive p)
+ test/suite/Snap/Snaplet/Internal/LensT/Tests.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TemplateHaskell #-}++module Snap.Snaplet.Internal.LensT.Tests (tests) where++import           Control.Applicative+import           Control.Category+import           Control.Monad.Identity+import           Control.Monad.State.Strict+import           Data.Lens.Template+import           Prelude hiding (catch, (.))+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.HUnit hiding (Test, path)+++------------------------------------------------------------------------------+import           Snap.Snaplet.Internal.LensT+++------------------------------------------------------------------------------+data TestType = TestType {+      _int0 :: Int+    , _sub  :: TestSubType+} deriving (Show)++data TestSubType = TestSubType {+      _sub0 :: Int+    , _sub1 :: Int+    , _bot  :: TestBotType+} deriving (Show)++data TestBotType = TestBotType {+      _bot0 :: Int+} deriving (Show)++makeLenses [''TestType, ''TestSubType, ''TestBotType]+++------------------------------------------------------------------------------+defaultState :: TestType+defaultState = TestType 1 $ TestSubType 2 999 $ TestBotType 3+++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Snap.Snaplet.Internal.LensT"+                  [ testfmap+                  , testApplicative+                  , testMonadState+                  ]+++------------------------------------------------------------------------------+testfmap :: Test+testfmap = testCase "lensed/fmap" $ do+--    x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState+    let x = fst $ runIdentity (runLensT (fmap (*2) three) (bot . sub) defaultState)+    assertEqual "fmap" 6 x++    let (y,s') = runIdentity (runLensT twiddle (bot . sub) defaultState)++    assertEqual "fmap2" (12 :: Int) y+    assertEqual "lens" (13 :: Int) $ _bot0 $ _bot $ _sub s'+    return ()++  where+--    three :: LensT TestType TestBotType IO Int+    three = return 3++    twiddle = do+        modify $ \(TestBotType x) -> TestBotType (x+10)+        fmap (+9) three+++------------------------------------------------------------------------------+testApplicative :: Test+testApplicative = testCase "lensed/applicative" $ do+--    x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState+    let x = fst $ runIdentity (runLensT (pure (*2) <*> three) (bot . sub) defaultState)+    assertEqual "fmap" 6 x++    let (y,s') = runIdentity (runLensT twiddle (bot . sub) defaultState)++    assertEqual "fmap2" (12::Int) y+    assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'+    return ()++  where+--    three :: LensT TestType TestBotType IO Int+    three = pure 3++    twiddle = do+        modify $ \(TestBotType x) -> TestBotType (x+10)+        pure [] *> (pure (+9) <*> three) <* pure []+++------------------------------------------------------------------------------+testMonadState :: Test+testMonadState = testCase "lens/MonadState" $ do+--    s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState+    let s = snd $ runIdentity (runLensT go (bot0 . bot . sub) defaultState)++    assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s+    assertEqual "sub0" 3 $ _sub0 $ _sub s+    assertEqual "sub1" 999 $ _sub1 $ _sub s++  where+--    go :: LensT TestType Int IO ()+    go = do+        modify (*2)+        modify (+3)+        withTop sub go'++--    go' :: LensT TestType TestSubType IO ()+    go' = do+        a <- with sub0 get+        with sub0 $ put $ a+1++
+ test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE TemplateHaskell #-}++module Snap.Snaplet.Internal.Lensed.Tests (tests) where++import           Control.Applicative+import           Control.Category+import           Control.Exception+import           Control.Monad.State.Strict+import           Data.Lens.Template+import           Prelude hiding (catch, (.))+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.HUnit hiding (Test, path)+++------------------------------------------------------------------------------+import           Snap.Snaplet.Internal.Lensed+++------------------------------------------------------------------------------+data TestType = TestType {+      _int0 :: Int+    , _sub  :: TestSubType+} deriving (Show)++data TestSubType = TestSubType {+      _sub0 :: Int+    , _sub1 :: Int+    , _bot  :: TestBotType+} deriving (Show)++data TestBotType = TestBotType {+      _bot0 :: Int+} deriving (Show)++makeLenses [''TestType, ''TestSubType, ''TestBotType]+++------------------------------------------------------------------------------+defaultState :: TestType+defaultState = TestType 1 $ TestSubType 2 999 $ TestBotType 3+++------------------------------------------------------------------------------+tests = testGroup "Snap.Snaplet.Internal.Lensed"+                  [ testfmap+                  , testApplicative+                  , testMonadState+                  ]+++------------------------------------------------------------------------------+testfmap :: Test+testfmap = testCase "lensed/fmap" $ do+    x <- evalStateT (lensedAsState (fmap (*2) three) (bot . sub)) defaultState+    assertEqual "fmap" 6 x++    (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState++    assertEqual "fmap2" 12 y+    assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'+    return ()++  where+    three :: Lensed TestType TestBotType IO Int+    three = return 3++    twiddle = do+        modify $ \(TestBotType x) -> TestBotType (x+10)+        fmap (+9) three+++------------------------------------------------------------------------------+testApplicative :: Test+testApplicative = testCase "lensed/applicative" $ do+    x <- evalStateT (lensedAsState (pure (*2) <*> three) (bot . sub)) defaultState+    assertEqual "fmap" 6 x++    (y,s') <- runStateT (lensedAsState twiddle (bot . sub)) defaultState++    assertEqual "fmap2" (12::Int) y+    assertEqual "lens" 13 $ _bot0 $ _bot $ _sub s'+    return ()++  where+    three :: Lensed TestType TestBotType IO Int+    three = pure 3++    twiddle = do+        modify $ \(TestBotType x) -> TestBotType (x+10)+        pure [] *> (pure (+9) <*> three) <* pure []+++------------------------------------------------------------------------------+testMonadState :: Test+testMonadState = testCase "lens/MonadState" $ do+    s <- execStateT (lensedAsState go (bot0 . bot . sub)) defaultState++    assertEqual "bot0" 9 $ _bot0 $ _bot $ _sub s+    assertEqual "sub0" 3 $ _sub0 $ _sub s+    assertEqual "sub1" 1000 $ _sub1 $ _sub s++  where+    go :: Lensed TestType Int IO ()+    go = do+        modify (*2)+        modify (+3)+        withTop sub go'++    go' :: Lensed TestType TestSubType IO ()+    go' = do+        a <- with sub0 get+        with sub0 $ put $ a+1+        embed sub1 go''++    go'' :: Lensed TestSubType Int IO ()+    go'' = modify (+1)+++eat :: SomeException -> IO ()+eat _ = return ()++qqq = defaultMainWithArgs [tests] ["--plain"] `catch` eat
+ test/suite/Snap/Snaplet/Internal/RST/Tests.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TemplateHaskell #-}++module Snap.Snaplet.Internal.RST.Tests+  ( tests ) where++import           Control.Applicative+import           Control.Monad.Identity+import           Control.Monad.Reader+import           Control.Monad.State+import           Prelude hiding (catch, (.))+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.Framework.Providers.QuickCheck2+import           Test.HUnit hiding (Test, path)++import Snap.Snaplet.Internal.RST+++tests :: Test+tests = testGroup "Snap.Snaplet.Internal.RST"+    [ testExec+    , testEval+    , testFail+    , testAlternative+    ]+++testEval :: Test+testEval = testProperty "RST/execRST" prop+  where+    prop x = runIdentity (evalRST m x undefined) == x+    m :: RST Int () Identity Int+    m = ask++testExec :: Test+testExec = testProperty "RST/execRST" prop+  where+    prop x = runIdentity (execRST m undefined x) == x+    m :: RST () Int Identity Int+    m = get++testFail :: Test+testFail = testCase "RST/fail" $+    assertEqual "RST fail" rstFail Nothing++testAlternative :: Test+testAlternative = testCase "RST/Alternative" $ do+    assertEqual "Alternative instance" rstAlt (Just (5, 1))+    assertEqual "Alternative instance" rstAlt2 (Just (5, 1))++addEnv :: Monad m => RST Int Int m ()+addEnv = do+    v <- ask+    modify (+v)++rstAlt :: Maybe (Int, Int)+rstAlt = runRST (addEnv >> (empty <|> (return 5))) 1 0++rstAlt2 :: Maybe (Int, Int)+rstAlt2 = runRST (addEnv >> ((return 5) <|> empty)) 1 0++rstFail :: Maybe Int+rstFail = evalRST (fail "foo") (0 :: Int) (0 :: Int)+
+ test/suite/Snap/Snaplet/Internal/Tests.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports      #-}+{-# LANGUAGE TemplateHaskell     #-}++module Snap.Snaplet.Internal.Tests+  ( tests, initTest ) where++------------------------------------------------------------------------------+import           Control.Monad+import           Control.Monad.Trans+import           Data.ByteString (ByteString)+import           Data.Lens.Template+import           Data.List+import           Data.Text+import           Prelude hiding (catch, (.))+import           System.Directory+import           Test.Framework+import           Test.Framework.Providers.HUnit+import           Test.HUnit hiding (Test, path)+------------------------------------------------------------------------------+import           Snap.Snaplet.Internal.Initializer+import           Snap.Snaplet.Internal.Types+++                       ---------------------------------+                       -- TODO: this module is a mess --+                       ---------------------------------+++------------------------------------------------------------------------------+data Foo = Foo Int++data Bar = Bar Int+++data App = App+    { _foo :: Snaplet Foo+    , _bar :: Snaplet Bar+    }++makeLens ''App++--showConfig :: SnapletConfig -> IO ()+--showConfig c = do+--    putStrLn "SnapletConfig:"+--    print $ _scAncestry c+--    print $ _scFilePath c+--    print $ _scId c+--    print $ _scDescription c+--    print $ _scRouteContext c+--    putStrLn ""+++------------------------------------------------------------------------------+assertGet :: (MonadIO m, Show a, Eq a) => String -> m a -> a -> m ()+assertGet name getter val = do+    v <- getter+    liftIO $ assertEqual name val v+++------------------------------------------------------------------------------+configAssertions :: (MonadSnaplet m, MonadIO (m b v))+                 => [Char]+                 -> ([Text], FilePath, Maybe Text, Text, ByteString)+                 -> m b v ()+configAssertions prefix (a,f,n,d,r) = do+    assertGet (prefix ++ "ancestry"      ) getSnapletAncestry    a+    assertGet (prefix ++ "file path"     ) getSnapletFilePath    f+    assertGet (prefix ++ "name"          ) getSnapletName        n+    assertGet (prefix ++ "description"   ) getSnapletDescription d+    assertGet (prefix ++ "route context" ) getSnapletRootURL     r+++------------------------------------------------------------------------------+appInit :: SnapletInit App App+appInit = makeSnaplet "app" "Test application" Nothing $ do+    cwd <- liftIO getCurrentDirectory++    configAssertions "root "+        ([], cwd, Just "app", "Test application", "")+    f <- nestSnaplet "foo" foo $ fooInit+    b <- nestSnaplet "bar" bar $ barInit+    return $ App f b+++------------------------------------------------------------------------------+fooInit :: SnapletInit b Foo+fooInit = makeSnaplet "foo" "Foo Snaplet" Nothing $ do+    cwd <- liftIO getCurrentDirectory+    let dir = cwd ++ "/snaplets/foo"++    configAssertions "foo "+        (["app"], dir, Just "foo", "Foo Snaplet", "foo")+    return $ Foo 42+++------------------------------------------------------------------------------+barInit :: SnapletInit b Bar+barInit = makeSnaplet "bar" "Bar Snaplet" Nothing $ do+    cwd <- liftIO getCurrentDirectory+    let dir = cwd ++ "/snaplets/bar"+    configAssertions "bar "+        (["app"], dir, Just "bar", "Bar Snaplet", "bar")+    return $ Bar 2+++------------------------------------------------------------------------------+initTest :: IO ()+initTest = do+    (out,_,_) <- runSnaplet appInit++    -- note from gdc: wtf?+    if out == "aoeu"+      then putStrLn "Something really strange"+      else return ()+++------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Snap.Snaplet.Internal"+    [ testCase "initializer tests" initTest+    ]+
test/suite/Snap/TestCommon.hs view
@@ -2,23 +2,38 @@  module Snap.TestCommon where -import Control.Concurrent-import Control.Exception-import Control.Monad (forM_, when)-import Data.Maybe-import Data.Monoid-import Prelude hiding (catch)-import System.Cmd-import System.Directory-import System.Environment-import System.Exit-import System.FilePath-import System.FilePath.Glob-import System.Process hiding (cwd)+------------------------------------------------------------------------------+import Control.Concurrent   ( threadDelay                )+import Control.Exception    ( ErrorCall(..)+                            , SomeException+                            , bracket+                            , catch+                            , throwIO+                            )+import Control.Monad        ( forM_                      )+import Data.Maybe           ( fromMaybe                  )+import Data.Monoid          ( First(..), mconcat         )+import Prelude       hiding ( catch                      )+import System.Cmd           ( system                     )+import System.Directory     ( doesFileExist+                            , getCurrentDirectory+                            , findExecutable+                            , removeFile+                            )+import System.Environment   ( getEnv                     )+import System.Exit          ( ExitCode(..)               )+import System.FilePath      ( joinPath, splitPath, (</>) )+import System.FilePath.Glob ( compile, globDir1          )+import System.Process       ( runCommand+                            , terminateProcess+                            , waitForProcess+                            ) +------------------------------------------------------------------------------ import SafeCWD  +------------------------------------------------------------------------------ testGeneratedProject :: String  -- ^ project name and directory                      -> String  -- ^ arguments to @snap init@                      -> String  -- ^ arguments to @cabal install@@@ -28,23 +43,25 @@ testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort                      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"-+    --------------------------------------------------------------------------+    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 +        args         = cabalDevArgs ++ " --reinstall " ++ cabalInstallArgs +        ----------------------------------------------------------------------         initialize = do             snapExe <- findSnap             systemOrDie $ snapExe ++ " init " ++ snapInitArgs -            snapCoreSrc   <- fromEnv "SNAP_CORE_SRC" $ snapRepos </> "snap-core"-            snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $ snapRepos </> "snap-server"+            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@@ -54,8 +71,11 @@              forM_ [ snapCoreSrc, snapServerSrc, xmlhtmlSrc, heistSrc                   , snapSrc] $ \s ->-                systemOrDie $ "cabal-dev " ++ cabalDevArgs-                                ++ " add-source " ++ s+                systemOrDie $ concat [ "cabal-dev "+                                     , cabalDevArgs+                                     , " add-source "+                                     , s+                                     ]              systemOrDie $ "cabal-dev install " ++ args             let cmd = ("." </> "dist" </> "build" </> projName </> projName)@@ -65,48 +85,59 @@             waitABit             return pHandle +        ----------------------------------------------------------------------         findSnap = do             home <- fromEnv "HOME" "."-            p1 <- gimmeIfExists $ snapRoot </> "dist" </> "build" </> "snap" </> "snap"-            p2 <- gimmeIfExists $ home </> ".cabal" </> "bin" </> "snap"-            p3 <- findExecutable "snap"+            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+    --------------------------------------------------------------------------+    putStrLn $ "Changing directory to " ++ projectPath     inDir True projectPath $ bracket initialize cleanup (const testAction)     removeDirectoryRecursiveSafe projectPath-  where +  where+    --------------------------------------------------------------------------     fromEnv name def = do         r <- getEnv name `catch` \(_::SomeException) -> return ""         if r == "" then return def else return r +    --------------------------------------------------------------------------     cleanup pHandle = do         terminateProcess pHandle         waitForProcess pHandle +    --------------------------------------------------------------------------     waitABit = threadDelay $ 2*10^(6::Int) +    --------------------------------------------------------------------------     pkgCleanUp d pkg = do         paths <- globDir1 (compile $ "packages*conf/" ++ pkg ++ "-*") d-        forM_ paths-              (\x -> (rm x `catch` \(_::SomeException) -> return ()))+        forM_ paths $ \x ->+            rm x `catch` \(_::SomeException) -> return ()+       where         rm x = do             putStrLn $ "removing " ++ x             removeFile x +    --------------------------------------------------------------------------     gimmeIfExists p = do         b <- doesFileExist p         if b then return (Just p) else return Nothing  +------------------------------------------------------------------------------ systemOrDie :: String -> IO () systemOrDie s = do     putStrLn $ "Running \"" ++ s ++ "\""     system s >>= check+   where     check ExitSuccess = return ()-    check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"+    check _           = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"
test/suite/TestSuite.hs view
@@ -1,54 +1,65 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}  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           Prelude hiding (catch) import           Snap.Http.Server.Config import           Snap.Snaplet+import           System.IO import           System.Posix.Process+import           System.Posix.Signals 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           Snap.Http.Server (simpleHttpServe) 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+import           SafeCWD   ------------------------------------------------------------------------------ main :: IO () main = do-    Blackbox.Tests.remove "non-cabal-appdir/templates/bad.tpl"-    Blackbox.Tests.remove "non-cabal-appdir/templates/good.tpl"+    Blackbox.Tests.remove+                "non-cabal-appdir/snaplets/heist/templates/bad.tpl"+    Blackbox.Tests.remove+                "non-cabal-appdir/snaplets/heist/templates/good.tpl"     Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet" -    inDir False "non-cabal-appdir" startServer-    threadDelay $ 2*10^(6::Int)-    defaultMain tests+    (tid, mvar) <- inDir False "non-cabal-appdir" startServer+    defaultMain [tests] `finally` killThread tid -  where tests = [ internalServerTests-                , testDefault-                , testBarebones-                , testTutorial-                ]+    putStrLn "waiting for termination mvar"+    takeMVar mvar +  where tests = mutuallyExclusive $+                testGroup "snap" [ internalServerTests+                                 , testDefault+                                 , testBarebones+                                 , testTutorial+                                 ] ++------------------------------------------------------------------------------ internalServerTests :: Test internalServerTests =+    mutuallyExclusive $     testGroup "internal server tests"         [ Blackbox.Tests.tests         , Snap.Snaplet.Internal.Lensed.Tests.tests@@ -57,17 +68,33 @@         , Snap.Snaplet.Internal.Tests.tests         ] -startServer :: IO ProcessID-startServer = forkProcess $ serve (setPort 9753 defaultConfig) app++------------------------------------------------------------------------------+startServer :: IO (ThreadId, MVar ())+startServer = do+    mvar <- newEmptyMVar+    t    <- forkIO $ serve mvar (setPort 9753 defaultConfig) app+    threadDelay $ 2*10^(6::Int)+    return (t, mvar)+   where-    serve config initializer = do-        (_, handler, doCleanup) <- runSnaplet initializer-        (conf, site)            <- combineConfig config handler-        _ <- try $ simpleHttpServe conf $ site-             :: IO (Either SomeException ())-        doCleanup+    serve mvar config initializer =+        flip finally (putMVar mvar ()) $+        handle handleErr $ do+            hPutStrLn stderr "initializing snaplet"+            (_, handler, doCleanup) <- runSnaplet initializer +            flip finally doCleanup $ do+                (conf, site) <- combineConfig config handler+                hPutStrLn stderr "bringing up server"+                simpleHttpServe conf site+                hPutStrLn stderr "server killed" +    handleErr :: SomeException -> IO ()+    handleErr e = hPutStrLn stderr $ "startServer exception: " ++ show e+++------------------------------------------------------------------------------ testBarebones :: Test testBarebones = testCase "snap/barebones" go   where@@ -76,12 +103,13 @@                               ""                               port                               testIt-    port = 9990+    port = 9990 :: Int     testIt = do         body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)         assertEqual "server not up" "hello world" body  +------------------------------------------------------------------------------ testDefault :: Test testDefault = testCase "snap/default" go   where@@ -90,7 +118,7 @@                               ""                               port                               testIt-    port = 9991+    port = 9991 :: Int     testIt = do         body <- liftM (S.concat . L.toChunks) $                 HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)@@ -98,6 +126,7 @@                    $ "It works!" `S.isInfixOf` body  +------------------------------------------------------------------------------ testTutorial :: Test testTutorial = testCase "snap/tutorial" go   where@@ -106,7 +135,7 @@                               ""                               port                               testIt-    port = 9992+    port = 9992 :: Int     testIt = do         body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)++"/hello"         assertEqual "server not up" "hello world" body