diff --git a/project_template/barebones/foo.cabal b/project_template/barebones/foo.cabal --- a/project_template/barebones/foo.cabal +++ b/project_template/barebones/foo.cabal @@ -19,8 +19,8 @@ bytestring >= 0.9.1 && < 0.10, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl >= 2 && < 3, - snap-core == 0.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 diff --git a/project_template/default/foo.cabal b/project_template/default/foo.cabal --- a/project_template/default/foo.cabal +++ b/project_template/default/foo.cabal @@ -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.* diff --git a/project_template/default/resources/static/screen.css b/project_template/default/resources/static/screen.css deleted file mode 100644 --- a/project_template/default/resources/static/screen.css +++ /dev/null @@ -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%; -} diff --git a/project_template/default/resources/templates/echo.tpl b/project_template/default/resources/templates/echo.tpl deleted file mode 100644 --- a/project_template/default/resources/templates/echo.tpl +++ /dev/null @@ -1,13 +0,0 @@ - - - Echo Page - - -
-

Is there an echo in here?

-
-

You wanted me to say this?

-

""

-

Return

- - diff --git a/project_template/default/resources/templates/index.tpl b/project_template/default/resources/templates/index.tpl deleted file mode 100644 --- a/project_template/default/resources/templates/index.tpl +++ /dev/null @@ -1,32 +0,0 @@ - - - Snap web server - - - -
-

It works!

-

- This is a simple demo page served using - Heist - and the Snap web framework. -

-

- Echo test: - cats - dogs - fish -

- - - - - - - - - -
Config generated at:
Page generated at:
-
- - diff --git a/project_template/default/snaplets/heist/templates/echo.tpl b/project_template/default/snaplets/heist/templates/echo.tpl new file mode 100644 --- /dev/null +++ b/project_template/default/snaplets/heist/templates/echo.tpl @@ -0,0 +1,13 @@ + + + Echo Page + + +
+

Is there an echo in here?

+
+

You wanted me to say this?

+

""

+

Return

+ + diff --git a/project_template/default/snaplets/heist/templates/index.tpl b/project_template/default/snaplets/heist/templates/index.tpl new file mode 100644 --- /dev/null +++ b/project_template/default/snaplets/heist/templates/index.tpl @@ -0,0 +1,32 @@ + + + Snap web server + + + +
+

It works!

+

+ This is a simple demo page served using + Heist + and the Snap web framework. +

+

+ Echo test: + cats + dogs + fish +

+ + + + + + + + + +
Config generated at:
Page generated at:
+
+ + diff --git a/project_template/default/src/Application.hs b/project_template/default/src/Application.hs --- a/project_template/default/src/Application.hs +++ b/project_template/default/src/Application.hs @@ -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 + diff --git a/project_template/default/src/Main.hs b/project_template/default/src/Main.hs --- a/project_template/default/src/Main.hs +++ b/project_template/default/src/Main.hs @@ -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. diff --git a/project_template/default/src/Site.hs b/project_template/default/src/Site.hs --- a/project_template/default/src/Site.hs +++ b/project_template/default/src/Site.hs @@ -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 diff --git a/project_template/default/static/screen.css b/project_template/default/static/screen.css new file mode 100644 --- /dev/null +++ b/project_template/default/static/screen.css @@ -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%; +} diff --git a/project_template/tutorial/foo.cabal b/project_template/tutorial/foo.cabal --- a/project_template/tutorial/foo.cabal +++ b/project_template/tutorial/foo.cabal @@ -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 diff --git a/snap.cabal b/snap.cabal --- a/snap.cabal +++ b/snap.cabal @@ -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 diff --git a/src/Control/Access/RoleBased/Checker.hs b/src/Control/Access/RoleBased/Checker.hs new file mode 100644 --- /dev/null +++ b/src/Control/Access/RoleBased/Checker.hs @@ -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" diff --git a/src/Control/Access/RoleBased/Internal/Role.hs b/src/Control/Access/RoleBased/Internal/Role.hs new file mode 100644 --- /dev/null +++ b/src/Control/Access/RoleBased/Internal/Role.hs @@ -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] + } diff --git a/src/Control/Access/RoleBased/Internal/RoleMap.hs b/src/Control/Access/RoleBased/Internal/RoleMap.hs new file mode 100644 --- /dev/null +++ b/src/Control/Access/RoleBased/Internal/RoleMap.hs @@ -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 diff --git a/src/Control/Access/RoleBased/Internal/Rule.hs b/src/Control/Access/RoleBased/Internal/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Control/Access/RoleBased/Internal/Rule.hs @@ -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 diff --git a/src/Control/Access/RoleBased/Internal/Types.hs b/src/Control/Access/RoleBased/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Access/RoleBased/Internal/Types.hs @@ -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) + diff --git a/src/Control/Access/RoleBased/Role.hs b/src/Control/Access/RoleBased/Role.hs new file mode 100644 --- /dev/null +++ b/src/Control/Access/RoleBased/Role.hs @@ -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 diff --git a/src/Control/Access/RoleBased/Types.hs b/src/Control/Access/RoleBased/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Access/RoleBased/Types.hs @@ -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 diff --git a/src/Data/RBAC/Checker.hs b/src/Data/RBAC/Checker.hs deleted file mode 100644 --- a/src/Data/RBAC/Checker.hs +++ /dev/null @@ -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" diff --git a/src/Data/RBAC/Internal/Role.hs b/src/Data/RBAC/Internal/Role.hs deleted file mode 100644 --- a/src/Data/RBAC/Internal/Role.hs +++ /dev/null @@ -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] - } diff --git a/src/Data/RBAC/Internal/RoleMap.hs b/src/Data/RBAC/Internal/RoleMap.hs deleted file mode 100644 --- a/src/Data/RBAC/Internal/RoleMap.hs +++ /dev/null @@ -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 diff --git a/src/Data/RBAC/Internal/Rule.hs b/src/Data/RBAC/Internal/Rule.hs deleted file mode 100644 --- a/src/Data/RBAC/Internal/Rule.hs +++ /dev/null @@ -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 diff --git a/src/Data/RBAC/Internal/Types.hs b/src/Data/RBAC/Internal/Types.hs deleted file mode 100644 --- a/src/Data/RBAC/Internal/Types.hs +++ /dev/null @@ -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) - diff --git a/src/Data/RBAC/Role.hs b/src/Data/RBAC/Role.hs deleted file mode 100644 --- a/src/Data/RBAC/Role.hs +++ /dev/null @@ -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 diff --git a/src/Data/RBAC/Types.hs b/src/Data/RBAC/Types.hs deleted file mode 100644 --- a/src/Data/RBAC/Types.hs +++ /dev/null @@ -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 diff --git a/src/Snap/Loader/Devel.hs b/src/Snap/Loader/Devel.hs --- a/src/Snap/Loader/Devel.hs +++ b/src/Snap/Loader/Devel.hs @@ -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 diff --git a/src/Snap/Loader/Devel/Evaluator.hs b/src/Snap/Loader/Devel/Evaluator.hs --- a/src/Snap/Loader/Devel/Evaluator.hs +++ b/src/Snap/Loader/Devel/Evaluator.hs @@ -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 [] diff --git a/src/Snap/Loader/Devel/Signal.hs b/src/Snap/Loader/Devel/Signal.hs --- a/src/Snap/Loader/Devel/Signal.hs +++ b/src/Snap/Loader/Devel/Signal.hs @@ -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 +------------------------------------------------------------------------------ diff --git a/src/Snap/Loader/Devel/TreeWatcher.hs b/src/Snap/Loader/Devel/TreeWatcher.hs --- a/src/Snap/Loader/Devel/TreeWatcher.hs +++ b/src/Snap/Loader/Devel/TreeWatcher.hs @@ -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 diff --git a/src/Snap/Loader/Prod.hs b/src/Snap/Loader/Prod.hs --- a/src/Snap/Loader/Prod.hs +++ b/src/Snap/Loader/Prod.hs @@ -1,8 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} + module Snap.Loader.Prod ( loadSnapTH ) where +------------------------------------------------------------------------------ import Language.Haskell.TH diff --git a/src/Snap/Snaplet.hs b/src/Snap/Snaplet.hs --- a/src/Snap/Snaplet.hs +++ b/src/Snap/Snaplet.hs @@ -100,6 +100,7 @@ -- * Handlers , Handler , reloadSite + , bracketHandler -- * Serving Applications , runSnaplet diff --git a/src/Snap/Snaplet/Auth.hs b/src/Snap/Snaplet/Auth.hs --- a/src/Snap/Snaplet/Auth.hs +++ b/src/Snap/Snaplet/Auth.hs @@ -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 diff --git a/src/Snap/Snaplet/Auth/AuthManager.hs b/src/Snap/Snaplet/Auth/AuthManager.hs --- a/src/Snap/Snaplet/Auth/AuthManager.hs +++ b/src/Snap/Snaplet/Auth/AuthManager.hs @@ -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 + } diff --git a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs --- a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs +++ b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs @@ -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 diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs --- a/src/Snap/Snaplet/Auth/Handlers.hs +++ b/src/Snap/Snaplet/Auth/Handlers.hs @@ -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_ diff --git a/src/Snap/Snaplet/Auth/SpliceHelpers.hs b/src/Snap/Snaplet/Auth/SpliceHelpers.hs --- a/src/Snap/Snaplet/Auth/SpliceHelpers.hs +++ b/src/Snap/Snaplet/Auth/SpliceHelpers.hs @@ -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. -- -- > Show this when there is a logged in user -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. -- -- > Show this when there is a logged in user -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 diff --git a/src/Snap/Snaplet/Auth/Types.hs b/src/Snap/Snaplet/Auth/Types.hs --- a/src/Snap/Snaplet/Auth/Types.hs +++ b/src/Snap/Snaplet/Auth/Types.hs @@ -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 diff --git a/src/Snap/Snaplet/Heist.hs b/src/Snap/Snaplet/Heist.hs --- a/src/Snap/Snaplet/Heist.hs +++ b/src/Snap/Snaplet/Heist.hs @@ -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 diff --git a/src/Snap/Snaplet/HeistNoClass.hs b/src/Snap/Snaplet/HeistNoClass.hs --- a/src/Snap/Snaplet/HeistNoClass.hs +++ b/src/Snap/Snaplet/HeistNoClass.hs @@ -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)] diff --git a/src/Snap/Snaplet/Internal/Initializer.hs b/src/Snap/Snaplet/Internal/Initializer.hs --- a/src/Snap/Snaplet/Internal/Initializer.hs +++ b/src/Snap/Snaplet/Internal/Initializer.hs @@ -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 diff --git a/src/Snap/Snaplet/Internal/Types.hs b/src/Snap/Snaplet/Internal/Types.hs --- a/src/Snap/Snaplet/Internal/Types.hs +++ b/src/Snap/Snaplet/Internal/Types.hs @@ -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 () diff --git a/src/Snap/Snaplet/Session.hs b/src/Snap/Snaplet/Session.hs --- a/src/Snap/Snaplet/Session.hs +++ b/src/Snap/Snaplet/Session.hs @@ -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' diff --git a/src/Snap/Snaplet/Session/Backends/CookieSession.hs b/src/Snap/Snaplet/Session/Backends/CookieSession.hs --- a/src/Snap/Snaplet/Session/Backends/CookieSession.hs +++ b/src/Snap/Snaplet/Session/Backends/CookieSession.hs @@ -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 diff --git a/src/Snap/Snaplet/Session/Common.hs b/src/Snap/Snaplet/Session/Common.hs --- a/src/Snap/Snaplet/Session/Common.hs +++ b/src/Snap/Snaplet/Session/Common.hs @@ -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 diff --git a/src/Snap/Snaplet/Session/SecureCookie.hs b/src/Snap/Snaplet/Session/SecureCookie.hs --- a/src/Snap/Snaplet/Session/SecureCookie.hs +++ b/src/Snap/Snaplet/Session/SecureCookie.hs @@ -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 diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs --- a/src/Snap/Starter.hs +++ b/src/Snap/Starter.hs @@ -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 diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs --- a/src/Snap/StarterTH.hs +++ b/src/Snap/StarterTH.hs @@ -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] diff --git a/test/foosnaplet/snaplet.cfg b/test/foosnaplet/snaplet.cfg new file mode 100644 --- /dev/null +++ b/test/foosnaplet/snaplet.cfg @@ -0,0 +1,2 @@ +fooSnapletField = "fooValue" + diff --git a/test/foosnaplet/templates/foopage.tpl b/test/foosnaplet/templates/foopage.tpl new file mode 100644 --- /dev/null +++ b/test/foosnaplet/templates/foopage.tpl @@ -0,0 +1,1 @@ +foo template page diff --git a/test/non-cabal-appdir/bad.tpl b/test/non-cabal-appdir/bad.tpl new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/bad.tpl @@ -0,0 +1,1 @@ + diff --git a/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl b/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/snaplets/baz/templates/bazpage.tpl @@ -0,0 +1,1 @@ +baz template page diff --git a/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl b/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/snaplets/embedded/extra-templates/extra.tpl @@ -0,0 +1,1 @@ +This is an extra template diff --git a/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl b/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/snaplets/embedded/snaplets/heist/templates/embeddedpage.tpl @@ -0,0 +1,1 @@ +embedded snaplet page diff --git a/test/non-cabal-appdir/snaplets/heist/templates/index.tpl b/test/non-cabal-appdir/snaplets/heist/templates/index.tpl new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/snaplets/heist/templates/index.tpl @@ -0,0 +1,1 @@ +index page diff --git a/test/non-cabal-appdir/snaplets/heist/templates/page.tpl b/test/non-cabal-appdir/snaplets/heist/templates/page.tpl new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/snaplets/heist/templates/page.tpl @@ -0,0 +1,8 @@ + + +Example App + + + + + diff --git a/test/non-cabal-appdir/snaplets/heist/templates/session.tpl b/test/non-cabal-appdir/snaplets/heist/templates/session.tpl new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/snaplets/heist/templates/session.tpl @@ -0,0 +1,1 @@ + diff --git a/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl b/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl new file mode 100644 --- /dev/null +++ b/test/non-cabal-appdir/snaplets/heist/templates/splicepage.tpl @@ -0,0 +1,1 @@ +splice page diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh --- a/test/runTestsAndCoverage.sh +++ b/test/runTestsAndCoverage.sh @@ -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 diff --git a/test/snap-testsuite.cabal b/test/snap-testsuite.cabal --- a/test/snap-testsuite.cabal +++ b/test/snap-testsuite.cabal @@ -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, diff --git a/test/suite/AppMain.hs b/test/suite/AppMain.hs new file mode 100644 --- /dev/null +++ b/test/suite/AppMain.hs @@ -0,0 +1,9 @@ +module Main where + +import Snap.Http.Server.Config +import Snap.Snaplet + +import Blackbox.App + +main :: IO () +main = serveSnaplet defaultConfig app diff --git a/test/suite/Blackbox/App.hs b/test/suite/Blackbox/App.hs new file mode 100644 --- /dev/null +++ b/test/suite/Blackbox/App.hs @@ -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 + + + diff --git a/test/suite/Blackbox/BarSnaplet.hs b/test/suite/Blackbox/BarSnaplet.hs new file mode 100644 --- /dev/null +++ b/test/suite/Blackbox/BarSnaplet.hs @@ -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 + diff --git a/test/suite/Blackbox/Common.hs b/test/suite/Blackbox/Common.hs new file mode 100644 --- /dev/null +++ b/test/suite/Blackbox/Common.hs @@ -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 + diff --git a/test/suite/Blackbox/EmbeddedSnaplet.hs b/test/suite/Blackbox/EmbeddedSnaplet.hs new file mode 100644 --- /dev/null +++ b/test/suite/Blackbox/EmbeddedSnaplet.hs @@ -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) + diff --git a/test/suite/Blackbox/FooSnaplet.hs b/test/suite/Blackbox/FooSnaplet.hs new file mode 100644 --- /dev/null +++ b/test/suite/Blackbox/FooSnaplet.hs @@ -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 + diff --git a/test/suite/Blackbox/Tests.hs b/test/suite/Blackbox/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Blackbox/Tests.hs @@ -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 \n" + , requestTest "bazpage2" "baz template page contents of the bar splice\n" + , requestTest "bazpage3" "baz template page \n" + , requestTest "bazpage4" "baz template page \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 \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" + diff --git a/test/suite/Blackbox/Types.hs b/test/suite/Blackbox/Types.hs new file mode 100644 --- /dev/null +++ b/test/suite/Blackbox/Types.hs @@ -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 + diff --git a/test/suite/NestTest.hs b/test/suite/NestTest.hs new file mode 100644 --- /dev/null +++ b/test/suite/NestTest.hs @@ -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 + diff --git a/test/suite/SafeCWD.hs b/test/suite/SafeCWD.hs new file mode 100644 --- /dev/null +++ b/test/suite/SafeCWD.hs @@ -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) diff --git a/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs b/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Internal/LensT/Tests.hs @@ -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 + + diff --git a/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Internal/Lensed/Tests.hs @@ -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 diff --git a/test/suite/Snap/Snaplet/Internal/RST/Tests.hs b/test/suite/Snap/Snaplet/Internal/RST/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Internal/RST/Tests.hs @@ -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) + diff --git a/test/suite/Snap/Snaplet/Internal/Tests.hs b/test/suite/Snap/Snaplet/Internal/Tests.hs new file mode 100644 --- /dev/null +++ b/test/suite/Snap/Snaplet/Internal/Tests.hs @@ -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 + ] + diff --git a/test/suite/Snap/TestCommon.hs b/test/suite/Snap/TestCommon.hs --- a/test/suite/Snap/TestCommon.hs +++ b/test/suite/Snap/TestCommon.hs @@ -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 ++ "'" diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -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