diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,8 +1,6 @@ Ozgun Ataman Doug Beardsley Gregory Collins -Shu-yu Guo Carl Howells -Shane O'Brien -James Sanders -Jacob Stanley +Chris Smith +Jurriën Stutterheim diff --git a/README.SNAP.md b/README.SNAP.md --- a/README.SNAP.md +++ b/README.SNAP.md @@ -16,11 +16,11 @@ * a sensible and clean monad for web programming - * an xml-based templating system for generating HTML based on - [expat](http://expat.sourceforge.net/) (via - [hexpat](http://hackage.haskell.org/package/hexpat)) that allows you to - bind Haskell functionality to XML tags without getting PHP-style tag soup - all over your pants + * an xml-based templating system for generating HTML that allows you to bind + Haskell functionality to XML tags without getting PHP-style tag soup all + over your pants + + * a "snaplet" system for building web sites from composable pieces. Snap is currently only officially supported on Unix platforms; it has been tested on Linux and Mac OSX Snow Leopard, and is reported to work on Windows. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,18 +1,14 @@ Snap Framework ============== -This is the first developer prerelease of the Snap Framework snap -tool. For more information about Snap, read the `README.SNAP.md` or -visit the Snap project website at http://www.snapframework.com/. - -Snap is a nascent web framework for Haskell, based on iteratee I/O (as -[popularized by Oleg -Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). - +Snap is a web framework for Haskell, based on iteratee I/O (as [popularized by +Oleg Kiselyov](http://okmij.org/ftp/Streams.html#iteratee)). For more +information about Snap, read the `README.SNAP.md` or visit the Snap project +website at http://www.snapframework.com/. ## Library contents -This is the `snap` executable and supporting library, which contains: +This is top-level project for the Snap Framework, which contains: * a command-line utility for creating initial Snap applications @@ -20,12 +16,14 @@ fly in development mode, with no performance loss in production mode. + * a "snaplet" API allowing web applications to be build from composable + pieces. Building snap ============= The snap tool and library are built using - [Cabal](http://www.haskell.org/cabal/) and +[Cabal](http://www.haskell.org/cabal/) and [Hackage](http://hackage.haskell.org/packages/hackage.html). Just run cabal install @@ -35,20 +33,13 @@ ## Building the Haddock Documentation -The haddock documentation can be built using the supplied `haddock.sh` shell -script: - - ./haddock.sh +The haddock documentation can be built using 'cabal haddock'. The docs get put in `dist/doc/html/`. ## Building the testsuite -Snap is still in its very early stages, so most of the "action" (and a big -chunk of the code) right now is centred on the test suite. Snap aims for 100% -test coverage, and we're trying hard to stick to that. - To build the test suite, `cd` into the `test/` directory and run $ cabal configure @@ -60,3 +51,12 @@ The testsuite generates an `hpc` test coverage report in `test/dist/hpc`. + + +## Roadmap to Understanding Snaplets + +1. Read Tutorial.lhs which is in `project_template/tutorial/src`. +2. Generate and read the haddock docs. +3. The test code has the nice property that it actually functions as a pretty good example app and covers a lot of the use cases. +4. If you're interested in the implementation, read design.md. + 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.5.*, - snap-server == 0.5.* + snap-core == 0.6.*, + snap-server == 0.6.* if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 diff --git a/project_template/barebones/src/Main.hs b/project_template/barebones/src/Main.hs --- a/project_template/barebones/src/Main.hs +++ b/project_template/barebones/src/Main.hs @@ -2,7 +2,7 @@ module Main where import Control.Applicative -import Snap.Types +import Snap.Core import Snap.Util.FileServe import Snap.Http.Server 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 @@ -21,21 +21,20 @@ Build-depends: base >= 4 && < 5, bytestring >= 0.9.1 && < 0.10, - heist >= 0.5 && < 0.6, + data-lens >= 2.0.1 && < 2.1, + data-lens-template >= 2.1 && < 2.2, + heist >= 0.6 && < 0.7, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl >= 2 && < 3, - snap == 0.5.*, - snap-core == 0.5.*, - snap-server == 0.5.*, + snap == 0.6.*, + snap-core == 0.6.*, + snap-server == 0.6.*, text >= 0.11 && < 0.12, time >= 1.1 && < 1.4, xmlhtml == 0.1.* - extensions: TypeSynonymInstances MultiParamTypeClasses - if flag(development) cpp-options: -DDEVELOPMENT - build-depends: hint >= 0.3.2 && < 0.4 -- In development mode, speed is already going to suffer, so skip -- the fancy optimization flags. Additionally, disable all -- warnings. The hint library doesn't give an option to execute diff --git a/project_template/default/resources/templates/index.tpl b/project_template/default/resources/templates/index.tpl --- a/project_template/default/resources/templates/index.tpl +++ b/project_template/default/resources/templates/index.tpl @@ -1,7 +1,7 @@ Snap web server - +
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,58 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + {- -This module defines our application's monad and any application-specific -information it requires. +This module defines our application's state type and an alias for its handler +monad. -} -module Application - ( Application - , applicationInitializer - ) where - -import Snap.Extension -import Snap.Extension.Heist.Impl -import Snap.Extension.Timer.Impl - +module Application where ------------------------------------------------------------------------------- --- | 'Application' is our application's monad. It uses 'SnapExtend' from --- 'Snap.Extension' to provide us with an extended 'MonadSnap' making use of --- the Heist and Timer Snap extensions. -type Application = SnapExtend ApplicationState +import Data.Lens.Template +import Data.Time.Clock +import Snap.Snaplet +import Snap.Snaplet.Heist ------------------------------------------------------------------------------- --- | 'ApplicationState' is a record which contains the state needed by the Snap --- extensions we're using. We're using Heist so we can easily render Heist --- templates, and Timer simply to illustrate the config loading differences --- between development and production modes. -data ApplicationState = ApplicationState - { templateState :: HeistState Application - , timerState :: TimerState +data App = App + { _heist :: Snaplet (Heist App) + , _startTime :: UTCTime } - ------------------------------------------------------------------------------- -instance HasHeistState Application ApplicationState where - getHeistState = templateState - setHeistState s a = a { templateState = s } - +type AppHandler = Handler App App ------------------------------------------------------------------------------- -instance HasTimerState ApplicationState where - getTimerState = timerState - setTimerState s a = a { timerState = s } +makeLens ''App +instance HasHeist App where + heistLens = subSnaplet heist ------------------------------------------------------------------------------- --- | The 'Initializer' for ApplicationState. For more on 'Initializer's, see --- the documentation from the snap package. Briefly, this is used to --- generate the 'ApplicationState' needed for our application and will --- automatically generate reload\/cleanup actions for us which we don't need --- to worry about. -applicationInitializer :: Initializer ApplicationState -applicationInitializer = do - heist <- heistInitializer "resources/templates" id - timer <- timerInitializer - return $ ApplicationState heist timer 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,6 +1,27 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Exception (SomeException, try) + +import qualified Data.Text as T + +import Snap.Http.Server +import Snap.Snaplet +import Snap.Core + +import System.IO + +import Site + +#ifdef DEVELOPMENT +import Snap.Loader.Devel +#else +import Snap.Loader.Prod +#endif + + {-| This is the entry point for this web server application. It supports @@ -38,31 +59,51 @@ change. -} +main :: IO () +main = do + -- depending on the version of loadSnapTH in scope, this either + -- enables dynamic reloading, or compiles it without. The last + -- argument to loadSnapTH is a list of additional directories to + -- watch for changes to trigger reloads in development mode. It + -- doesn't need to include source directories, those are picked up + -- automatically by the splice. + (conf, site, cleanup) <- $(loadSnapTH [| getConf |] + 'getActions + ["resources/templates"]) -module Main where + _ <- try $ httpServe conf $ site :: IO (Either SomeException ()) + cleanup -#ifdef DEVELOPMENT -import Control.Exception (SomeException, try) -import Snap.Extension.Loader.Devel -import Snap.Http.Server (quickHttpServe) -#else -import Snap.Extension.Server -#endif +-- | This action loads the config used by this application. The +-- loaded config is returned as the first element of the tuple +-- produced by the loadSnapTH Splice. The type is not solidly fixed, +-- though it must be an IO action that produces the same type as +-- 'getActions' takes. It also must be an instance of Typeable. If +-- the type of this is changed, a full recompile will be needed to +-- pick up the change, even in development mode. +-- +-- This action is only run once, regardless of whether development or +-- production mode is in use. +getConf :: IO (Config Snap ()) +getConf = commandLineConfig defaultConfig -import Application -import Site -main :: IO () -#ifdef DEVELOPMENT -main = do - -- All source directories will be watched for updates - -- automatically. If any extra directories should be watched for - -- updates, include them here. - (snap, cleanup) <- $(let watchDirs = ["resources/templates"] - in loadSnapTH 'applicationInitializer 'site watchDirs) - try $ quickHttpServe snap :: IO (Either SomeException ()) - cleanup -#else -main = quickHttpServe applicationInitializer site -#endif +-- | This function generates the the site handler and cleanup action +-- from the configuration. In production mode, this action is only +-- run once. In development mode, this action is run whenever the +-- application is reloaded. +-- +-- Development mode also makes sure that the cleanup actions are run +-- appropriately before shutdown. The cleanup action returned from +-- loadSnapTH should still be used after the server has stopped +-- handling requests, as the cleanup actions are only automatically +-- run when a reload is triggered. +-- +-- This sample doesn't actually use the config passed in, but more +-- sophisticated code might. +getActions :: Config Snap () -> IO (Snap (), IO ()) +getActions _ = do + (msgs, site, cleanup) <- runSnaplet app + hPutStrLn stderr $ T.unpack msgs + return (site, cleanup) 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 @@ -3,22 +3,29 @@ {-| This is where all the routes and handlers are defined for your site. The -'site' function combines everything together and is exported by this module. +'app' function is the initializer that combines everything together and +is exported by this module. -} module Site - ( site + ( app ) where import Control.Applicative +import Control.Monad.Trans +import Control.Monad.State +import Data.ByteString (ByteString) import Data.Maybe +import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Snap.Extension.Heist -import Snap.Extension.Timer +import Data.Time.Clock +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Heist import Snap.Util.FileServe -import Snap.Types import Text.Templating.Heist +import Text.XmlHtml hiding (render) import Application @@ -29,7 +36,7 @@ -- The 'ifTop' is required to limit this to the top of a route. -- Otherwise, the way the route table is currently set up, this action -- would be given every request. -index :: Application () +index :: Handler App App () index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index" where indexSplices = @@ -39,8 +46,24 @@ ------------------------------------------------------------------------------ +-- | For your convenience, a splice which shows the start time. +startTimeSplice :: Splice AppHandler +startTimeSplice = do + time <- lift $ gets _startTime + return $ [TextNode $ T.pack $ show $ time] + + +------------------------------------------------------------------------------ +-- | For your convenience, a splice which shows the current time. +currentTimeSplice :: Splice AppHandler +currentTimeSplice = do + time <- liftIO getCurrentTime + return $ [TextNode $ T.pack $ show $ time] + + +------------------------------------------------------------------------------ -- | Renders the echo page. -echo :: Application () +echo :: Handler App App () echo = do message <- decodedParam "stuff" heistLocal (bindString "message" (T.decodeUtf8 message)) $ render "echo" @@ -49,9 +72,21 @@ ------------------------------------------------------------------------------ --- | The main entry point handler. -site :: Application () -site = route [ ("/", index) - , ("/echo/:stuff", echo) - ] - <|> serveDirectory "resources/static" +-- | The application's routes. +routes :: [(ByteString, Handler App App ())] +routes = [ ("/", index) + , ("/echo/:stuff", echo) + , ("", with heist heistServe) + , ("", serveDirectory "resources/static") + ] + +------------------------------------------------------------------------------ +-- | The application initializer. +app :: SnapletInit App App +app = makeSnaplet "app" "An snaplet example application." Nothing $ do + sTime <- liftIO getCurrentTime + h <- nestSnaplet "heist" heist $ heistInit "resources/templates" + addRoutes routes + return $ App h sTime + + diff --git a/project_template/default/src/Snap/Extension/Timer.hs b/project_template/default/src/Snap/Extension/Timer.hs deleted file mode 100644 --- a/project_template/default/src/Snap/Extension/Timer.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-| - -'Snap.Extension.Timer' exports the 'MonadTimer' interface which allows you to -keep track of the time at which your application was started. The interface's -only operation is 'startTime'. - -Two splices, 'startTimeSplice' and 'currentTimeSplice' are also provided, for -your convenience. - -'Snap.Extension.Timer.Timer' contains the only implementation of this -interface and can be used to turn your application's monad into a -'MonadTimer'. - -More than anything else, this is intended to serve as an example Snap -Extension to any developer wishing to write their own Snap Extension. - --} - -module Snap.Extension.Timer - ( MonadTimer(..) - , startTimeSplice - , currentTimeSplice - ) where - -import Control.Monad.Trans -import Data.Time.Clock -import qualified Data.Text as T -import Snap.Types -import Text.Templating.Heist -import Text.XmlHtml - - ------------------------------------------------------------------------------- --- | The 'MonadTimer' type class. Minimal complete definition: 'startTime'. -class MonadSnap m => MonadTimer m where - -- | The time at which your application was last loaded. - startTime :: m UTCTime - - ------------------------------------------------------------------------------- --- | For your convenience, a splice which shows the start time. -startTimeSplice :: MonadTimer m => Splice m -startTimeSplice = do - time <- lift startTime - return $ [TextNode $ T.pack $ show $ time] - - ------------------------------------------------------------------------------- --- | For your convenience, a splice which shows the current time. -currentTimeSplice :: MonadTimer m => Splice m -currentTimeSplice = do - time <- lift $ liftIO getCurrentTime - return $ [TextNode $ T.pack $ show $ time] diff --git a/project_template/default/src/Snap/Extension/Timer/Impl.hs b/project_template/default/src/Snap/Extension/Timer/Impl.hs deleted file mode 100644 --- a/project_template/default/src/Snap/Extension/Timer/Impl.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-| - -'Snap.Extension.Timer.Impl' is an implementation of the 'MonadTimer' -interface defined in 'Snap.Extension.Timer'. - -As always, to use, add 'TimerState' to your application's state, along with an -instance of 'HasTimerState' for your application's state, making sure to use a -'timerInitializer' in your application's 'Initializer', and then you're ready to go. - -This implementation does not require that your application's monad implement -interfaces from any other Snap Extension. - --} - -module Snap.Extension.Timer.Impl - ( TimerState - , HasTimerState(..) - , timerInitializer - , module Snap.Extension.Timer - ) where - -import Control.Monad.Reader -import Data.Time.Clock -import Snap.Extension -import Snap.Extension.Timer -import Snap.Types - ------------------------------------------------------------------------------- --- | Your application's state must include a 'TimerState' in order for your --- application to be a 'MonadTimer'. -newtype TimerState = TimerState - { _startTime :: UTCTime - } - - ------------------------------------------------------------------------------- --- | For your application's monad to be a 'MonadTimer', your application's --- state needs to be an instance of 'HasTimerState'. Minimal complete --- definition: 'getTimerState', 'setTimerState'. -class HasTimerState s where - getTimerState :: s -> TimerState - setTimerState :: TimerState -> s -> s - - ------------------------------------------------------------------------------- --- | The Initializer for 'TimerState'. No arguments are required. -timerInitializer :: Initializer TimerState -timerInitializer = liftIO getCurrentTime >>= mkInitializer . TimerState - - ------------------------------------------------------------------------------- -instance InitializerState TimerState where - extensionId = const "Timer/Timer" - mkCleanup = const $ return () - mkReload = const $ return () - - ------------------------------------------------------------------------------- -instance HasTimerState s => MonadTimer (SnapExtend s) where - startTime = fmap _startTime $ asks getTimerState - - ------------------------------------------------------------------------------- -instance (MonadSnap m, HasTimerState s) => MonadTimer (ReaderT s m) where - startTime = fmap _startTime $ asks getTimerState diff --git a/snap.cabal b/snap.cabal --- a/snap.cabal +++ b/snap.cabal @@ -1,13 +1,13 @@ name: snap -version: 0.5.5.1 +version: 0.6.0 synopsis: Snap: A Haskell Web Framework: project starter executable and glue code library description: Snap Framework project starter executable and glue code library license: BSD3 license-file: LICENSE -author: James Sanders, Shu-yu Guo, Gregory Collins, Doug Beardsley +author: Ozgun Ataman, Doug Beardsley, Gregory Collins, Carl Howells, Chris Smith maintainer: snap@snapframework.com build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.8 homepage: http://snapframework.com/ category: Web @@ -27,58 +27,106 @@ project_template/default/src/Application.hs, project_template/default/src/Main.hs, project_template/default/src/Site.hs, - project_template/default/src/Snap/Extension/Timer/Impl.hs, - project_template/default/src/Snap/Extension/Timer.hs, extra/hscolour.css, extra/haddock.css, extra/logo.gif, test/snap-testsuite.cabal, - test/runTests.sh, + test/runTestsAndCoverage.sh, test/suite/Snap/TestCommon.hs, test/suite/TestSuite.hs Flag hint Description: Support dynamic project reloading via hint - Default: True + Default: False Library hs-source-dirs: src - exposed-modules: - Snap.Extension.Heist, - Snap.Extension.Heist.Impl, - Snap.Extension.Server, - Snap.Extension - if flag(hint) exposed-modules: - Snap.Extension.Loader.Devel + Snap.Loader.Devel - other-modules: - Snap.Extension.Loader.Devel.Evaluator, - Snap.Extension.Loader.Devel.Signal, - Snap.Extension.Loader.Devel.TreeWatcher + exposed-modules: + Snap, + Snap.Loader.Prod + Snap.Snaplet, + Snap.Snaplet.Heist, + Snap.Snaplet.Auth, + Snap.Snaplet.Auth.Backends.JsonFile, + Snap.Snaplet.Session, + Snap.Snaplet.Session.Backends.CookieSession + other-modules: + Data.RBAC.Checker, + Data.RBAC.Role, + Data.RBAC.Types, + Data.RBAC.Internal.Role, + Data.RBAC.Internal.RoleMap, + Data.RBAC.Internal.Rule, + Data.RBAC.Internal.Types, + Snap.Loader.Devel.Evaluator, + Snap.Loader.Devel.Signal, + Snap.Loader.Devel.TreeWatcher, + Snap.Snaplet.Auth.AuthManager, + Snap.Snaplet.Auth.Types, + Snap.Snaplet.Auth.Handlers, + Snap.Snaplet.Auth.SpliceHelpers, + Snap.Snaplet.HeistNoClass, + Snap.Snaplet.Internal.Initializer, + Snap.Snaplet.Internal.LensT, + Snap.Snaplet.Internal.Lensed, + Snap.Snaplet.Internal.RST, + Snap.Snaplet.Internal.Types + Snap.Snaplet.Session.Common, + Snap.Snaplet.Session.SecureCookie, + Snap.Snaplet.Session.SessionManager + build-depends: - base >= 4 && < 5, - blaze-builder >= 0.2.1.4 && <0.4, - bytestring >= 0.9.1 && < 0.10, - directory >= 1.0 && < 1.2, - directory-tree >= 0.10 && < 0.11, - enumerator >= 0.4.13.1 && <0.5, - filepath >= 1.1 && <1.3, - MonadCatchIO-transformers >= 0.2.1 && < 0.3, - snap-core >= 0.5.4 && <0.6, - heist >= 0.5 && < 0.6, - template-haskell >= 2.3 && < 2.7, - time >= 1.0 && < 1.4 + Crypto >= 4.2 && < 4.3, + MonadCatchIO-transformers >= 0.2 && < 0.3, + aeson >= 0.3.2 && < 0.4, + attoparsec (>= 0.8.0.2 && < 0.9) || + (>= 0.9.1.1 && < 0.10), + base >= 4 && < 5, + bytestring >= 0.9.1 && < 0.10, + cereal >= 0.3 && < 0.4, + clientsession >= 0.7.2 && < 0.8, + configurator >= 0.1 && < 0.2, + containers >= 0.3 && < 0.5, + directory >= 1.0 && < 1.2, + directory-tree >= 0.10 && < 0.11, + data-lens >= 2.0.1 && < 2.1, + data-lens-template >= 2.1 && < 2.2, + filepath >= 1.1 && < 1.3, + hashable >= 1.1 && < 1.2, + heist >= 0.6 && < 0.7, + logict >= 0.4.2 && < 0.6, + mtl > 2.0 && < 2.1, + mwc-random >= 0.8 && < 0.11, + old-time >= 1.0 && < 1.1, + pwstore-fast >= 2.2 && < 2.3, + safe >= 0.3 && < 0.4, + snap-core >= 0.6 && < 0.7, + snap-server >= 0.6 && < 0.7, + stm >= 2.2 && < 2.3, + syb >= 0.1 && < 0.4, + template-haskell >= 2.2 && < 2.7, + text >= 0.11 && < 0.12, + time >= 1.1 && < 1.5, + transformers >= 0.2 && < 0.3, + unordered-containers >= 0.1.4 && < 0.2, + utf8-string >= 0.3 && < 0.4, + vector >= 0.7.1 && < 0.10, + vector-algorithms >= 0.4 && < 0.6, + xmlhtml >= 0.1 && < 0.2 if flag(hint) build-depends: hint >= 0.3.3.1 && < 0.4 if !os(windows) - build-depends: unix >= 2.2.0.0 && < 2.6 + build-depends: + unix >= 2.2.0.0 && < 2.6 if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 @@ -94,27 +142,16 @@ other-modules: Snap.StarterTH build-depends: - attoparsec >= 0.8.0.2 && < 0.10, - base >= 4 && < 5, - bytestring, - bytestring-nums, - cereal >= 0.3 && < 0.4, - containers, - directory >= 1.0 && < 1.2, - directory-tree, - dlist >= 0.5 && < 0.6, - enumerator >= 0.4.13.1 && <0.5, - filepath >= 1.1 && <1.3, - mtl >= 2, - old-locale, - old-time, - snap-core >= 0.5.4 && <0.6, - snap-server >= 0.5.4 && <0.6, - template-haskell >= 2.3 && < 2.7, - text >= 0.11 && <0.12, - time >= 1.0 && < 1.4, - unix-compat, - zlib + base >= 4 && < 5, + bytestring >= 0.9.1 && < 0.10, + containers >= 0.3 && < 0.5, + directory >= 1.0 && < 1.2, + directory-tree >= 0.10 && < 0.11, + filepath >= 1.1 && < 1.3, + old-time >= 1.0 && < 1.1, + snap-server >= 0.6 && < 0.7, + template-haskell >= 2.2 && < 2.7, + text >= 0.11 && < 0.12 ghc-prof-options: -prof -auto-all diff --git a/src/Data/RBAC/Checker.hs b/src/Data/RBAC/Checker.hs new file mode 100644 --- /dev/null +++ b/src/Data/RBAC/Checker.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.RBAC.Checker where + +import Control.Monad +import Control.Monad.Logic +import Control.Monad.Reader +import Control.Monad.State.Lazy +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) + +import Data.RBAC.Internal.RoleMap (RoleMap) +import qualified Data.RBAC.Internal.RoleMap as RM +import Data.RBAC.Internal.Types +import Data.RBAC.Role + + +------------------------------------------------------------------------------ +type RoleBuilder a = StateT RoleMap RoleMonad a + + +------------------------------------------------------------------------------ +applyRule :: Role -> Rule -> [Role] +applyRule r (Rule _ f) = f r + + +------------------------------------------------------------------------------ +applyRuleSet :: Role -> RuleSet -> [Role] +applyRuleSet r (RuleSet m) = f r + where + f = fromMaybe (const []) $ M.lookup (_roleName r) m + + +------------------------------------------------------------------------------ +checkUnseen :: Role -> RoleBuilder () +checkUnseen role = do + m <- get + if isJust $ RM.lookup role m then mzero else return () + + +------------------------------------------------------------------------------ +checkSeen :: Role -> RoleBuilder () +checkSeen = lnot . checkUnseen + + +------------------------------------------------------------------------------ +markSeen :: Role -> RoleBuilder () +markSeen role = modify $ RM.insert role + + +------------------------------------------------------------------------------ +isum :: (MonadLogic m, MonadPlus m) => [m a] -> m a +isum l = case l of + [] -> mzero + (x:xs) -> x `interleave` isum xs + + +------------------------------------------------------------------------------ +-- | Given a set of roles to check, and a set of implication rules describing +-- how a given role inherits from other roles, this function produces a stream +-- of expanded Roles. If a Role is seen twice, expandRoles mzeros. +expandRoles :: [Rule] -> [Role] -> RoleMonad Role +expandRoles rules roles0 = evalStateT (go roles0) RM.empty + where + ruleSet = rulesToSet rules + + go roles = isum $ map expandOne roles + + expandOne role = do + checkUnseen role + markSeen role + return role `interleave` go newRoles + + where + newRoles = applyRuleSet role ruleSet + + +------------------------------------------------------------------------------ +hasRole :: Role -> RuleChecker () +hasRole r = RuleChecker $ do + ch <- ask + once $ go ch + where + go gen = do + r' <- lift gen + if r `matches` r' then return () else mzero + + +------------------------------------------------------------------------------ +missingRole :: Role -> RuleChecker () +missingRole = lnot . hasRole + + +------------------------------------------------------------------------------ +hasAllRoles :: [Role] -> RuleChecker () +hasAllRoles rs = RuleChecker $ do + ch <- ask + lift $ once $ go ch $ RM.fromList rs + where + go gen !st = do + mr <- msplit gen + maybe mzero + (\(r,gen') -> let st' = RM.delete r st + in if RM.null st' + then return () + else go gen' st') + mr + + +------------------------------------------------------------------------------ +hasAnyRoles :: [Role] -> RuleChecker () +hasAnyRoles rs = RuleChecker $ do + ch <- ask + lift $ once $ go ch + where + st = RM.fromList rs + go gen = do + mr <- msplit gen + maybe mzero + (\(r,gen') -> if isJust $ RM.lookup r st + then return () + else go gen') + mr + + +------------------------------------------------------------------------------ +runRuleChecker :: [Rule] + -> [Role] + -> RuleChecker a + -> Bool +runRuleChecker rules roles (RuleChecker f) = + case outs of + [] -> False + _ -> True + where + (RoleMonad st) = runReaderT f $ expandRoles rules roles + outs = observeMany 1 st + + +------------------------------------------------------------------------------ +mkRule :: Text -> (Role -> [Role]) -> Rule +mkRule = Rule + + +------------------------------------------------------------------------------ +implies :: Role -> [Role] -> Rule +implies src dest = Rule (_roleName src) + (\role -> if role `matches` src then dest else []) + + +------------------------------------------------------------------------------ +impliesWith :: Role -> (HashMap Text RoleValue -> [Role]) -> Rule +impliesWith src f = Rule (_roleName src) + (\role -> if src `matches` role + then f $ _roleData role + else []) + + +------------------------------------------------------------------------------ +-- Testing code follows: TODO: move into test suite + + +testRules :: [Rule] +testRules = [ "user" `implies` ["guest", "can_post"] + , "superuser" `implies` [ "user" + , "can_moderate" + , "can_administrate"] + , "superuser" `implies` [ addRoleData "arg" "*" "with_arg" ] + , "with_arg" `impliesWith` \dat -> + maybe [] (\arg -> [addRoleData "arg" arg "dependent_arg"]) $ + M.lookup "arg" dat + , "superuser" `implies` [ addRoleData "arg1" "a" $ + addRoleData "arg2" "b" "multi_args" ] + ] + +tX :: RuleChecker () -> Bool +tX f = runRuleChecker testRules ["superuser"] f + +t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15,t16,t17 :: Bool +t1 = tX $ hasAnyRoles ["guest","userz"] + +t2 = tX $ hasAllRoles ["guest","userz"] + +t3 = tX $ hasAllRoles ["guest","user"] + +t4 = tX $ hasRole "can_administrate" + +t5 = tX $ hasRole "lkfdhjkjfhds" + +t6 = tX $ do + hasRole "guest" + hasRole "superuser" + +t7 = tX $ do + hasRole "zzzzz" + hasRole "superuser" + +t8 = tX $ hasRole $ addRoleData "arg" "*" "dependent_arg" + +t9 = tX $ hasRole "multi_args" + +t10 = tX $ hasRole $ addRoleData "arg2" "b" "multi_args" + +t11 = tX $ hasRole $ addRoleData "arg2" "z" "multi_args" + +t12 = tX $ hasAllRoles [addRoleData "arg2" "b" "multi_args"] + +t13 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args" + , addRoleData "arg2" "b" "multi_args" ] + +t14 = tX $ hasAnyRoles [ addRoleData "arg2" "z" "multi_args" + , addRoleData "arg2" "aaa" "multi_args" ] + +t15 = tX $ missingRole "jflsdkjf" + +t16 = tX $ do + missingRole "fdjlksjlf" + hasRole "multi_args" + +t17 = tX $ missingRole "multi_args" diff --git a/src/Data/RBAC/Internal/Role.hs b/src/Data/RBAC/Internal/Role.hs new file mode 100644 --- /dev/null +++ b/src/Data/RBAC/Internal/Role.hs @@ -0,0 +1,81 @@ +module Data.RBAC.Internal.Role where + +import Control.Monad.ST +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.String +import Data.Text (Text) +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Merge as VA + + +------------------------------------------------------------------------------ +data RoleValue = RoleBool Bool + | RoleText Text + | RoleInt Int + | RoleDouble Double + deriving (Ord, Eq, Show) + + +instance IsString RoleValue where + fromString = RoleText . fromString + + +instance Hashable RoleValue where + hashWithSalt salt (RoleBool e) = hashWithSalt salt e `combine` 7 + hashWithSalt salt (RoleText t) = hashWithSalt salt t `combine` 196613 + hashWithSalt salt (RoleInt i) = hashWithSalt salt i `combine` 12582917 + hashWithSalt salt (RoleDouble d) = + hashWithSalt salt d `combine` 1610612741 + + +------------------------------------------------------------------------------ +data Role = Role { + _roleName :: Text + , _roleData :: HashMap Text RoleValue + } + deriving (Eq, Show) + + +instance IsString Role where + fromString s = Role (fromString s) M.empty + + +------------------------------------------------------------------------------ +toSortedList :: (Ord k, Ord v) => HashMap k v -> [(k,v)] +toSortedList m = runST $ do + v <- V.unsafeThaw $ V.fromList $ M.toList m + VA.sort v + v' <- V.unsafeFreeze v + return $ V.toList v' + + + +instance Hashable Role where + hashWithSalt salt (Role nm dat) = + h $ hashWithSalt salt nm + where + h s = hashWithSalt s $ toSortedList dat + + +------------------------------------------------------------------------------ +data RoleValueMeta = RoleBoolMeta + | RoleTextMeta + | RoleEnumMeta [Text] + | RoleIntMeta + | RoleDoubleMeta + + +data RoleDataDefinition = RoleDataDefinition { + _roleDataName :: Text + , _roleValueMeta :: RoleValueMeta + , _roleDataDescription :: Text + } + + +data RoleMetadata = RoleMetadata { + _roleMetadataName :: Text + , _roleDescription :: Text + , _roleDataDefs :: [RoleDataDefinition] + } diff --git a/src/Data/RBAC/Internal/RoleMap.hs b/src/Data/RBAC/Internal/RoleMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/RBAC/Internal/RoleMap.hs @@ -0,0 +1,58 @@ +module Data.RBAC.Internal.RoleMap where + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.HashSet (HashSet) +import qualified Data.HashSet as S +import Data.List (find, foldl') +import Data.Text (Text) + +import Data.RBAC.Role +import Data.RBAC.Internal.Types + + +newtype RoleMap = RoleMap (HashMap Text (HashSet Role)) + + +------------------------------------------------------------------------------ +fromList :: [Role] -> RoleMap +fromList = RoleMap . foldl' ins M.empty + where + ins m role = + M.insertWith S.union (_roleName role) (S.singleton role) m + + +------------------------------------------------------------------------------ +lookup :: Role -> RoleMap -> Maybe Role +lookup role (RoleMap m) = find (`matches` role) l + where + l = maybe [] S.toList $ M.lookup (_roleName role) m + + +------------------------------------------------------------------------------ +delete :: Role -> RoleMap -> RoleMap +delete role (RoleMap m) = RoleMap $ maybe m upd $ M.lookup rNm m + where + rNm = _roleName role + upd s = maybe m + (\r -> let s' = S.delete r s + in if S.null s' + then M.delete rNm m + else M.insert rNm s' m) + (find (`matches` role) $ S.toList s) + + +------------------------------------------------------------------------------ +insert :: Role -> RoleMap -> RoleMap +insert role (RoleMap m) = + RoleMap $ M.insertWith S.union (_roleName role) (S.singleton role) m + + +------------------------------------------------------------------------------ +empty :: RoleMap +empty = RoleMap M.empty + + +------------------------------------------------------------------------------ +null :: RoleMap -> Bool +null (RoleMap m) = M.null m diff --git a/src/Data/RBAC/Internal/Rule.hs b/src/Data/RBAC/Internal/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Data/RBAC/Internal/Rule.hs @@ -0,0 +1,31 @@ +module Data.RBAC.Internal.Rule where + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.List (foldl') +import Data.Monoid +import Data.Text (Text) + +import Data.RBAC.Internal.Role + +------------------------------------------------------------------------------ +data Rule = Rule Text (Role -> [Role]) + +newtype RuleSet = RuleSet (HashMap Text (Role -> [Role])) + +instance Monoid RuleSet where + mempty = RuleSet M.empty + (RuleSet m1) `mappend` (RuleSet m2) = RuleSet $ M.foldlWithKey' ins m2 m1 + where + combine f1 f2 r = f1 r ++ f2 r + ins m k v = M.insertWith combine k v m + + +------------------------------------------------------------------------------ +ruleToSet :: Rule -> RuleSet +ruleToSet (Rule nm f) = RuleSet $ M.singleton nm f + + +------------------------------------------------------------------------------ +rulesToSet :: [Rule] -> RuleSet +rulesToSet = foldl' mappend (RuleSet M.empty) . map ruleToSet diff --git a/src/Data/RBAC/Internal/Types.hs b/src/Data/RBAC/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/RBAC/Internal/Types.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.RBAC.Internal.Types + ( module Data.RBAC.Internal.Role + , module Data.RBAC.Internal.Rule + , RoleMonad(..) + , RuleChecker(..) + ) where + +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.Logic + +import Data.RBAC.Internal.Role +import Data.RBAC.Internal.Rule + + +------------------------------------------------------------------------------ +-- TODO: should the monads be transformers here? If they were, you could check +-- more complex predicates here + + +------------------------------------------------------------------------------ +newtype RoleMonad a = RoleMonad { _unRC :: Logic a } + deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic) + + +------------------------------------------------------------------------------ +newtype RuleChecker a = RuleChecker (ReaderT (RoleMonad Role) RoleMonad a) + deriving (Alternative, Applicative, Functor, Monad, MonadPlus, MonadLogic) + diff --git a/src/Data/RBAC/Role.hs b/src/Data/RBAC/Role.hs new file mode 100644 --- /dev/null +++ b/src/Data/RBAC/Role.hs @@ -0,0 +1,24 @@ +module Data.RBAC.Role where + +import qualified Data.HashMap.Strict as M +import Data.RBAC.Internal.Types +import Data.Text (Text) + + +------------------------------------------------------------------------------ +matches :: Role -> Role -> Bool +matches (Role a1 d1) (Role a2 d2) = + a1 == a2 && dmatch (toSortedList d1) (toSortedList d2) + where + dmatch [] _ = True + dmatch _ [] = False + dmatch dds@(d:ds) (e:es) = + case compare d e of + LT -> False + EQ -> dmatch ds es + GT -> dmatch dds es + + +------------------------------------------------------------------------------ +addRoleData :: Text -> RoleValue -> Role -> Role +addRoleData k v (Role n d) = Role n $ M.insert k v d diff --git a/src/Data/RBAC/Types.hs b/src/Data/RBAC/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/RBAC/Types.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.RBAC.Types + ( Role(..) -- fixme: remove (..) + , RoleValue(..) -- fixme + , RoleValueMeta(..) + , RoleDataDefinition(..) + , RoleMetadata(..) + , Rule + , RuleChecker + ) where + +import Data.RBAC.Internal.Types diff --git a/src/Snap.hs b/src/Snap.hs new file mode 100644 --- /dev/null +++ b/src/Snap.hs @@ -0,0 +1,26 @@ +{-| + +This module provides convenience exports of the modules most commonly used +when developing with the Snap Framework. For documentation about Snaplets, +see "Snap.Snaplet". For the core web server API, see "Snap.Core". + +-} + +module Snap + ( module Control.Applicative + , module Control.Monad.State + , module Data.Lens.Common + , module Data.Lens.Template + , module Snap.Core + , module Snap.Http.Server + , module Snap.Snaplet + ) where + +import Control.Applicative +import Control.Monad.State +import Data.Lens.Common +import Data.Lens.Template +import Snap.Core +import Snap.Http.Server +import Snap.Snaplet + diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs deleted file mode 100644 --- a/src/Snap/Extension.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Snap.Extension - ( -- * Introduction - -- $introduction - - -- ** Using Snap Extensions - -- $using - - -- *** Define Application State and Monad - -- $definingtypes - - -- *** Provide Instances For \"HasState\" Classes - -- $hasstateclasses - - -- *** Define The Initializer - -- $initializer - - -- *** Simplified Snap Extension Server - -- $httpserve - - SnapExtend - , Initializer - , InitializerState(..) - , runInitializer - , runInitializerWithReloadAction - , runInitializerWithoutReloadAction - , mkInitializer - , defaultReloadHandler - , nullReloadHandler - ) where - -import Blaze.ByteString.Builder -import Control.Applicative -import Control.Exception (SomeException) -import Control.Monad -import Control.Monad.CatchIO -import Control.Monad.Reader -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Prelude hiding (catch, init) -import Snap.Iteratee (enumBuilder, (>==>)) -import Snap.Types -import System.IO - - -{- $introduction - - Snap Extensions is a library which makes it easy to create reusable plugins - that extend your Snap application with modular chunks of functionality such - as session management, user authentication, templating, or database - connection pooling. - - We achieve this by requiring that you create a datatype that holds an - environment for your application and wrap it around the Snap monad. This new - construct becomes your application's handler monad and gives you access to - your application state throughout your handlers. - - Warning: this interface is still EXPERIMENTAL and has a very high likelihood - of changing substantially in coming versions of Snap. - --} - -{- $using - - Every extension has an interface and at least one implementation of that - interface. - - For some extensions, like Heist, there is only ever going to be one - implementation of the interface. In these cases, both the interface and the - implementation are exported from the same module, Snap.Extension.Heist.Impl. - - Hypothetically, for something like session management though, there could be - multiple implementations, one using a HDBC backend, one using a MongoDB - backend and one just using an encrypted cookie as backend. In these cases, - the interface is exported from Snap.Extension.Session, and the - implementations live in Snap.Extension.Session.HDBC, - Snap.Extension.Session.MongoDB and Snap.Extension.Session.CookieStore. - - Keeping this in mind, there are a number of things you need to do to use - Snap extensions in your application. Let's walk through how to set up a - simple application with the Heist extension turned on. - --} - -{- $definingtypes - - First, we define a record type AppState for holding our application's state, - including the state needed by the extensions we're using. - - At the same time, we also define the monad for our application, App, as - a type alias to @SnapExtend AppState@. 'SnapExtend' is a 'MonadSnap' and - a 'MonadReader', whose environment is a given type; in our case, AppState. - - @ -module App where - -import Database.HDBC -import Database.HDBC.ODBC -import Snap.Extension -import Snap.Extension.Heist -import Snap.Types - -type App = SnapExtend AppState - -data AppState = AppState - { heistState :: HeistState App } - @ - - An important thing to note is that the -State types that we use in the - fields of AppState are specific to each implementation of a extension's - interface. That is, Snap.Extension.Session.HDBC will export a different - SessionState to Snap.Extension.Session.CookieStore, whose internal - representation might be completely different. - - This state is what the extension's implementation needs to be able to do its - job. - --} - -{- $hasstateclasses - - Now we have a datatype that contains all the internal state needed by our - application and the extensions it uses. That's a great start! But when do we - actually get to use this interface and all the functionality that these - extensions export? What is actually being extended? - - We use the interface provided by an extension inside our application's - monad, App. Snap extensions extend our App with new functionality by - allowing us to user their exported functions inside of our handlers. For - example, the Heist extension provides the function: - - @render :: MonadHeist m => ByteString -> m ()@ that renders a template by - its name. - - Is App a 'MonadHeist'? Well, not quite yet. Any 'MonadReader' which is also - a 'MonadSnap' whose environment contains a 'HeistState' is a 'MonadHeist'. - That sounds a lot like our App, doesn't it? We just have to tell the Heist - extension how to find the 'HeistState' in our AppState: - - @ -instance HasHeistState AppState where - getHeistState = heistState - setHeistState hs as = as { heistState = hs } - @ - - Stated another way, if we give our AppState the ability to hold a HeistState - and let the HasHeistState typeclass know how to get/set this state, we are - /automagically/ given the ability to render heist templates in our handlers. - - With these instances, our application's monad App is now a MonadHeist - giving it access to operations like: - - @render :: MonadHeist m => ByteString -> m ()@ - - and - - @heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a@ - --} - -{- $initializer - - So, our monad is now a 'MonadHeist', but how do we actually construct our - AppState and turn an App () into a 'Snap' ()? We need to do this upfront, - once and right before our web server starts listening for connections. - - Snap extensions have a thing called an 'Initializer' that does these things. - Each implementation of a Snap extension interface provides an 'Initializer' - for its -State type. We must construct an initializer type for our -State - type, AppState. An 'Initializer' monad is provided in this library to make - it easy to do this. For your convenience, 'Initializer' is an instance of - 'MonadIO'. - - @ -appInitializer :: Initializer AppState -appInitializer = do - hs <- heistInitializer \"resources/templates\" - return $ AppState hs - @ - - In addition to constructing the AppState, the Initializer monad also - constructs the init, destroy and reload functions for our application from - the init, reload and destroy functions for the extensions. - - Although it won't cause a compile-time error, it is important to get the - order of the initializers correct as much as possible, otherwise they may be - reloaded and destroyed in the wrong order. The "right" order is an order - where every extension's dependencies are initialised before that extension. - For example, Snap.Extension.Session.HDBC would depend on something which - would extend the monad with MonadConnectionPool, i.e., - Snap.Extension.ConnectionPool. If you had this configuration it would be - important that you put the connectionPoolInitializer before the - sessionInitializer in your appInitializer. - - This Initializer AppState can then be passed to 'runInitializer', which - combines our initializer action with our application's handler to produce a - 'Snap' handler (which can be passed to 'httpServe'), a cleanup action (which - you can run after 'httpServe' finishes), and a reload action (which, for - example, you may want to use in your handler for the path \"admin/reload\". - - The following is an example of how you might use this in main: - - @ -main :: IO () -main = do - (snap,cleanup,reload) <- runInitializer appInitializer appSite - let site = snap - <|> path "admin/reload" $ defaultReloadHandler reload cleanup - quickHttpServe site `finally` cleanup - @ - - You'll notice we're using 'defaultReloadHandler'. This is a function - exported by "Snap.Extension" with the type signature - - @MonadSnap m => IO [(ByteString, Maybe ByteString)] -> m ()@ It takes the - reload action returned by 'runInitializer' and returns a 'Snap' action which - renders a simple page showing how the reload went. To avoid denial of - service attacks, the reload handler only works for requests made from the - local host. - --} - -{- $httpserve - - This is, of course, a lot of avoidable boilerplate. Snap extensions framework - comes with another module "Snap.Extension.Server", which provides an - interface mimicking that of "Snap.Http.Server". Their function names clash, - so if you need to use both of them in the same module, use a qualified - import. Using this module, the example above becomes: - - @ -import Snap.Extension.Server - -main :: IO () -main = quickHttpServe appRunner site - @ - - All it needs is a Initializer AppState and an App () and it is ready to go. - You might be wondering what happened to all the reload handler bits we - had before: That stuff has been absorbed into the config for the server. - - One quick note: 'quickHttpServe' doesn't take a config, instead it uses the - defaults augmented with any options specified on the command-line. The - default reload handler path in this case is "admin/reload". - - If you wanted to change this to nullReloadHandler, you would do this: - - @ -import Snap.Extension.Server - -main :: IO () -main = do - config <- commandLineConfig emptyConfig - httpServe (setReloadHandler nullReloadHandler config) appRunner site - @ - - This behaves exactly as the above example apart from the reload handler. - - With this, we now have a fully functional base application that makes use of - the Snap Extensions mechanism. - - To initialize a directory with all of this setup provided as a starting - point, simply @cd@ into the desired location and type: @snap init@. An - example \"Timer\" extension will also be included for your convenience. - --} - ------------------------------------------------------------------------------- --- | A 'SnapExtend' is a 'MonadReader' and a 'MonadSnap' whose environment is --- the application state for a given progam. You would usually type alias --- @SnapExtend AppState@ to something like @App@ to form the monad in which --- you write your application. -newtype SnapExtend s a = SnapExtend (ReaderT s Snap a) - deriving - ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadIO - , MonadCatchIO - , MonadSnap - , MonadReader s - ) - - ------------------------------------------------------------------------------- --- | The 'SCR' datatype is used internally by the 'Initializer' monad to store --- the application's state, cleanup actions and reload actions. -data SCR s = SCR - { _state :: s - -- ^ The internal state of the application's Snap Extensions. - , _cleanup :: IO () - -- ^ IO action which when run will cleanup the application's state, - -- e.g., closing open connections. - , _reload :: IO [(ByteString, Maybe ByteString)] - -- ^ IO action which when run will reload the application's state, e.g., - -- refreshing any cached values stored in the state. - -- - -- It returns a list of tuples whose \"keys\" are the names of the Snap - -- Extensions which were reloaded and whose \"values\" are @Nothing@ - -- when run successfully and @Just x@ on failure, where @x@ is an error - -- message. - } - - ------------------------------------------------------------------------------- --- | The 'Initializer' monad. The code that initialises your application's --- state is written in the 'Initializer' monad. It's used for constructing --- values which have cleanup\/destroy and reload actions associated with them. -newtype Initializer s = Initializer (Bool -> IO (Either s (SCR s))) - - ------------------------------------------------------------------------------- --- | Values of types which are instances of 'InitializerState' have --- cleanup\/destroy and reload actions associated with them. -class InitializerState s where - extensionId :: s -> ByteString - mkCleanup :: s -> IO () - mkReload :: s -> IO () - - ------------------------------------------------------------------------------- --- | Although it has the same type signature, this is not the same as 'return' --- in the 'Initializer' monad. Return simply lifts a value into the --- 'Initializer' monad, but this lifts the value and its destroy\/reload --- actions. Use this when making your own 'Initializer' actions. -mkInitializer :: InitializerState s => s -> Initializer s -mkInitializer s = Initializer $ \v -> setup v $ Right $ mkSCR v - where - handler :: SomeException -> IO (Maybe ByteString) - handler e = return $ Just $ toUTF8 $ show e - maybeCatch m = (m >> return Nothing) `catch` handler - maybeToMsg = maybe " done." $ const " failed." - name = fromUTF8 $ extensionId s - mkSCR v = SCR s (cleanup v) (reload v) - cleanup v = do - when v $ hPutStr stderr $ "Cleaning up " ++ name ++ "..." - m <- maybeCatch $ mkCleanup s - when v $ hPutStrLn stderr $ maybeToMsg m - reload v = do - when v $ hPutStr stderr $ "Reloading " ++ name ++ "..." - m <- maybeCatch $ mkReload s - when v $ hPutStrLn stderr $ maybeToMsg m - return [(extensionId s, m)] - setup v r = do - when v $ hPutStrLn stderr $ "Initializing " ++ name ++ "... done." - return r - - ------------------------------------------------------------------------------- --- | Given the Initializer for your application's state, and a value in the --- monad formed by 'SnapExtend' wrapped it, this returns a 'Snap' action, a --- cleanup action and a reload action. -runInitializer - :: Bool - -- ^ Verbosity; info is printed to 'stderr' when this is 'True' - -> Initializer s - -- ^ The Initializer value - -> SnapExtend s () - -- ^ A web handler in your application's monad - -> IO (Snap (), IO (), IO [(ByteString, Maybe ByteString)]) - -- ^ Returns a 'Snap' handler, a cleanup action, and a reload action. The - -- list returned by the reload action is for error reporting. There is - -- one tuple in the list for each Snap extension; the first element of - -- the tuple is the name of the Snap extension, and the second is a Maybe - -- which contains Nothing if there was no error reloading that extension - -- and a Just with the ByteString containing the error message if there - -- was. -runInitializer v (Initializer r) (SnapExtend m) = - r v >>= \e -> case e of - Left s -> return (runReaderT m s, return (), return []) - Right (SCR s a b) -> return (runReaderT m s, a, b) - - ------------------------------------------------------------------------------- --- | Serves the same purpose as 'runInitializer', but combines the --- application's web handler with a user-supplied action to be run to reload --- the application's state. -runInitializerWithReloadAction - :: Bool - -- ^ Verbosity; info is printed to 'stderr' when this is 'True' - -> Initializer s - -- ^ The Initializer value - -> SnapExtend s () - -- ^ A web handler in your application's monad. - -> (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ()) - -- ^ Your desired \"reload\" handler; it gets passed the reload - -- action. This handler is always run, so you have to guard the path - -- yourself (with. - -> IO (Snap (), IO ()) - -- ^ Your 'Snap' handler and a cleanup action. -runInitializerWithReloadAction v (Initializer r) se f = do - (state, cleanup, reload) <- runInit - - let (SnapExtend m') = f reload <|> se - return (runReaderT m' state, cleanup) - - where - runInit = r v >>= \e -> - case e of - Left s -> return (s, return (), return []) - Right (SCR s a b) -> return (s, a, b) - ------------------------------------------------------------------------------- --- | A cut-down version of 'runInitializer', for use by the hint --- loading code -runInitializerWithoutReloadAction :: Initializer s - -- ^ The Initializer value - -> SnapExtend s () - -- ^ An action in your application's monad. - -> IO (Snap (), IO ()) -runInitializerWithoutReloadAction i se = do - (action, cleanup, _) <- runInitializer True i se - return (action, cleanup) - - ------------------------------------------------------------------------------- -instance Functor Initializer where - fmap f (Initializer r) = Initializer $ \v -> r v >>= \e -> return $ - case e of - Left s -> Left $ f s - Right (SCR s a b) -> Right $ SCR (f s) a b - - ------------------------------------------------------------------------------- -instance Applicative Initializer where - pure = return - (<*>) = ap - - ------------------------------------------------------------------------------- -instance Monad Initializer where - return = Initializer . const . return . Left - a >>= f = join' $ fmap f a - - ------------------------------------------------------------------------------- -instance MonadIO Initializer where - liftIO = Initializer . const . fmap Left - - ------------------------------------------------------------------------------- --- | Join for the 'Initializer' monad. This is used in the definition of bind --- for the 'Initializer' monad. -join' :: Initializer (Initializer s) -> Initializer s -join' (Initializer r) = Initializer $ \v -> r v >>= \e -> case e of - Left (Initializer r') -> r' v - Right (SCR (Initializer r') a b) -> r' v >>= \e' -> return $ Right $ - case e' of - Left s -> SCR s a b - Right (SCR s a' b') -> SCR s (a' >> a) (liftM2 (++) b b') - - ------------------------------------------------------------------------------- --- | This takes the last value of the tuple returned by 'runInitializer', --- which is a list representing the results of an attempt to reload the --- application's Snap Extensions, and turns it into a Snap action which --- displays the these results. -defaultReloadHandler :: MonadSnap m - => IO [(ByteString, Maybe ByteString)] - -> m () -defaultReloadHandler ioms = failIfNotLocal $ do - ms <- liftIO $ ioms - let showE e = mappend "Error: " $ toUTF8 $ show e - format (n, m) = mconcat [n, ": ", maybe "Success" showE m, "\n"] - msg = mconcat $ map format ms - finishWith $ setContentType "text/plain; charset=utf-8" - $ setContentLength (fromIntegral $ B.length msg) - $ modifyResponseBody (>==> enumBuilder (fromByteString msg)) - emptyResponse - where - failIfNotLocal m = do - rip <- liftM rqRemoteAddr getRequest - if not $ elem rip [ "127.0.0.1" - , "localhost" - , "::1" ] - then pass - else m - ------------------------------------------------------------------------------- --- | Use this reload handler to disable the ability to have a web handler --- which reloads Snap extensions. -nullReloadHandler :: MonadSnap m - => IO [(ByteString, Maybe ByteString)] - -> m () -nullReloadHandler = const pass - - ------------------------------------------------------------------------------- -fromUTF8 :: ByteString -> String -fromUTF8 = T.unpack . T.decodeUtf8 - -toUTF8 :: String -> ByteString -toUTF8 = T.encodeUtf8 . T.pack diff --git a/src/Snap/Extension/Heist.hs b/src/Snap/Extension/Heist.hs deleted file mode 100644 --- a/src/Snap/Extension/Heist.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -{-| - -'Snap.Extension.Heist' exports the 'MonadHeist' interface which allows you to -integrate Heist templates into your Snap application. The interface's -operations are 'heistServe', 'heistServeSingle', 'heistLocal' and 'render'. As -a convenience, we also provide 'renderWithSplices' that combines 'heistLocal' -and 'render' into a single function call. - -'Snap.Extension.Heist.Impl' contains the only implementation of this interface -and can be used to turn your application's monad into a 'MonadHeist'. - -'MonadHeist' is unusual among Snap extensions in that it's a multi-parameter -typeclass. The last parameter is your application's monad, and the first is -the monad you want the 'TemplateState' to use. This is usually, but not -always, also your application's monad. - -This module should not be used directly. Instead, import -"Snap.Extension.Heist.Impl" in your application. - --} - -module Snap.Extension.Heist - ( MonadHeist(..) - , renderWithSplices ) where - -import Control.Applicative -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import Data.Text (Text) -import Snap.Types -import Snap.Util.FileServe -import Text.Templating.Heist - - ------------------------------------------------------------------------------- --- | The 'MonadHeist' type class. Minimal complete definition: 'render', --- 'heistLocal'. -class (Monad n, MonadSnap m) => MonadHeist n m | m -> n where - -- | Renders a template as text\/html. If the given template is not found, - -- this returns 'empty'. - render :: ByteString -> m () - - -- | Renders a template as the given content type. If the given template - -- is not found, this returns 'empty'. - renderAs :: ByteString -> ByteString -> m () - - -- | Runs an action with a modified 'TemplateState'. You might want to use - -- this if you had a set of splices which were customised for a specific - -- action. To do that you would do: - -- - -- > heistLocal (bindSplices mySplices) $ render "myTemplate" - heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a - - -- | Analogous to 'fileServe'. If the template specified in the request - -- path is not found, it returns 'empty'. - heistServe :: m () - heistServe = ifTop (render "index") <|> (render . B.pack =<< getSafePath) - - -- | Analogous to 'fileServeSingle'. If the given template is not found, - -- this throws an error. - heistServeSingle :: ByteString -> m () - heistServeSingle t = render t - <|> error ("Template " ++ show t ++ " not found.") - - ------------------------------------------------------------------------------- --- | Helper function for common use case: --- Render a template with a given set of splices. -renderWithSplices - :: (MonadHeist n m) - => ByteString -- ^ Template to render - -> [(Text, Splice n)] -- ^ Splice mapping - -> m () -renderWithSplices t sps = heistLocal bsps $ render t - where bsps = bindSplices sps diff --git a/src/Snap/Extension/Heist/Impl.hs b/src/Snap/Extension/Heist/Impl.hs deleted file mode 100644 --- a/src/Snap/Extension/Heist/Impl.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -{-| - -'Snap.Extension.Heist.Impl' is an implementation of the 'MonadHeist' -interface defined in 'Snap.Extension.Heist'. - -As always, to use, add 'HeistState' to your application's state, along with an -instance of 'HasHeistState' for your application's state, making sure to -use a 'heistInitializer' in your application's 'Initializer', and then you're -ready to go. - -'Snap.Extension.Heist.Impl' is a little different to other Snap Extensions, -which is unfortunate as it is probably the most widely useful one. As -explained below, 'HeistState' takes your application's monad as a type -argument, and 'HasHeistState' is a multi-parameter type class, the additional -first parameter also being your application's monad. - -Two instances of 'MonadHeist' are provided with this module. One is designed -for users wanting to use Heist templates with their application, the other is -designed for users writing Snap Extensions which use their own Heist templates -internally. - -The first one of these instances is -@HasHeistState (SnapExtend s) s => MonadHeist (SnapExtend s) (SnapExtend s)@. -This means that any type @s@ which has a 'HeistState', whose -'TemplateState'\'s monad is @SnapExtend s@ forms a 'MonadHeist' whose -'TemplateState'\'s monad is @SnapExtend s@ and whose monad itself is -@SnapExtend s@. The @s@ here is your application's state, and @SnapExtend s@ -is your application's monad. - -The second one of these instances is -@HasHeistState m s => MonadHeist m (ReaderT s m)@. This means that any type -@s@ which has, for any m, a @HeistState m@, forms a 'MonadHeist', whose -'TemplateState'\'s monad is @m@, when made the environment of -a 'ReaderT' wrapped around @m@. The @s@ here would be the Snap Extension's -internal state, and the @m@ would be 'SnapExtend' wrapped around any @s'@ -which was an instance of the Snap Extension's @HasState@ class. - -This implementation does not require that your application's monad implement -interfaces from any other Snap Extension. - --} - -module Snap.Extension.Heist.Impl - ( - - -- * Heist State Definitions - HeistState - , HasHeistState(..) - , heistInitializer - - -- * The MonadHeist Interface - , MonadHeist(..) - - -- * Convenience Functions - , registerSplices - ) where - -import Control.Concurrent.MVar -import Control.Monad.Reader -import Data.ByteString (ByteString) -import Data.Maybe -import Data.Text (Text) -import Snap.Extension -import Snap.Extension.Heist -import Snap.Types -import Text.Templating.Heist -import Text.Templating.Heist.Splices.Static - - ------------------------------------------------------------------------------- --- | Your application's state must include a 'HeistState' in order for your --- application to be a 'MonadHeist'. --- --- Unlike other @-State@ types, this is of kind @(* -> *) -> *@. Unless you're --- developing your own Snap Extension which has its own internal 'HeistState', --- the type argument you want to pass to 'HeistState' is your application's --- monad, which should be 'SnapExtend' wrapped around your application's --- state. -data MonadSnap m => HeistState m = HeistState - { _path :: FilePath - , _origTs :: TemplateState m - , _tsMVar :: MVar (TemplateState m) - , _sts :: StaticTagState - , _modifier :: TemplateState m -> TemplateState m - } - - ------------------------------------------------------------------------------- --- | For your application's monad to be a 'MonadHeist', your application's --- state needs to be an instance of 'HasHeistState'. Minimal complete --- definition: 'getHeistState', 'setHeistState'. --- --- Unlike other @HasState@ type classes, this is a type class has two --- parameters. Among other things, this means that you will need to enable the --- @FlexibleInstances@ and @MultiParameterTypeClasses@ language extensions to --- be able to create an instance of @HasHeistState@. In most cases, the last --- parameter will as usual be your application's state, and the additional --- first one will be the monad formed by wrapping 'SnapExtend' around your --- application's state. --- --- However, if you are developing your own Snap Extension which uses its own --- internal 'HeistState', the last parameter will be your Snap Extension's --- internal state, and the additional first parameter will be any monad formed --- by wrapping @SnapExtend@ around a type which has an instance of the --- @HasState@ class for your monad. These two use cases are subtly different, --- which is why 'HasHeistState' needs two type parameters. -class MonadSnap m => HasHeistState m s | s -> m where - getHeistState :: s -> HeistState m - setHeistState :: HeistState m -> s -> s - - modifyHeistState :: (HeistState m -> HeistState m) -> s -> s - modifyHeistState f s = setHeistState (f $ getHeistState s) s - - ------------------------------------------------------------------------------- --- | The 'Initializer' for 'HeistState'. -heistInitializer :: MonadSnap m - => FilePath - -- ^ Path to a template directory containing @.tpl@ files - -> (TemplateState m -> TemplateState m) - -- ^ Function to modify the initial template state - -> Initializer (HeistState m) -heistInitializer p modTS = do - heistState <- liftIO $ do - (origTs,sts) <- bindStaticTag $ modTS $ emptyTemplateState p - loadTemplates p origTs >>= either error (\ts -> do - tsMVar <- newMVar ts - return $ HeistState p origTs tsMVar sts id) - mkInitializer heistState - - ------------------------------------------------------------------------------- -instance MonadSnap m => InitializerState (HeistState m) where - extensionId = const "Heist/Impl" - mkCleanup = const $ return () - mkReload (HeistState p origTs tsMVar sts _) = do - clearStaticTagCache $ sts - either error (modifyMVar_ tsMVar . const . return) =<< - loadTemplates p origTs - - ------------------------------------------------------------------------------- -instance HasHeistState (SnapExtend s) s - => MonadHeist (SnapExtend s) (SnapExtend s) where - render t = do - hs <- asks getHeistState - renderHelper hs Nothing t - - renderAs c t = do - hs <- asks getHeistState - renderHelper hs (Just c) t - - heistLocal f = local $ modifyHeistState $ \s -> - s { _modifier = f . _modifier s } - - ------------------------------------------------------------------------------- -instance HasHeistState m s => MonadHeist m (ReaderT s m) where - render t = ReaderT $ \s -> renderHelper (getHeistState s) Nothing t - - renderAs c t = ReaderT $ \s -> renderHelper (getHeistState s) (Just c) t - - heistLocal f = local $ modifyHeistState $ \s -> - s { _modifier = f . _modifier s } - - ------------------------------------------------------------------------------- -renderHelper :: (MonadSnap m) - => HeistState m - -> Maybe MIMEType - -> ByteString - -> m () -renderHelper hs c t = do - let (HeistState _ _ tsMVar _ modifier) = hs - ts <- liftIO $ fmap modifier $ readMVar tsMVar - renderTemplate ts t >>= maybe pass (\(b,mime) -> do - modifyResponse $ setContentType $ fromMaybe mime c - writeBuilder b) - - ------------------------------------------------------------------------------- --- | Take your application's state and register these splices in it so --- that you don't have to re-list them in every handler. Should be called from --- inside your application's 'Initializer'. The splices registered by this --- function do not persist through template reloads. Those splices must be --- passed as a parameter to heistInitializer. --- --- (NOTE: In the future we may decide to deprecate registerSplices in favor of --- the heistInitializer argument.) --- --- Typical use cases are dynamically generated components that are present in --- many of your views. --- --- Example Usage: --- --- @ --- appInit :: Initializer AppState --- appInit = do --- hs <- heistInitializer \"templates\" --- registerSplices hs $ --- [ (\"tabs\", tabsSplice) --- , (\"loginLogout\", loginLogoutSplice) ] --- @ -registerSplices - :: (MonadSnap m, MonadIO n) - => HeistState m - -- ^ Heist state that you are going to embed in your application's state. - -> [(Text, Splice m)] - -- ^ Your splices. - -> n () -registerSplices s sps = liftIO $ do - let mv = _tsMVar s - modifyMVar_ mv $ (return . bindSplices sps) diff --git a/src/Snap/Extension/Loader/Devel.hs b/src/Snap/Extension/Loader/Devel.hs deleted file mode 100644 --- a/src/Snap/Extension/Loader/Devel.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} --- | This module includes the machinery necessary to use hint to load --- action code dynamically. It includes a Template Haskell function --- to gather the necessary compile-time information about code --- location, compiler arguments, etc, and bind that information into --- the calls to the dynamic loader. -module Snap.Extension.Loader.Devel - ( loadSnapTH - , loadSnapTH' - ) where - -import Control.Monad (liftM2) - -import Data.List -import Data.Maybe (catMaybes) -import Data.Time.Clock (diffUTCTime, getCurrentTime) - -import Language.Haskell.Interpreter hiding (lift, liftIO) -import Language.Haskell.Interpreter.Unsafe - -import Language.Haskell.TH - -import System.Environment (getArgs) - ------------------------------------------------------------------------------- -import Snap.Types -import Snap.Extension.Loader.Devel.Signal -import Snap.Extension.Loader.Devel.Evaluator -import Snap.Extension.Loader.Devel.TreeWatcher - ------------------------------------------------------------------------------- --- | This function derives all the information necessary to use the --- interpreter from the compile-time environment, and compiles it in --- to the generated code. --- --- This could be considered a TH wrapper around a function --- --- > loadSnap :: Initializer s -> SnapExtend s () -> [String] -> IO (Snap ()) --- --- with a magical implementation. --- --- The upshot is that you shouldn't need to recompile your server --- during development unless your .cabal file changes, or the code --- that uses this splice changes. -loadSnapTH :: Name -> Name -> [String] -> Q Exp -loadSnapTH initializer action additionalWatchDirs = - loadSnapTH' modules imports additionalWatchDirs loadStr - where - initMod = nameModule initializer - initBase = nameBase initializer - actMod = nameModule action - actBase = nameBase action - - modules = catMaybes [initMod, actMod] - imports = ["Snap.Extension"] - - loadStr = intercalate " " [ "runInitializerWithoutReloadAction" - , initBase - , actBase - ] - - ------------------------------------------------------------------------------- --- | This is the backing implementation for 'loadSnapTH'. This --- interface can be used when the types involved don't include a --- SnapExtend and an Initializer. -loadSnapTH' :: [String] -- ^ the list of modules to interpret - -> [String] -- ^ the list of modules to import in addition - -- to those being interpreted - -> [String] -- ^ additional directories to watch for - -- changes to trigger to recompile/reload - -> String -- ^ the expression to interpret in the - -- context of the loaded modules and imports. - -- It should have the type 'HintLoadable' - -> Q Exp -loadSnapTH' modules imports additionalWatchDirs loadStr = do - args <- runIO getArgs - - let opts = getHintOpts args - srcPaths = additionalWatchDirs ++ getSrcPaths args - - [| hintSnap opts modules imports srcPaths loadStr |] - - ------------------------------------------------------------------------------- --- | Convert the command-line arguments passed in to options for the --- hint interpreter. This is somewhat brittle code, based on a few --- experimental datapoints regarding the structure of the command-line --- arguments cabal produces. -getHintOpts :: [String] -> [String] -getHintOpts args = removeBad opts - where - bad = ["-threaded", "-O"] - removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad) - - hideAll = filter (== "-hide-all-packages") args - - srcOpts = filter (\x -> "-i" `isPrefixOf` x - && not ("-idist" `isPrefixOf` x)) args - - toCopy = filter (not . isSuffixOf ".hs") $ - dropWhile (not . ("-package" `isPrefixOf`)) args - copy = map (intercalate " ") . groupBy (\_ s -> not $ "-" `isPrefixOf` s) - - opts = hideAll ++ srcOpts ++ copy toCopy - - ------------------------------------------------------------------------------- --- | This function extracts the source paths from the compilation args -getSrcPaths :: [String] -> [String] -getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg - where - srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x) - - ------------------------------------------------------------------------------- --- | This function creates the Snap handler that actually is --- responsible for doing the dynamic loading of actions via hint, --- given all of the configuration information that the interpreter --- needs. It also ensures safe concurrent access to the interpreter, --- and caches the interpreter results for a short time before allowing --- it to run again. --- --- Generally, this won't be called manually. Instead, loadSnapTH will --- generate a call to it at compile-time, calculating all the --- arguments from its environment. -hintSnap :: [String] -- ^ A list of command-line options for the interpreter - -> [String] -- ^ A list of modules that need to be - -- interpreted. This should contain only the - -- modules which contain the initialization, - -- cleanup, and handler actions. Everything else - -- they require will be loaded transitively. - -> [String] -- ^ A list of modules that need to be be - -- imported, in addition to the ones that need to - -- be interpreted. This only needs to contain - -- modules that aren't being interpreted, such as - -- those from other libraries, that are used in - -- the expression passed in. - -> [String] -- ^ A list of paths to watch for updates - -> String -- ^ The string to execute - -> IO (Snap (), IO ()) -hintSnap opts modules imports srcPaths action = - protectedHintEvaluator initialize test loader - where - interpreter = do - loadModules . nub $ modules - setImports . nub $ "Prelude" : "Snap.Types" : imports ++ modules - - interpret action (as :: HintLoadable) - - loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter - - formatOnError (Left err) = error $ format err - formatOnError (Right a) = a - - loader = formatOnError `fmap` protectHandlers loadInterpreter - - initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths - - test (prevTime, ts) = do - now <- getCurrentTime - if diffUTCTime now prevTime < 3 - then return True - else checkTreeStatus ts - - ------------------------------------------------------------------------------- --- | Convert an InterpreterError to a String for presentation -format :: InterpreterError -> String -format (UnknownError e) = "Unknown interpreter error:\r\n\r\n" ++ e -format (NotAllowed e) = "Interpreter action not allowed:\r\n\r\n" ++ e -format (GhcException e) = "GHC error:\r\n\r\n" ++ e -format (WontCompile errs) = "Compile errors:\r\n\r\n" ++ - (intercalate "\r\n" $ nub $ map errMsg errs) - diff --git a/src/Snap/Extension/Loader/Devel/Evaluator.hs b/src/Snap/Extension/Loader/Devel/Evaluator.hs deleted file mode 100644 --- a/src/Snap/Extension/Loader/Devel/Evaluator.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Snap.Extension.Loader.Devel.Evaluator - ( HintLoadable - , protectedHintEvaluator - ) where - - -import Control.Exception -import Control.Monad (when) -import Control.Monad.Trans (liftIO) - -import Control.Concurrent (ThreadId, forkIO, myThreadId) -import Control.Concurrent.MVar - -import Prelude hiding (catch, init, any) - -import Snap.Types (Snap) - - ------------------------------------------------------------------------------- --- | A type synonym to simply talking about the type loaded by hint. -type HintLoadable = IO (Snap (), IO ()) - - ------------------------------------------------------------------------------- --- | Convert an action to generate 'HintLoadable's into an action to --- generate Snap actions. The resulting action will share initialized --- state until the next execution of the input action. At this time, --- the cleanup action will be executed. --- --- The first two arguments control when recompiles are done. The --- first argument is an action that is executed when compilation --- starts. The second is a function from the result of the first --- action to an action that determines whether the value from the --- previous compilation is still good. This abstracts out the --- strategy for determining when a cached result is no longer valid. --- --- If an exception is raised during the processing of the action, it --- will be thrown to all waiting threads, and for all requests made --- before the recompile condition is reached. -protectedHintEvaluator :: forall a. - IO a - -> (a -> IO Bool) - -> IO HintLoadable - -> IO (Snap (), IO ()) -protectedHintEvaluator start test getInternals = do - -- The list of requesters waiting for a result. Contains the - -- ThreadId in case of exceptions, and an empty MVar awaiting a - -- successful result. - readerContainer <- newReaderContainer - - -- Contains the previous result and initialization value, and the - -- time it was stored, if a previous result has been computed. - -- The result stored is either the actual result and - -- initialization result, or the exception thrown by the - -- calculation. - resultContainer <- newResultContainer - - -- The model used for the above MVars in the returned action is - -- "keep them full, unless updating them." In every case, when - -- one of those MVars is emptied, the next action is to fill that - -- same MVar. This makes deadlocking on MVar wait impossible. - let snap = do - let waitForNewResult :: IO (Snap ()) - waitForNewResult = do - -- Need to calculate a new result - tid <- myThreadId - reader <- newEmptyMVar - - readers <- takeMVar readerContainer - - -- Some strictness is employed to ensure the MVar - -- isn't holding on to a chain of unevaluated thunks. - let pair = (tid, reader) - newReaders = readers `seq` pair `seq` (pair : readers) - putMVar readerContainer $! newReaders - - -- If this is the first reader to queue, clean up the - -- previous state, if there was any, and then begin - -- evaluation of the new code and state. - when (null readers) $ do - let runAndFill = block $ do - -- run the cleanup action - previous <- readMVar resultContainer - unblock $ cleanup previous - - -- compile the new internals and initialize - stateInitializer <- unblock getInternals - res <- unblock stateInitializer - - let a = fst res - - clearAndNotify (Right res) (flip putMVar a . snd) - - killWaiting :: SomeException -> IO () - killWaiting e = block $ do - clearAndNotify (Left e) (flip throwTo e . fst) - throwIO e - - clearAndNotify r f = do - a <- unblock start - _ <- swapMVar resultContainer $ Just (r, a) - allReaders <- swapMVar readerContainer [] - mapM_ f allReaders - - _ <- forkIO $ runAndFill `catch` killWaiting - return () - - -- Wait for the evaluation of the action to complete, - -- and return its result. - takeMVar reader - - existingResult <- liftIO $ readMVar resultContainer - - getResult <- liftIO $ case existingResult of - Just (res, a) -> do - -- There's an existing result. Check for validity - valid <- test a - case (valid, res) of - (True, Right (x, _)) -> return x - (True, Left e) -> throwIO e - (False, _) -> do - _ <- swapMVar resultContainer Nothing - waitForNewResult - Nothing -> waitForNewResult - getResult - - clean = do - let msg = "invalid dynamic loader state. " ++ - "The cleanup action has been executed" - contents <- swapMVar resultContainer $ error msg - cleanup contents - - return (snap, clean) - where - newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))]) - newReaderContainer = newMVar [] - - newResultContainer :: IO (MVar (Maybe (Either SomeException - (Snap (), IO ()), a))) - newResultContainer = newMVar Nothing - - cleanup (Just (Right (_, clean), _)) = clean - cleanup _ = return () diff --git a/src/Snap/Extension/Loader/Devel/Signal.hs b/src/Snap/Extension/Loader/Devel/Signal.hs deleted file mode 100644 --- a/src/Snap/Extension/Loader/Devel/Signal.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE CPP #-} -module Snap.Extension.Loader.Devel.Signal (protectHandlers) where - -import Control.Exception (bracket) - -#ifdef mingw32_HOST_OS -import GHC.ConsoleHandler as C - - -saveHandlers :: IO C.Handler -saveHandlers = C.installHandler Ignore - - -restoreHandlers :: C.Handler -> IO C.Handler -restoreHandlers = C.installHandler - - -#else -import qualified System.Posix.Signals as S - -helper :: S.Handler -> S.Signal -> IO S.Handler -helper handler signal = S.installHandler signal handler Nothing - - -signals :: [S.Signal] -signals = [ S.sigQUIT - , S.sigINT - , S.sigHUP - , S.sigTERM - ] - - -saveHandlers :: IO [S.Handler] -saveHandlers = mapM (helper S.Ignore) signals - - -restoreHandlers :: [S.Handler] -> IO [S.Handler] -restoreHandlers h = sequence $ zipWith helper h signals - - -#endif -protectHandlers :: IO a -> IO a -protectHandlers a = bracket saveHandlers restoreHandlers $ const a diff --git a/src/Snap/Extension/Loader/Devel/TreeWatcher.hs b/src/Snap/Extension/Loader/Devel/TreeWatcher.hs deleted file mode 100644 --- a/src/Snap/Extension/Loader/Devel/TreeWatcher.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Snap.Extension.Loader.Devel.TreeWatcher - ( TreeStatus - , getTreeStatus - , checkTreeStatus - ) where - -import Control.Applicative - -import System.Directory -import System.Directory.Tree - -import System.Time - - ------------------------------------------------------------------------------- --- | An opaque representation of the contents and last modification --- times of a forest of directory trees. -data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime] - - ------------------------------------------------------------------------------- --- | Create a 'TreeStatus' for later checking with 'checkTreeStatus' -getTreeStatus :: [FilePath] -> IO TreeStatus -getTreeStatus = liftA2 (<$>) TS readModificationTimes - - ------------------------------------------------------------------------------- --- | Checks that all the files present in the initial set of paths are --- the exact set of files currently present, with unchanged modifcations times -checkTreeStatus :: TreeStatus -> IO Bool -checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths - where - check = and . zipWith (==) entries - - ------------------------------------------------------------------------------- --- | This is the core of the functions in this module. It converts a --- list of filepaths into a list of 'AnchoredDirTree' annotated with --- the modification times of the files located in those paths. -readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime] -readModificationTimes = mapM $ readDirectoryWith getModificationTime diff --git a/src/Snap/Extension/Server.hs b/src/Snap/Extension/Server.hs deleted file mode 100644 --- a/src/Snap/Extension/Server.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - -{-| - -This module provides replacements for the 'httpServe' and 'quickHttpServe' -functions exported by 'Snap.Http.Server'. By taking a 'Initializer' as an -argument, these functions simplify the glue code that is needed to use Snap -Extensions. - --} - -module Snap.Extension.Server - ( ConfigExtend - , httpServe - , quickHttpServe - , defaultConfig - , getReloadHandler - , setReloadHandler - , module Snap.Http.Server.Config - ) where - -import Control.Exception (SomeException) -import Control.Monad -import Control.Monad.CatchIO -import Data.ByteString (ByteString) -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Prelude hiding (catch) -import Snap.Extension -import qualified Snap.Http.Server as SS -import qualified Snap.Http.Server.Config as C -import Snap.Http.Server.Config hiding ( defaultConfig - , completeConfig - , getOther - , setOther - ) -import Snap.Util.GZip -import Snap.Types -import System.IO - - ------------------------------------------------------------------------------- --- | 'ConfigExtend' is similar to the 'Config' exported by 'Snap.Http.Server', --- but is augmented with a @reloadHandler@ field which can be accessed using --- 'getReloadHandler' and 'setReloadHandler'. -type ConfigExtend s = Config - (SnapExtend s) (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ()) - - ------------------------------------------------------------------------------- -getReloadHandler :: ConfigExtend s -> Maybe - (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ()) -getReloadHandler = C.getOther - - ------------------------------------------------------------------------------- -setReloadHandler :: (IO [(ByteString, Maybe ByteString)] -> SnapExtend s ()) - -> ConfigExtend s - -> ConfigExtend s -setReloadHandler = C.setOther - - - - ------------------------------------------------------------------------------- --- | These are the default values for all the fields in 'ConfigExtend'. --- --- > hostname = "localhost" --- > address = "0.0.0.0" --- > port = 8000 --- > accessLog = "log/access.log" --- > errorLog = "log/error.log" --- > locale = "en_US" --- > compression = True --- > verbose = True --- > errorHandler = prints the error message --- > reloadHandler = prints the result of each reload handler (error/success) --- -defaultConfig :: ConfigExtend s -defaultConfig = setReloadHandler handler C.defaultConfig - where - handler = path "admin/reload" . defaultReloadHandler - - ------------------------------------------------------------------------------- --- | Completes a partial 'Config' by filling in the unspecified values with --- the default values from 'defaultConfig'. -completeConfig :: ConfigExtend s -> IO (ConfigExtend s) -completeConfig = C.completeConfig . (mappend defaultConfig) - - ------------------------------------------------------------------------------- --- | Starts serving HTTP requests using the given handler, with settings from --- the 'ConfigExtend' passed in. This function never returns; to shut down --- the HTTP server, kill the controlling thread. -httpServe :: ConfigExtend s - -- ^ Any configuration options which override the defaults - -> Initializer s - -- ^ The 'Initializer' function for the application's monad - -> SnapExtend s () - -- ^ The application to be served - -> IO () -httpServe config initializer handler = do - conf <- completeConfig config - let !verbose = fromJust $ getVerbose conf - let !reloader = fromJust $ getReloadHandler conf - let !compress = if fromJust $ getCompression conf then withCompression else id - let !catch500 = flip catch $ fromJust $ getErrorHandler conf - let !serve = SS.simpleHttpServe config - (site, cleanup) <- runInitializerWithReloadAction - verbose - initializer - (catch500 $ compress handler) - reloader - _ <- try $ serve $ site :: IO (Either SomeException ()) - putStr "\n" - cleanup - - ------------------------------------------------------------------------------- --- | Starts serving HTTP using the given handler. The configuration is read --- from the options given on the command-line, as returned by --- 'commandLineConfig'. -quickHttpServe :: Initializer s - -- ^ The 'Initializer' function for the application's monad - -> SnapExtend s () - -- ^ The application to be served - -> IO () -quickHttpServe r m = commandLineConfig emptyConfig >>= \c -> httpServe c r m - ------------------------------------------------------------------------------- -fromUTF8 :: ByteString -> String -fromUTF8 = T.unpack . T.decodeUtf8 diff --git a/src/Snap/Loader/Devel.hs b/src/Snap/Loader/Devel.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Loader/Devel.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This module includes the machinery necessary to use hint to load +-- action code dynamically. It includes a Template Haskell function +-- to gather the necessary compile-time information about code +-- location, compiler arguments, etc, and bind that information into +-- the calls to the dynamic loader. +module Snap.Loader.Devel + ( loadSnapTH + ) where + +import Control.Monad (liftM2) + +import Data.Char (isAlphaNum) +import Data.List +import Data.Maybe (maybeToList) +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Data.Typeable + +import Language.Haskell.Interpreter hiding (lift, liftIO, typeOf) +import Language.Haskell.Interpreter.Unsafe + +import Language.Haskell.TH + +import System.Environment (getArgs) + +------------------------------------------------------------------------------ +import Snap.Core +import Snap.Loader.Devel.Signal +import Snap.Loader.Devel.Evaluator +import Snap.Loader.Devel.TreeWatcher + +------------------------------------------------------------------------------ +-- | This function derives all the information necessary to use the +-- interpreter from the compile-time environment, and compiles it in +-- to the generated code. +-- +-- This could be considered a TH wrapper around a function +-- +-- > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ())) +-- > -> [String] -> IO (a, Snap (), IO ()) +-- +-- with a magical implementation. The [String] argument is a list of +-- directories to watch for updates to trigger a reloading. +-- Directories containing code should be automatically picked up by +-- this splice. +-- +-- The generated splice executes the initialiser once, sets up the +-- interpreter for the load function, and returns the initializer's +-- result along with the interpreter's proxy handler and cleanup +-- actions. The behavior of the proxy actions will change to reflect +-- changes in the watched files, reinterpreting the load function as +-- needed and applying it to the initializer result. +-- +-- This will handle reloading the application successfully in most +-- cases. The cases in which it is certain to fail are those +-- involving changing the types of the initializer or the load +-- function, or changing the compiler options required, such as by +-- changing/adding dependencies in the project's .cabal file. In +-- those cases, a full recompile will be needed. +loadSnapTH :: Q Exp -- ^ the initializer expression + -> Name -- ^ the name of the load function + -> [String] -- ^ a list of directories to watch in addition + -- to those containing code + -> Q Exp +loadSnapTH initializer action additionalWatchDirs = do + args <- runIO getArgs + + let opts = getHintOpts args + srcPaths = additionalWatchDirs ++ getSrcPaths args + + -- The first line is an extra type check to ensure the provided + -- names refer to expressions with the correct types + [| do let _ = $initializer >>= $(varE action) + v <- $initializer + (handler, cleanup) <- hintSnap opts actMods srcPaths loadStr v + return (v, handler, cleanup) |] + where + actMods = maybeToList $ nameModule action + loadStr = nameBase action + + +------------------------------------------------------------------------------ +-- | Convert the command-line arguments passed in to options for the +-- hint interpreter. This is somewhat brittle code, based on a few +-- experimental datapoints regarding the structure of the command-line +-- arguments cabal produces. +getHintOpts :: [String] -> [String] +getHintOpts args = removeBad opts + where + bad = ["-threaded", "-O"] + removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad) + + hideAll = filter (== "-hide-all-packages") args + + srcOpts = filter (\x -> "-i" `isPrefixOf` x + && not ("-idist" `isPrefixOf` x)) args + + toCopy = filter (not . isSuffixOf ".hs") $ + dropWhile (not . ("-package" `isPrefixOf`)) args + copy = map (intercalate " ") . groupBy (\_ s -> not $ "-" `isPrefixOf` s) + + opts = hideAll ++ srcOpts ++ copy toCopy + + +------------------------------------------------------------------------------ +-- | This function extracts the source paths from the compilation args +getSrcPaths :: [String] -> [String] +getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg + where + srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x) + + +------------------------------------------------------------------------------ +-- | This function creates the Snap handler that actually is +-- responsible for doing the dynamic loading of actions via hint, +-- given all of the configuration information that the interpreter +-- needs. It also ensures safe concurrent access to the interpreter, +-- and caches the interpreter results for a short time before allowing +-- it to run again. +-- +-- Generally, this won't be called manually. Instead, loadSnapTH will +-- generate a call to it at compile-time, calculating all the +-- arguments from its environment. +hintSnap :: Typeable a + => [String] -- ^ A list of command-line options for the interpreter + -> [String] -- ^ A list of modules that need to be + -- interpreted. This should contain only the + -- modules which contain the initialization, + -- cleanup, and handler actions. Everything else + -- they require will be loaded transitively. + -> [String] -- ^ A list of paths to watch for updates + -> String -- ^ The name of the function to load + -> a -- ^ The value to apply the loaded function to + -> IO (Snap (), IO ()) +hintSnap opts modules srcPaths action value = + protectedHintEvaluator initialize test loader + where + witness x = undefined $ x `asTypeOf` value :: HintLoadable + + -- This is somewhat fragile, and probably can be cleaned up with a + -- future version of Typeable. For the moment, and + -- backwards-compatibility, this is the approach being taken. + witnessModules = map (reverse . drop 1 . dropWhile (/= '.') . reverse) . + filter (elem '.') . groupBy typePart . show . typeOf $ + witness + + typePart x y = (isAlphaNum x && isAlphaNum y) || x == '.' || y == '.' + + interpreter = do + loadModules . nub $ modules + setImports . nub $ "Prelude" : witnessModules ++ modules + + f <- interpret action witness + return $ f value + + loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter + + formatOnError (Left err) = error $ format err + formatOnError (Right a) = a + + loader = formatOnError `fmap` protectHandlers loadInterpreter + + initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths + + test (prevTime, ts) = do + now <- getCurrentTime + if diffUTCTime now prevTime < 3 + then return True + else checkTreeStatus ts + + +------------------------------------------------------------------------------ +-- | Convert an InterpreterError to a String for presentation +format :: InterpreterError -> String +format (UnknownError e) = "Unknown interpreter error:\r\n\r\n" ++ e +format (NotAllowed e) = "Interpreter action not allowed:\r\n\r\n" ++ e +format (GhcException e) = "GHC error:\r\n\r\n" ++ e +format (WontCompile errs) = "Compile errors:\r\n\r\n" ++ + (intercalate "\r\n" $ nub $ map errMsg errs) + diff --git a/src/Snap/Loader/Devel/Evaluator.hs b/src/Snap/Loader/Devel/Evaluator.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Loader/Devel/Evaluator.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Snap.Loader.Devel.Evaluator + ( HintLoadable + , protectedHintEvaluator + ) where + + +import Control.Exception +import Control.Monad (when) +import Control.Monad.Trans (liftIO) + +import Control.Concurrent (ThreadId, forkIO, myThreadId) +import Control.Concurrent.MVar + +import Prelude hiding (catch, init, any) + +import Snap.Core (Snap) + + +------------------------------------------------------------------------------ +-- | A type synonym to simply talking about the type loaded by hint. +type HintLoadable = IO (Snap (), IO ()) + + +------------------------------------------------------------------------------ +-- | Convert an action to generate 'HintLoadable's into Snap and IO +-- actions that handle periodic reloading. The resulting action will +-- share initialized state until the next execution of the input +-- action. At this time, the cleanup action will be executed. +-- +-- The first two arguments control when recompiles are done. The +-- first argument is an action that is executed when compilation +-- starts. The second is a function from the result of the first +-- action to an action that determines whether the value from the +-- previous compilation is still good. This abstracts out the +-- strategy for determining when a cached result is no longer valid. +-- +-- If an exception is raised during the processing of the action, it +-- will be thrown to all waiting threads, and for all requests made +-- before the recompile condition is reached. +protectedHintEvaluator :: forall a. + IO a + -> (a -> IO Bool) + -> IO HintLoadable + -> IO (Snap (), IO ()) +protectedHintEvaluator start test getInternals = do + -- The list of requesters waiting for a result. Contains the + -- ThreadId in case of exceptions, and an empty MVar awaiting a + -- successful result. + readerContainer <- newReaderContainer + + -- Contains the previous result and initialization value, and the + -- time it was stored, if a previous result has been computed. + -- The result stored is either the actual result and + -- initialization result, or the exception thrown by the + -- calculation. + resultContainer <- newResultContainer + + -- The model used for the above MVars in the returned action is + -- "keep them full, unless updating them." In every case, when + -- one of those MVars is emptied, the next action is to fill that + -- same MVar. This makes deadlocking on MVar wait impossible. + let snap = do + let waitForNewResult :: IO (Snap ()) + waitForNewResult = do + -- Need to calculate a new result + tid <- myThreadId + reader <- newEmptyMVar + + readers <- takeMVar readerContainer + + -- Some strictness is employed to ensure the MVar + -- isn't holding on to a chain of unevaluated thunks. + let pair = (tid, reader) + newReaders = readers `seq` pair `seq` (pair : readers) + putMVar readerContainer $! newReaders + + -- If this is the first reader to queue, clean up the + -- previous state, if there was any, and then begin + -- evaluation of the new code and state. + when (null readers) $ do + let runAndFill = block $ do + -- run the cleanup action + previous <- readMVar resultContainer + unblock $ cleanup previous + + -- compile the new internals and initialize + stateInitializer <- unblock getInternals + res <- unblock stateInitializer + + let a = fst res + + clearAndNotify (Right res) + (flip putMVar a . snd) + + killWaiting :: SomeException -> IO () + killWaiting e = block $ do + clearAndNotify (Left e) (flip throwTo e . fst) + throwIO e + + clearAndNotify r f = do + a <- unblock start + _ <- swapMVar resultContainer $ Just (r, a) + allReaders <- swapMVar readerContainer [] + mapM_ f allReaders + + _ <- forkIO $ runAndFill `catch` killWaiting + return () + + -- Wait for the evaluation of the action to complete, + -- and return its result. + takeMVar reader + + existingResult <- liftIO $ readMVar resultContainer + + getResult <- liftIO $ case existingResult of + Just (res, a) -> do + -- There's an existing result. Check for validity + valid <- test a + case (valid, res) of + (True, Right (x, _)) -> return x + (True, Left e) -> throwIO e + (False, _) -> waitForNewResult + Nothing -> waitForNewResult + getResult + + clean = do + let msg = "invalid dynamic loader state. " ++ + "The cleanup action has been executed" + contents <- swapMVar resultContainer $ error msg + cleanup contents + + return (snap, clean) + where + newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))]) + newReaderContainer = newMVar [] + + newResultContainer :: IO (MVar (Maybe (Either SomeException + (Snap (), IO ()), a))) + newResultContainer = newMVar Nothing + + cleanup (Just (Right (_, clean), _)) = clean + cleanup _ = return () diff --git a/src/Snap/Loader/Devel/Signal.hs b/src/Snap/Loader/Devel/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Loader/Devel/Signal.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +module Snap.Loader.Devel.Signal (protectHandlers) where + +import Control.Exception (bracket) + +#ifdef mingw32_HOST_OS +import GHC.ConsoleHandler as C + + +saveHandlers :: IO C.Handler +saveHandlers = C.installHandler Ignore + + +restoreHandlers :: C.Handler -> IO C.Handler +restoreHandlers = C.installHandler + + +#else +import qualified System.Posix.Signals as S + +helper :: S.Handler -> S.Signal -> IO S.Handler +helper handler signal = S.installHandler signal handler Nothing + + +signals :: [S.Signal] +signals = [ S.sigQUIT + , S.sigINT + , S.sigHUP + , S.sigTERM + ] + + +saveHandlers :: IO [S.Handler] +saveHandlers = mapM (helper S.Ignore) signals + + +restoreHandlers :: [S.Handler] -> IO [S.Handler] +restoreHandlers h = sequence $ zipWith helper h signals + + +#endif +protectHandlers :: IO a -> IO a +protectHandlers a = bracket saveHandlers restoreHandlers $ const a diff --git a/src/Snap/Loader/Devel/TreeWatcher.hs b/src/Snap/Loader/Devel/TreeWatcher.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Loader/Devel/TreeWatcher.hs @@ -0,0 +1,41 @@ +module Snap.Loader.Devel.TreeWatcher + ( TreeStatus + , getTreeStatus + , checkTreeStatus + ) where + +import Control.Applicative + +import System.Directory +import System.Directory.Tree + +import System.Time + + +------------------------------------------------------------------------------ +-- | An opaque representation of the contents and last modification +-- times of a forest of directory trees. +data TreeStatus = TS [FilePath] [AnchoredDirTree ClockTime] + + +------------------------------------------------------------------------------ +-- | Create a 'TreeStatus' for later checking with 'checkTreeStatus' +getTreeStatus :: [FilePath] -> IO TreeStatus +getTreeStatus = liftA2 (<$>) TS readModificationTimes + + +------------------------------------------------------------------------------ +-- | Checks that all the files present in the initial set of paths are +-- the exact set of files currently present, with unchanged modifcations times +checkTreeStatus :: TreeStatus -> IO Bool +checkTreeStatus (TS paths entries) = check <$> readModificationTimes paths + where + check = and . zipWith (==) entries + + +------------------------------------------------------------------------------ +-- | This is the core of the functions in this module. It converts a +-- list of filepaths into a list of 'AnchoredDirTree' annotated with +-- the modification times of the files located in those paths. +readModificationTimes :: [FilePath] -> IO [AnchoredDirTree ClockTime] +readModificationTimes = mapM $ readDirectoryWith getModificationTime diff --git a/src/Snap/Loader/Prod.hs b/src/Snap/Loader/Prod.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Loader/Prod.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} +module Snap.Loader.Prod + ( loadSnapTH + ) where + +import Language.Haskell.TH + + +------------------------------------------------------------------------------ +-- | This function provides a non-magical type-compatible loader for +-- the one in Snap.Loader.Devel, allowing switching one import to +-- provide production-mode compilation. +-- +-- This could be considered a TH wrapper around a function +-- +-- > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ())) +-- > -> [String] -> IO (a, Snap (), IO ()) +-- +-- The third argument is unused, and only present for +-- type-compatibility with Snap.Loader.Devel +loadSnapTH :: Q Exp -> Name -> [String] -> Q Exp +loadSnapTH initializer action _additionalWatchDirs = + [| do value <- $initializer + (site, conf) <- $(varE action) value + return (value, site, conf) |] diff --git a/src/Snap/Snaplet.hs b/src/Snap/Snaplet.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +{-| + +Snaplets allow you to build web applications out of composable parts. This +allows you to build self-contained units and glue them together to make your +overall application. + +A snaplet has a few moving parts, some user-defined and some provided by the +snaplet API: + + * each snaplet has its own configuration given to it at startup. + + * each snaplet is given its own directory on the filesystem, from which it + reads its configuration and in which it can store files. + + * each snaplet comes with an 'Initializer' which defines how to create an + instance of the Snaplet at startup. The initializer decides how to + interpret the snaplet configuration, which URLs to handle (and how), sets + up the initial snaplet state, tells the snaplet runtime system how to + clean the snaplet up, etc. + + * each snaplet contains some user-defined in-memory state; for instance, a + snaplet that talks to a database might contain a reference to a connection + pool. The snaplet state is an ordinary Haskell record, with a datatype + defined by the snaplet author. The initial state record is created during + initialization and is available to snaplet 'Handler's when serving HTTP + requests. + +NOTE: This documentation is written as a prose tutorial of the snaplets +API. Don't be scared by the fact that it's auto-generated and is filled with +type signatures. Just keep reading. + +-} + +module Snap.Snaplet + ( + -- * Snaplet + -- $snapletDoc + Snaplet + , SnapletConfig + + -- * Snaplet Helper Functions + -- $snapletHelpers + , snapletConfig + , snapletValue + , subSnaplet + + -- * Lenses + -- $lenses + + -- * MonadSnaplet + -- $monadSnaplet + , MonadSnaplet(..) + , getSnapletAncestry + , getSnapletFilePath + , getSnapletName + , getSnapletDescription + , getSnapletUserConfig + , getSnapletRootURL + + -- * Snaplet state manipulation + -- $snapletState + , getSnapletState + , putSnapletState + , modifySnapletState + , getsSnapletState + +-- , wrap +-- , wrapTop + + -- * Initializer + -- $initializer + , Initializer + , SnapletInit + , makeSnaplet + + , nestSnaplet + , embedSnaplet + , nameSnaplet + + , onUnload + , addPostInitHook + , addPostInitHookBase + , printInfo + + -- * Routes + -- $routes + , addRoutes + , wrapHandlers + + -- * Handlers + , Handler + , reloadSite + + -- * Serving Applications + , runSnaplet + , combineConfig + , serveSnaplet + ) where + + +import Snap.Snaplet.Internal.Initializer +import Snap.Snaplet.Internal.Types + +-- $snapletDoc +-- The heart of the snaplets infrastructure is state management. (Note: when +-- we say \"state\" here, we mean in-memory Haskell objects, not external data +-- storage or databases; how you deal with persisted data is up to you.) Most +-- nontrivial pieces of a web application need some kind of runtime state or +-- environment data. The datatype we use to handle this is called 'Snaplet': + +-- $snapletHelpers +-- +-- Your web application will itself get wrapped in a 'Snaplet', and the +-- top-level user state of your application (which will likely contain other +-- snaplets nested inside it) will look something like this: +-- +-- > data App = App +-- > { _foo :: Snaplet Foo +-- > , _bar :: Snaplet Bar +-- > , _someNonSnapletData :: String +-- > } +-- +-- Every web application using snaplets has a top-most user state which +-- contains all of the application state; we call this state the \"base\" +-- state. +-- +-- We provide a couple of helper functions for working with Snaplet types. + +-- $lenses +-- In the example above, the @Foo@ snaplet has to be written to work with any +-- base state (otherwise it wouldn't be reusable!), but functions written to +-- work with the @Foo@ snaplet want to be able to modify the @Foo@ record +-- /within the context/ of the base state. Given that Haskell datatypes are +-- pure, how do you allow for this? +-- +-- Our solution is to use /lenses/, as defined in the @data-lens@ library +-- (). A lens, notated as +-- follows: +-- +-- > Lens a b +-- +-- is a \"getter\" and a \"setter\" rolled up into one. The @data-lens@ +-- library provides the following functions: +-- +-- > getL :: (Lens a b) -> a -> b +-- > setL :: (Lens a b) -> b -> a -> a +-- > modL :: (Lens a b) -> (b -> b) -> a -> a +-- +-- which allow you to get, set, and modify a value of type @b@ within the +-- context of type of type @a@. The @data-lens@ package comes with a Template +-- Haskell function called 'makeLenses', which auto-magically defines a lens +-- for every record field having a name beginning with an underscore. In the +-- @App@ example above, adding the declaration: +-- +-- > makeLenses [''App] +-- +-- would define lenses: +-- +-- > foo :: Lens App (Snaplet Foo) +-- > bar :: Lens App (Snaplet Bar) +-- > someNonSnapletData :: Lens App String +-- +-- The coolest thing about @data-lens@ lenses is that they /compose/, using +-- the "Control.Category"'s generalization of the @(.)@ operator. If the @Foo@ +-- type had a field of type @Quux@ within it with a lens @quux :: Lens Foo +-- Quux@, then you could create a lens of type @Lens App Quux@ by composition: +-- +-- > import Control.Category +-- > import Prelude hiding ((.)) -- you have to hide (.) from the Prelude +-- > -- to use Control.Category.(.) +-- > +-- > data Foo = Foo { _quux :: Quux } +-- > makeLenses [''Foo] +-- > +-- > -- snapletValue is defined in the framework: +-- > snapletValue :: Lens (Snaplet a) a +-- > +-- > appQuuxLens :: Lens App (Snaplet Quux) +-- > appQuuxLens = quux . snapletValue . foo +-- +-- Lens composition is very similar to function composition, but it gives you +-- a composed getter and setter at the same time. + +-- $monadSnaplet +-- The primary abstraction in the snaplet infrastructure is a combination of +-- the reader and state monads. The state monad holds the top level +-- application data type (from now on referred to as the base state). The +-- reader monad holds a lens from the base state to the current snaplet's +-- state. This allows quux snaplet functions to access and modify the Quux +-- data structure without knowing anything about the App or Foo data +-- structures. It also lets other snaplets call functions from the quux +-- snaplet if they have the quux snaplet's lens @Lens App (Snaplet Quux)@. +-- We can view our application as a tree of snaplets and other pieces of data. +-- The lenses are like pointers to nodes of the tree. If you have a pointer to +-- a node, you can access the node and all of its children without knowing +-- anything about the rest of the tree. +-- +-- Several monads use this infrastructure. These monads need at least three +-- type parameters. Two for the lens type, and the standard \'a\' denoting the +-- monad return value. You will usually see this written in type signatures as +-- \"m b v a\" or some variation. The \'m\' is the type variable of the +-- MonadSnaplet type class. \'b\' is the base state, and \'v\' is the state of +-- the current \"view\" snaplet (or simply, current state). +-- +-- The MonadSnaplet type class distills the essence of the operations used +-- with this pattern. Its functions define fundamental methods for navigating +-- snaplet trees. + +-- $snapletState +-- MonadSnaplet instances will typically have @MonadState v@ instances. We +-- provide the following convenience functions which give the equivalent to +-- @MonadState (Snaplet v)@ for the less common cases where you need to work +-- with the Snaplet wrapper. + +-- $initializer +-- The Initializer monad is where your application's initialization happens. +-- Initializers are run at startup and any time a site reload is triggered. +-- The Initializer's job is to construct a snaplet's routes and initial state, +-- set up filesystem data, read config files, etc. +-- +-- In order to initialize its state, a snaplet needs to initialize all the +-- @Snaplet a@ state for each of its subsnaplets. The only way to construct +-- a @Snaplet a@ type is by calling 'nestSnaplet' or 'embedSnaplet' from +-- within an initializer. + + +-- $writingSnaplets +-- When writing a snaplet, you must define an initializer function. The +-- initializer function for the Foo snaplet (where Foo is the snaplet's +-- state type) must have a return type of @Initializer b Foo Foo@. +-- To create an initializer like this, you have to use the 'makeSnaplet' +-- function. It takes care of the necessary internal bookkeeping needed when +-- initializing a new snaplet. Haskell's strong type system allows us to +-- ensure that calling 'makeSnaplet' is the only way you can construct a +-- Snaplet type. + + +-- $routes +-- Snaplet initializers are also responsible for setting up any routes defined +-- by the snaplet. To do that you'll usually use either 'addRoutes' or +-- 'wrapHandlers'. + + +{- + + +/FIXME/: finish this section + + +Discuss: + + * lenses and how snaplet apps are built out of parts. + + * the initializer type, and what you can do with it + + * layout of snaplets on disk, and how on-disk stuff can be auto-populated + from the cabal data directory + + * the handler type, and what you can do with it + + + + +{FIXME: strike/rewrite these sentences. Components that do not need any kind +of state or environment are probably more appropriate as a standalone +library than as a snaplet. + +We start our application by defining a data structure to hold the state. +This data structure includes the state of any snaplets (wrapped in a +Snaplet) we want to use as well as any other state we might want.} + +> module MyApp where +> import Snap.Snaplet +> import Snap.Snaplet.Heist +> +> data App = App +> { _heist :: Snaplet (Heist App) +> , _foo :: Snaplet Foo +> , _bar :: Snaplet Bar +> , _companyName :: String +> } +> +> makeLenses [''App] + +The next thing we need to do is define an initializer. + +> app :: Initializer App App App +> app = do +> hs <- nestSnaplet "heist" $ heistInit "templates" +> fs <- nestSnaplet "foo" $ fooInit heist +> bs <- nestSnaplet "" $ nameSnaplet "baz" $ barInit heist +> addRoutes [ ("/hello", writeText "hello world") +> ] +> wrapHandlers (<|> with heist heistServe) +> return $ App hs fs bs "fooCorp" + +Then we define a simple main to run the application. + +> main = serveSnaplet defaultConfig app + + + +Snaplet filesystem directory structure: + +> snaplet +> |-- snaplet.cabal +> |-- log/ +> |-- src/ +> ------------------------ +> |-- db.cfg +> |-- snaplet.cfg +> |-- public/ +> |-- stylesheets/ +> |-- images/ +> |-- js/ +> |-- snaplets +> |-- subsnaplet1/ +> |-- subsnaplet2/ +> |-- templates/ + +-} + diff --git a/src/Snap/Snaplet/Auth.hs b/src/Snap/Snaplet/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| + + This module contains all the central authentication functionality. + + It exports a number of high-level functions to be used directly in your + application handlers. + + We also export a number of mid-level functions that + should be helpful when you are integrating with another way of confirming + the authentication of login requests. + +-} + +module Snap.Snaplet.Auth + ( + + -- * Higher Level Handler Functions + createUser + , usernameExists + , saveUser + , destroyUser + , loginByUsername + , loginByRememberToken + , forceLogin + , logout + , currentUser + , isLoggedIn + + -- * Lower Level Functions + , markAuthSuccess + , markAuthFail + , checkPasswordAndLogin + + -- * Types + , AuthManager(..) + , IAuthBackend(..) + , AuthSettings(..) + , defAuthSettings + , AuthUser(..) + , defAuthUser + , UserId(..) + , Password(..) + , AuthFailure(..) + , BackendError(..) + , Role(..) + + -- * Other Utilities + , withBackend + , encryptPassword + , checkPassword + , authenticatePassword + , setPassword + + -- * Handlers + , registerUser + , loginUser + , logoutUser + , requireUser + + -- * Splice helpers + , addAuthSplices + , ifLoggedIn + , ifLoggedOut + ) + where + +import Snap.Snaplet.Auth.AuthManager +import Snap.Snaplet.Auth.Handlers +import Snap.Snaplet.Auth.SpliceHelpers +import Snap.Snaplet.Auth.Types + diff --git a/src/Snap/Snaplet/Auth/AuthManager.hs b/src/Snap/Snaplet/Auth/AuthManager.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/AuthManager.hs @@ -0,0 +1,102 @@ + +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Snap.Snaplet.Auth.AuthManager + +( + -- * AuthManager Datatype + AuthManager(..) + + -- * Backend Typeclass + , IAuthBackend(..) + + -- * Context-free Operations + , buildAuthUser + +) where + + +import Data.ByteString (ByteString) +import Data.Lens.Lazy +import Data.Time +import Data.Text (Text) +import Web.ClientSession + +import Snap.Snaplet +import Snap.Snaplet.Session +import Snap.Snaplet.Auth.Types + +------------------------------------------------------------------------------ +-- | Create a new user from just a username and password +-- +-- May throw a "DuplicateLogin" if given username is not unique +buildAuthUser + :: (IAuthBackend r) + => r + -- ^ An auth backend + -> Text + -- ^ Username + -> ByteString + -- ^ Password + -> IO AuthUser +buildAuthUser r unm pass = do + now <- getCurrentTime + let au = defAuthUser { + userLogin = unm + , userPassword = Nothing + , userCreatedAt = Just now + , userUpdatedAt = Just now + } + au' <- setPassword au pass + save r au' + + +------------------------------------------------------------------------------ +-- | All storage backends need to implement this typeclass +-- +-- Backend operations may throw 'BackendError's +class IAuthBackend r where + + -- | Needs to create or update the given 'AuthUser' record + save :: r -> AuthUser -> IO AuthUser + + lookupByUserId :: r -> UserId -> IO (Maybe AuthUser) + + lookupByLogin :: r -> Text -> IO (Maybe AuthUser) + + lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser) + + destroy :: r -> AuthUser -> IO () + + +------------------------------------------------------------------------------ +-- | Abstract data type holding all necessary information for auth operation +data AuthManager b = forall r. IAuthBackend r => AuthManager { + backend :: r + -- ^ Storage back-end + + , session :: Lens b (Snaplet SessionManager) + -- ^ A lens pointer to a SessionManager + + , activeUser :: Maybe AuthUser + -- ^ A per-request logged-in user cache + + , minPasswdLen :: Int + -- ^ Password length range + + , rememberCookieName :: ByteString + -- ^ Cookie name for the remember token + + , rememberPeriod :: Maybe Int + -- ^ Remember period in seconds. Defaults to 2 weeks. + + , siteKey :: Key + -- ^ A unique encryption key used to encrypt remember cookie + + , lockout :: Maybe (Int, NominalDiffTime) + -- ^ Lockout after x tries, re-allow entry after y seconds + } + diff --git a/src/Snap/Snaplet/Auth/Backends/JsonFile.hs b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Backends/JsonFile.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + + +module Snap.Snaplet.Auth.Backends.JsonFile + ( initJsonFileAuthManager + , mkJsonAuthMgr + ) where + + +import Control.Applicative +import Control.Monad.CatchIO (throw) +import Control.Monad.State +import Control.Concurrent.STM +import Data.Aeson +import qualified Data.Attoparsec as Atto +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString as B +import qualified Data.Map as HM +import Data.Map (Map) +import Data.Maybe (fromJust, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Lens.Lazy +import Data.Time +import Web.ClientSession +import System.Directory + +import Snap.Snaplet +import Snap.Snaplet.Auth.Types +import Snap.Snaplet.Auth.AuthManager +import Snap.Snaplet.Session + + + +------------------------------------------------------------------------------ +-- | Initialize a JSON file backed 'AuthManager' +initJsonFileAuthManager + :: AuthSettings + -- ^ Authentication settings for your app + -> Lens b (Snaplet SessionManager) + -- ^ Lens into a 'SessionManager' auth snaplet will use + -> FilePath + -- ^ Where to store user data as JSON + -> SnapletInit b (AuthManager b) +initJsonFileAuthManager s l db = + makeSnaplet "JsonFileAuthManager" + "A snaplet providing user authentication using a JSON-file backend" + Nothing $ liftIO $ do + key <- getKey (asSiteKey s) + jsonMgr <- mkJsonAuthMgr db + return $ AuthManager { + backend = jsonMgr + , session = l + , activeUser = Nothing + , minPasswdLen = asMinPasswdLen s + , rememberCookieName = asRememberCookieName s + , rememberPeriod = asRememberPeriod s + , siteKey = key + , lockout = asLockout s + } + + +------------------------------------------------------------------------------ +-- | Load/create a datafile into memory cache and return the manager. +-- +-- This data type can be used by itself for batch/non-handler processing. +mkJsonAuthMgr :: FilePath -> IO JsonFileAuthManager +mkJsonAuthMgr fp = do + db <- loadUserCache fp + let db' = case db of + Left e -> error e + Right x -> x + cache <- newTVarIO db' + return $ JsonFileAuthManager { + memcache = cache + , dbfile = fp + } + + +type UserIdCache = Map UserId AuthUser + + +instance ToJSON UserIdCache where + toJSON m = toJSON $ HM.toList m + + +instance FromJSON UserIdCache where + parseJSON = fmap HM.fromList . parseJSON + + +type LoginUserCache = Map Text UserId + + +type RemTokenUserCache = Map Text UserId + + +-- JSON user back-end stores the user data and indexes for login and token +-- based logins. +data UserCache = UserCache { + uidCache :: UserIdCache -- the actual datastore + , loginCache :: LoginUserCache -- fast lookup for login field + , tokenCache :: RemTokenUserCache -- fast lookup for remember tokens + , uidCounter :: Int -- user id counter +} + + +defUserCache :: UserCache +defUserCache = UserCache { + uidCache = HM.empty + , loginCache = HM.empty + , tokenCache = HM.empty + , uidCounter = 0 +} + + +loadUserCache :: FilePath -> IO (Either String UserCache) +loadUserCache fp = do + chk <- doesFileExist fp + case chk of + True -> do + d <- B.readFile fp + case Atto.parseOnly json d of + Left e -> return . Left $ "Can't open JSON auth backend. Error: " ++ e + Right v -> case fromJSON v of + Error e -> return . Left $ + "Malformed JSON auth data store. Error: " ++ e + Success db -> return $ Right db + False -> do + putStrLn "User JSON datafile not found. Creating a new one." + return $ Right defUserCache + + +data JsonFileAuthManager = JsonFileAuthManager { + memcache :: TVar UserCache + , dbfile :: FilePath +} + + +instance IAuthBackend JsonFileAuthManager where + + save mgr u = do + now <- getCurrentTime + oldByLogin <- lookupByLogin mgr (userLogin u) + oldById <- case userId u of + Nothing -> return Nothing + Just x -> lookupByUserId mgr x + res <- atomically $ do + cache <- readTVar (memcache mgr) + res <- case userId u of + Nothing -> create cache now oldByLogin + Just _ -> update cache now oldById + case res of + Left e -> return $ Left e + Right (cache', u') -> do + writeTVar (memcache mgr) cache' + return $ Right (cache', u') + case res of + Left e -> throw e + Right (cache', u') -> do + dumpToDisk cache' + return u' + where + create + :: UserCache + -> UTCTime + -> (Maybe AuthUser) + -> STM (Either BackendError (UserCache, AuthUser)) + create cache now old = do + case old of + Just _ -> return $ Left DuplicateLogin + Nothing -> do + new <- do + let uid' = UserId . showT $ uidCounter cache + 1 + let u' = u { userUpdatedAt = Just now, userId = Just uid' } + return $ cache { + uidCache = HM.insert uid' u' $ uidCache cache + , loginCache = HM.insert (userLogin u') uid' $ loginCache cache + , tokenCache = case userRememberToken u' of + Nothing -> tokenCache cache + Just x -> HM.insert x uid' $ tokenCache cache + , uidCounter = uidCounter cache + 1 + } + return $ Right (new, getLastUser new) + + + -- lookup old record, see what's changed and update indexes accordingly + update + :: UserCache + -> UTCTime + -> (Maybe AuthUser) + -> STM (Either BackendError (UserCache, AuthUser)) + update cache now old = + case old of + Nothing -> return $ Left $ + BackendError "User not found; should never happen" + Just x -> do + let oldLogin = userLogin x + let oldToken = userRememberToken x + let uid = fromJust $ userId u + let newLogin = userLogin u + let newToken = userRememberToken u + let lc = if oldLogin /= userLogin u + then HM.insert newLogin uid . HM.delete oldLogin $ + loginCache cache + else loginCache cache + let tc = if oldToken /= newToken && isJust oldToken + then HM.delete (fromJust oldToken) $ loginCache cache + else tokenCache cache + let tc' = case newToken of + Just t -> HM.insert t uid tc + Nothing -> tc + let u' = u { userUpdatedAt = Just now } + let new = cache { + uidCache = HM.insert uid u' $ uidCache cache + , loginCache = lc + , tokenCache = tc' + } + return $ Right (new, u') + + -- Sync user database to disk + -- Need to implement a mutex here; simult syncs could screw things up + dumpToDisk c = LB.writeFile (dbfile mgr) (encode c) + + -- Get's the last added user + getLastUser cache = maybe e id $ getUser cache uid + where uid = UserId . showT $ uidCounter cache + e = error "getLastUser failed. This should not happen." + + + destroy = error "JsonFile: destroy is not yet implemented" + + lookupByUserId mgr uid = withCache mgr f + where f cache = getUser cache uid + + lookupByLogin mgr login = withCache mgr f + where + f cache = getUid >>= getUser cache + where getUid = HM.lookup login (loginCache cache) + + lookupByRememberToken mgr token = withCache mgr f + where + f cache = getUid >>= getUser cache + where getUid = HM.lookup token (tokenCache cache) + + +withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a +withCache mgr f = atomically $ do + cache <- readTVar $ memcache mgr + return $ f cache + + +getUser :: UserCache -> UserId -> Maybe AuthUser +getUser cache uid = HM.lookup uid (uidCache cache) + + +------------------------------------------------------------------------------ +-- JSON Instances +-- +------------------------------------------------------------------------------ + + +instance ToJSON UserCache where + toJSON uc = object + [ "uidCache" .= uidCache uc + , "loginCache" .= loginCache uc + , "tokenCache" .= tokenCache uc + , "uidCounter" .= uidCounter uc] + + +instance FromJSON UserCache where + parseJSON (Object v) = + UserCache + <$> v .: "uidCache" + <*> v .: "loginCache" + <*> v .: "tokenCache" + <*> v .: "uidCounter" + parseJSON _ = error "Unexpected JSON input" + +instance ToJSON AuthUser where + toJSON u = object + [ "uid" .= userId u + , "login" .= userLogin u + , "pw" .= userPassword u + , "activated_at" .= userActivatedAt u + , "suspended_at" .= userSuspendedAt u + , "remember_token" .= userRememberToken u + , "login_count" .= userLoginCount u + , "failed_login_count" .= userFailedLoginCount u + , "locked_until" .= userLockedOutUntil u + , "current_login_at" .= userCurrentLoginAt u + , "last_login_at" .= userLastLoginAt u + , "current_ip" .= userCurrentLoginIp u + , "last_ip" .= userLastLoginIp u + , "created_at" .= userCreatedAt u + , "updated_at" .= userUpdatedAt u + , "meta" .= userMeta u ] + + +instance FromJSON AuthUser where + parseJSON (Object v) = AuthUser + <$> v .: "uid" + <*> v .: "login" + <*> v .: "pw" + <*> v .: "activated_at" + <*> v .: "suspended_at" + <*> v .: "remember_token" + <*> v .: "login_count" + <*> v .: "failed_login_count" + <*> v .: "locked_until" + <*> v .: "current_login_at" + <*> v .: "last_login_at" + <*> v .: "current_ip" + <*> v .: "last_ip" + <*> v .: "created_at" + <*> v .: "updated_at" + <*> return [] + <*> v .: "meta" + parseJSON _ = error "Unexpected JSON input" + + +instance ToJSON Password where + toJSON (Encrypted x) = toJSON x + toJSON (ClearText _) = + error "ClearText passwords can't be serialized into JSON" + + +instance FromJSON Password where + parseJSON = fmap Encrypted . parseJSON + + +showT :: Int -> Text +showT = T.pack . show diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Handlers.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +{-| + + Pre-packaged Handlers that deal with form submissions and standard use-cases + involving authentication. + +-} + +module Snap.Snaplet.Auth.Handlers where + +import Control.Applicative +import Control.Monad.CatchIO (throw) +import Control.Monad.State +import Data.ByteString (ByteString) +import Data.Lens.Lazy +import Data.Maybe (isJust) +import Data.Serialize hiding (get) +import Data.Time +import Data.Text.Encoding (decodeUtf8) +import Data.Text (Text) +import Web.ClientSession + +import Snap.Core +import Snap.Snaplet +import Snap.Snaplet.Auth.AuthManager +import Snap.Snaplet.Auth.Types +import Snap.Snaplet.Session +import Snap.Snaplet.Session.Common +import Snap.Snaplet.Session.SecureCookie + + + +------------------------------------------------------------------------------ +-- Higher level functions +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | Create a new user from just a username and password +-- +-- May throw a "DuplicateLogin" if given username is not unique +createUser + :: Text -- Username + -> ByteString -- Password + -> Handler b (AuthManager b) AuthUser +createUser unm pwd = withBackend (\r -> liftIO $ buildAuthUser r unm pwd) + +------------------------------------------------------------------------------ +-- | Check whether a user with the given username exists. +usernameExists + :: Text + -- ^ The username to be checked + -> Handler b (AuthManager b) Bool +usernameExists username = withBackend $ + \r -> liftIO $ isJust <$> lookupByLogin r username + +------------------------------------------------------------------------------ +-- | Lookup a user by her username, check given password and perform login +loginByUsername + :: ByteString -- ^ Username/login for user + -> Password -- ^ Should be ClearText + -> Bool -- ^ Set remember token? + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +loginByUsername _ (Encrypted _) _ = + error "Cannot login with encrypted password" +loginByUsername unm pwd rm = do + sk <- gets siteKey + cn <- gets rememberCookieName + rp <- gets rememberPeriod + withBackend $ loginByUsername' sk cn rp + where + loginByUsername' :: (IAuthBackend t) + => Key -> ByteString -> Maybe Int -> t + -> Handler b (AuthManager b) + (Either AuthFailure AuthUser) + loginByUsername' sk cn rp r = do + au <- liftIO $ lookupByLogin r (decodeUtf8 unm) + case au of + Nothing -> return $ Left UserNotFound + Just au' -> do + res <- checkPasswordAndLogin au' pwd + case res of + Left e -> return $ Left e + Right au'' -> do + case rm of + True -> do + token <- liftIO $ randomToken 64 + setRememberToken sk cn rp token + let au''' = au'' + { userRememberToken = Just (decodeUtf8 token) } + saveUser au''' + return $ Right au''' + False -> return $ Right au'' + + +------------------------------------------------------------------------------ +-- | Remember user from the remember token if possible and perform login +loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser) +loginByRememberToken = withBackend $ \r -> do + sk <- gets siteKey + rc <- gets rememberCookieName + rp <- gets rememberPeriod + token <- getRememberToken sk rc rp + au <- maybe (return Nothing) + (liftIO . lookupByRememberToken r . decodeUtf8) token + case au of + Just au' -> forceLogin au' >> return au + Nothing -> return Nothing + + +------------------------------------------------------------------------------ +-- | Logout the active user +logout :: Handler b (AuthManager b) () +logout = do + s <- gets session + withTop s $ withSession s removeSessionUserId + rc <- gets rememberCookieName + forgetRememberToken rc + modify (\mgr -> mgr { activeUser = Nothing } ) + + +------------------------------------------------------------------------------ +-- | Return the current user; trying to remember from cookie if possible. +currentUser :: Handler b (AuthManager b) (Maybe AuthUser) +currentUser = cacheOrLookup $ withBackend $ \r -> do + s <- gets session + uid <- withTop s getSessionUserId + case uid of + Nothing -> loginByRememberToken + Just uid' -> liftIO $ lookupByUserId r uid' + + +------------------------------------------------------------------------------ +-- | Convenience wrapper around 'rememberUser' that returns a bool result +isLoggedIn :: Handler b (AuthManager b) Bool +isLoggedIn = isJust `fmap` currentUser + + +------------------------------------------------------------------------------ +-- | Create or update a given user +-- +-- May throw a 'BackendError' if something goes wrong. +saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser +saveUser u = withBackend $ liftIO . flip save u + + +------------------------------------------------------------------------------ +-- | Destroy the given user +-- +-- May throw a 'BackendError' if something goes wrong. +destroyUser :: AuthUser -> Handler b (AuthManager b) () +destroyUser u = withBackend $ liftIO . flip destroy u + + +------------------------------------------------------------------------------ +-- Lower level helper functions +-- +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | Mutate an 'AuthUser', marking failed authentication +-- +-- This will save the user to the backend. +markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser +markAuthFail u = withBackend $ \r -> do + lo <- gets lockout + incFailCtr u >>= checkLockout lo >>= liftIO . save r + where + incFailCtr u' = return $ u' + { userFailedLoginCount = userFailedLoginCount u' + 1} + checkLockout lo u' = case lo of + Nothing -> return u' + Just (mx, wait) -> + if userFailedLoginCount u' >= mx + then do + now <- liftIO getCurrentTime + let reopen = addUTCTime wait now + return $ u' { userLockedOutUntil = Just reopen } + else return u' + + +------------------------------------------------------------------------------ +-- | Mutate an 'AuthUser', marking successful authentication +-- +-- This will save the user to the backend. +markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser +markAuthSuccess u = withBackend $ \r -> do + incLoginCtr u >>= updateIp >>= updateLoginTS + >>= resetFailCtr >>= liftIO . save r + where + incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 } + updateIp u' = do + ip <- rqRemoteAddr `fmap` getRequest + return $ u' { userLastLoginIp = userCurrentLoginIp u' + , userCurrentLoginIp = Just ip } + updateLoginTS u' = do + now <- liftIO getCurrentTime + return $ + u' { userCurrentLoginAt = Just now + , userLastLoginAt = userCurrentLoginAt u' } + resetFailCtr u' = return $ + u' { userFailedLoginCount = 0 + , userLockedOutUntil = Nothing } + + +------------------------------------------------------------------------------ +-- | Authenticate and log the user into the current session if successful. +-- +-- This is a mid-level function exposed to allow roll-your-own ways of looking +-- up a user from the database. +-- +-- This function will: +-- +-- 1. Check the password +-- +-- 2. Login the user into the current session +-- +-- 3. Mark success/failure of the authentication trial on the user record +checkPasswordAndLogin + :: AuthUser -- ^ An existing user, somehow looked up from db + -> Password -- ^ A ClearText password + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +checkPasswordAndLogin u pw = + case userLockedOutUntil u of + Just x -> do + now <- liftIO getCurrentTime + if now > x + then auth u + else return . Left $ LockedOut x + Nothing -> auth u + where + auth user = + case authenticatePassword user pw of + Just e -> do + markAuthFail user + return $ Left e + Nothing -> do + forceLogin user + modify (\mgr -> mgr { activeUser = Just user }) + user' <- markAuthSuccess user + return $ Right user' + + +------------------------------------------------------------------------------ +-- | Login and persist the given 'AuthUser' in the active session +-- +-- Meant to be used if you have other means of being sure that the person is +-- who she says she is. +forceLogin + :: AuthUser + -- ^ An existing user, somehow looked up from db + -> Handler b (AuthManager b) (Either AuthFailure AuthUser) +forceLogin u = do + s <- gets session + withSession s $ do + case userId u of + Just x -> do + withTop s (setSessionUserId x) + return $ Right u + Nothing -> return . Left $ + AuthError "forceLogin: Can't force the login of a user without userId" + + +------------------------------------------------------------------------------ +-- Internal, non-exported helpers +-- +------------------------------------------------------------------------------ + + +getRememberToken :: (Serialize t, MonadSnap m) + => Key + -> ByteString + -> Maybe Int + -> m (Maybe t) +getRememberToken sk rc rp = getSecureCookie rc sk rp + + +setRememberToken :: (Serialize t, MonadSnap m) + => Key + -> ByteString + -> Maybe Int + -> t + -> m () +setRememberToken sk rc rp token = setSecureCookie rc sk rp token + + +forgetRememberToken :: MonadSnap m => ByteString -> m () +forgetRememberToken rc = expireCookie rc (Just "/") + + +------------------------------------------------------------------------------ +-- | Set the current user's 'UserId' in the active session +setSessionUserId :: UserId -> Handler b SessionManager () +setSessionUserId (UserId t) = setInSession "__user_id" t + + +------------------------------------------------------------------------------ +-- | Remove 'UserId' from active session, effectively logging the user out. +removeSessionUserId :: Handler b SessionManager () +removeSessionUserId = deleteFromSession "__user_id" + + +------------------------------------------------------------------------------ +-- | Get the current user's 'UserId' from the active session +getSessionUserId :: Handler b SessionManager (Maybe UserId) +getSessionUserId = do + uid <- getFromSession "__user_id" + return $ uid >>= return . UserId + + +------------------------------------------------------------------------------ +-- | Check password for a given user. +-- +-- Returns "Nothing" if check is successful and an "IncorrectPassword" error +-- otherwise +authenticatePassword + :: AuthUser -- ^ Looked up from the back-end + -> Password -- ^ Check against this password + -> Maybe AuthFailure +authenticatePassword u pw = auth + where + auth = case userPassword u of + Nothing -> Just PasswordMissing + Just upw -> check $ checkPassword pw upw + check b = if b then Nothing else Just IncorrectPassword + + +------------------------------------------------------------------------------ +-- | Wrap lookups around request-local cache +cacheOrLookup + :: Handler b (AuthManager b) (Maybe AuthUser) + -- ^ Lookup action to perform if request local cache is empty + -> Handler b (AuthManager b) (Maybe AuthUser) +cacheOrLookup f = do + au <- gets activeUser + if isJust au + then return au + else do + au' <- f + modify (\mgr -> mgr { activeUser = au' }) + return au' + + +------------------------------------------------------------------------------ +-- | Register a new user by specifying login and password 'Param' fields +registerUser + :: ByteString -- Login field + -> ByteString -- Password field + -> Handler b (AuthManager b) AuthUser +registerUser lf pf = do + l <- fmap decodeUtf8 `fmap` getParam lf + p <- getParam pf + case liftM2 (,) l p of + Nothing -> throw PasswordMissing + Just (lgn, pwd) -> do + createUser lgn pwd + + +------------------------------------------------------------------------------ +-- | A 'MonadSnap' handler that processes a login form. +-- +-- The request paremeters are passed to 'performLogin' +loginUser + :: ByteString + -- ^ Username field + -> ByteString + -- ^ Password field + -> Maybe ByteString + -- ^ Remember field; Nothing if you want no remember function. + -> (AuthFailure -> Handler b (AuthManager b) ()) + -- ^ Upon failure + -> Handler b (AuthManager b) () + -- ^ Upon success + -> Handler b (AuthManager b) () +loginUser unf pwdf remf loginFail loginSucc = do + username <- getParam unf + password <- getParam pwdf + remember <- maybe False (=="1") `fmap` + maybe (return Nothing) getParam remf + mMatch <- case password of + Nothing -> return $ Left PasswordMissing + Just password' -> do + case username of + Nothing -> return . Left $ AuthError "Username is missing" + Just username' -> do + loginByUsername username' (ClearText password') remember + either loginFail (const loginSucc) mMatch + + +------------------------------------------------------------------------------ +-- | Simple handler to log the user out. Deletes user from session. +logoutUser + :: Handler b (AuthManager b) () + -- ^ What to do after logging out + -> Handler b (AuthManager b) () +logoutUser target = logout >> target + + +------------------------------------------------------------------------------ +-- | Require that an authenticated 'AuthUser' is present in the current +-- session. +-- +-- This function has no DB cost - only checks to see if a user_id is present +-- in the current session. +requireUser + :: Lens b (Snaplet (AuthManager b)) + -- Lens reference to an "AuthManager" + -> Handler b v a + -- ^ Do this if no authenticated user is present. + -> Handler b v a + -- ^ Do this if an authenticated user is present. + -> Handler b v a +requireUser auth bad good = do + loggedIn <- withTop auth isLoggedIn + if loggedIn then good else bad + + +------------------------------------------------------------------------------ +-- | Run a function on the backend, and return the result. +-- +-- This uses an existential type so that the backend type doesn't +-- 'escape' AuthManager. The reason that the type is Handler b +-- (AuthManager v) a and not a is because anything that uses the +-- backend will return an IO something, which you can liftIO, or a +-- Handler b (AuthManager v) a if it uses other handler things. +withBackend + :: (forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a) + -- ^ The function to run with the handler. + -> Handler b (AuthManager v) a +withBackend f = join $ do + (AuthManager bckend _ _ _ _ _ _ _) <- get + return $ f bckend diff --git a/src/Snap/Snaplet/Auth/SpliceHelpers.hs b/src/Snap/Snaplet/Auth/SpliceHelpers.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/SpliceHelpers.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| + + Some pre-packaged splices that add convenience to a Heist-enabled + application. + +-} + +module Snap.Snaplet.Auth.SpliceHelpers + ( + addAuthSplices + , ifLoggedIn + , ifLoggedOut + ) where + +import Data.Lens.Lazy +import qualified Text.XmlHtml as X +import Text.Templating.Heist + +import Snap.Snaplet +import Snap.Snaplet.Auth.AuthManager +import Snap.Snaplet.Auth.Handlers +import Snap.Snaplet.Heist + + +------------------------------------------------------------------------------ +-- | Add all standard auth splices to a Heist-enabled application. +-- +-- This adds the following splices: +-- \ +-- \ +addAuthSplices + :: HasHeist b + => Lens b (Snaplet (AuthManager b)) + -- ^ A lens reference to 'AuthManager' + -> Initializer b v () +addAuthSplices auth = addSplices + [ ("ifLoggedIn", ifLoggedIn auth) + , ("ifLoggedOut", ifLoggedOut auth) + ] + + +------------------------------------------------------------------------------ +-- | A splice that can be used to check for existence of a user. If a user is +-- present, this will run the contents of the node. +-- +-- > Show this when there is a logged in user +ifLoggedIn + :: Lens b (Snaplet (AuthManager b)) + -> SnapletSplice b v +ifLoggedIn auth = do + chk <- liftHandler $ withTop auth isLoggedIn + case chk of + True -> liftHeist $ getParamNode >>= return . X.childNodes + False -> return [] + + +------------------------------------------------------------------------------ +-- | A splice that can be used to check for absence of a user. If a user is +-- not present, this will run the contents of the node. +-- +-- > Show this when there is a logged in user +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 [] + diff --git a/src/Snap/Snaplet/Auth/Types.hs b/src/Snap/Snaplet/Auth/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Auth/Types.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Snap.Snaplet.Auth.Types where + +import Control.Monad.CatchIO +import Data.Aeson +import Data.ByteString (ByteString) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Hashable (Hashable) +import Data.Time +import Data.Typeable +import Data.Text (Text) +import Crypto.PasswordStore + + +------------------------------------------------------------------------------ +-- | Password is clear when supplied by the user and encrypted later when +-- returned from the db. +data Password = ClearText ByteString + | Encrypted ByteString + deriving (Read, Show, Ord, Eq) + + +------------------------------------------------------------------------------ +-- Turn a 'ClearText' password into an 'Encrypted' password, ready to be +-- stuffed into a database. +encryptPassword :: Password -> IO Password +encryptPassword p@(Encrypted {}) = return p +encryptPassword (ClearText p) = do + hashed <- makePassword p 12 + return $ Encrypted hashed + + +checkPassword :: Password -> Password -> Bool +checkPassword (ClearText pw) (Encrypted pw') = verifyPassword pw pw' +checkPassword _ _ = + error "checkPassword failed. Make sure you pass ClearText passwords" + + +------------------------------------------------------------------------------ +-- | Authentication failures indicate what went wrong during authentication. +-- They may provide useful information to the developer, although it is +-- generally not advisable to show the user the exact details about why login +-- failed. +data AuthFailure = + UserNotFound + | IncorrectPassword + | PasswordMissing + | LockedOut UTCTime + -- ^ Locked out until given time + | AuthError String + deriving (Read, Show, Ord, Eq, Typeable) + + +instance Exception AuthFailure + + +------------------------------------------------------------------------------ +-- | Internal representation of a 'User'. By convention, we demand that the +-- application is able to directly fetch a 'User' using this identifier. +-- +-- Think of this type as a secure, authenticated user. You should normally +-- never see this type unless a user has been authenticated. +newtype UserId = UserId { unUid :: Text } + deriving (Read,Show,Ord,Eq,FromJSON,ToJSON,Hashable) + + +-- | This will be replaced by a role-based permission system. +data Role = Role ByteString + deriving (Read,Show,Ord,Eq) + + +------------------------------------------------------------------------------ +-- | Type representing the concept of a User in your application. +data AuthUser = AuthUser + { userId :: Maybe UserId + , userLogin :: Text + , userPassword :: Maybe Password + , userActivatedAt :: Maybe UTCTime + , userSuspendedAt :: Maybe UTCTime + , userRememberToken :: Maybe Text + , userLoginCount :: Int + , userFailedLoginCount :: Int + , userLockedOutUntil :: Maybe UTCTime + , userCurrentLoginAt :: Maybe UTCTime + , userLastLoginAt :: Maybe UTCTime + , userCurrentLoginIp :: Maybe ByteString + , userLastLoginIp :: Maybe ByteString + , userCreatedAt :: Maybe UTCTime + , userUpdatedAt :: Maybe UTCTime + , userRoles :: [Role] + , userMeta :: HashMap Text Value + } deriving (Show,Eq) + + +------------------------------------------------------------------------------ +-- | Default AuthUser that has all empty values. +defAuthUser :: AuthUser +defAuthUser = AuthUser { + userId = Nothing + , userLogin = "" + , userPassword = Nothing + , userActivatedAt = Nothing + , userSuspendedAt = Nothing + , userRememberToken = Nothing + , userLoginCount = 0 + , userFailedLoginCount = 0 + , userLockedOutUntil = Nothing + , userCurrentLoginAt = Nothing + , userLastLoginAt = Nothing + , userCurrentLoginIp = Nothing + , userLastLoginIp = Nothing + , userCreatedAt = Nothing + , userUpdatedAt = Nothing + , userRoles = [] + , userMeta = HM.empty +} + + +------------------------------------------------------------------------------ +-- | Set a new password for the given user. Given password should be +-- clear-text; it will be encrypted into a 'Encrypted'. +setPassword :: AuthUser -> ByteString -> IO AuthUser +setPassword au pass = do + pw <- Encrypted `fmap` (makePassword pass 12) + return $ au { userPassword = Just pw } + + +------------------------------------------------------------------------------ +-- | Authetication settings defined at initialization time +data AuthSettings = AuthSettings { + asMinPasswdLen :: Int + -- ^ Currently not used/checked + , asRememberCookieName :: ByteString + -- ^ Name of the desired remember cookie + , asRememberPeriod :: Maybe Int + -- ^ How long to remember when the option is used in rest of the API. + -- 'Nothing' means remember until end of session. + , asLockout :: Maybe (Int, NominalDiffTime) + -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration]) + , asSiteKey :: FilePath + -- ^ Location of app's encryption key +} + + +------------------------------------------------------------------------------ +-- | Default settings for Auth. +-- +-- > asMinPasswdLen = 8 +-- > asRememberCookieName = "_remember" +-- > asRememberPeriod = Just (2*7*24*60*60) = 2 weeks +-- > asLockout = Nothing +-- > asSiteKey = "site_key.txt" +defAuthSettings :: AuthSettings +defAuthSettings = AuthSettings { + asMinPasswdLen = 8 + , asRememberCookieName = "_remember" + , asRememberPeriod = Just (2*7*24*60*60) + , asLockout = Nothing + , asSiteKey = "site_key.txt" +} + + +data BackendError = + DuplicateLogin + | BackendError String + deriving (Eq,Show,Read,Typeable) + + +instance Exception BackendError + diff --git a/src/Snap/Snaplet/Heist.hs b/src/Snap/Snaplet/Heist.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Heist.hs @@ -0,0 +1,201 @@ +{-| + +The Heist snaplet makes it easy to add Heist to your application and use it in +other snaplets. + +-} + +module Snap.Snaplet.Heist + ( + -- * Heist and its type class + Heist + , HasHeist(..) + + -- * Initializer Functions + -- $initializerSection + , heistInit + , addTemplates + , addTemplatesAt + , modifyHeistTS + , withHeistTS + , addSplices + + -- * Handler Functions + -- $handlerSection + , render + , renderAs + , heistServe + , heistServeSingle + , heistLocal + , withSplices + , renderWithSplices + + -- * Writing Splices + -- $spliceSection + , Unclassed.SnapletHeist + , Unclassed.SnapletSplice + , Unclassed.liftHeist + , Unclassed.liftHandler + , Unclassed.liftAppHandler + , Unclassed.liftWith + , Unclassed.bindSnapletSplices + + , clearHeistCache + ) where + +import Prelude hiding (id, (.)) +import Data.ByteString (ByteString) +import Data.Lens.Lazy +import Data.Text (Text) +import Text.Templating.Heist + +import Snap.Snaplet + +import qualified Snap.Snaplet.HeistNoClass as Unclassed +import Snap.Snaplet.HeistNoClass (Heist, heistInit, clearHeistCache) + + +------------------------------------------------------------------------------ +-- | A single snaplet should never need more than one instance of Heist as a +-- subsnaplet. This type class allows you to make it easy for other snaplets +-- to get the lens that identifies the heist snaplet. Here's an example of +-- how the heist snaplet might be declared: +-- +-- > data App = App { _heist :: Snaplet (Heist App) } +-- > mkLabels [''App] +-- > +-- > instance HasHeist App where heistLens = subSnaplet heist +-- > +-- > appInit = makeSnaplet "app" "" Nothing $ do +-- > h <- nestSnaplet "heist" $ heistInit "templates" +-- > addSplices myAppSplices +-- > return $ App h +class HasHeist b where + -- | A lens to the Heist snaplet. The b parameter to Heist will + -- typically be the base state of your application. + heistLens :: Lens (Snaplet b) (Snaplet (Heist b)) + + +-- $initializerSection +-- This section contains functions for use in setting up your Heist state +-- during initialization. + + +------------------------------------------------------------------------------ +-- | Adds templates to the Heist TemplateState. Other snaplets should use +-- this function to add their own templates. The templates are automatically +-- read from the templates directory in the current snaplet's filesystem root. +addTemplates :: HasHeist b => ByteString -> Initializer b v () +addTemplates pfx = withTop' heistLens (Unclassed.addTemplates pfx) + + +------------------------------------------------------------------------------ +-- | Adds templates to the Heist TemplateState, and lets you specify where +-- they are found in the filesystem. +addTemplatesAt :: HasHeist b => ByteString -> FilePath -> Initializer b v () +addTemplatesAt pfx p = withTop' heistLens (Unclassed.addTemplatesAt pfx p) + + +------------------------------------------------------------------------------ +-- | Allows snaplets to add splices. +addSplices :: (HasHeist b) + => [(Text, Unclassed.SnapletSplice b v)] -> Initializer b v () +addSplices = Unclassed.addSplices' heistLens + + +------------------------------------------------------------------------------ +-- | More general function allowing arbitrary TemplateState modification. +-- Without this function you wouldn't be able to bind more complicated splices +-- like the cache tag. +modifyHeistTS :: (HasHeist b) + => (TemplateState (Handler b b) -> TemplateState (Handler b b)) + -> Initializer b v () +modifyHeistTS = Unclassed.modifyHeistTS' heistLens + + +------------------------------------------------------------------------------ +-- | Runs a function on with the Heist snaplet's 'TemplateState'. +withHeistTS :: (HasHeist b) + => (TemplateState (Handler b b) -> a) + -> Handler b v a +withHeistTS = Unclassed.withHeistTS' heistLens + + +-- $handlerSection +-- This section contains functions in the 'Handler' monad that you'll use in +-- processing requests. + + +------------------------------------------------------------------------------ +-- | Renders a template as text\/html. If the given template is not found, +-- this returns 'empty'. +render :: HasHeist b => ByteString -> Handler b v () +render t = withTop' heistLens (Unclassed.render t) + + +------------------------------------------------------------------------------ +-- | Renders a template as the given content type. If the given template +-- is not found, this returns 'empty'. +renderAs :: HasHeist b => ByteString -> ByteString -> Handler b v () +renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t) + + +------------------------------------------------------------------------------ +-- | Analogous to 'fileServe'. If the template specified in the request path +-- is not found, it returns 'empty'. +heistServe :: HasHeist b => Handler b v () +heistServe = withTop' heistLens Unclassed.heistServe + + +------------------------------------------------------------------------------ +-- | Analogous to 'fileServeSingle'. If the given template is not found, +-- this throws an error. +heistServeSingle :: HasHeist b => ByteString -> Handler b v () +heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t) + + +------------------------------------------------------------------------------ +-- | Renders a template with a given set of splices. This is syntax sugar for +-- a common combination of heistLocal, bindSplices, and render. +renderWithSplices :: HasHeist b + => ByteString + -> [(Text, Unclassed.SnapletSplice b v)] + -> Handler b v () +renderWithSplices = Unclassed.renderWithSplices' heistLens + + +------------------------------------------------------------------------------ +-- | Runs an action with additional splices bound into the Heist +-- 'TemplateState'. +withSplices :: HasHeist b + => [(Text, Unclassed.SnapletSplice b v)] + -> Handler b v a + -> Handler b v a +withSplices = Unclassed.withSplices' heistLens + + +------------------------------------------------------------------------------ +-- | Runs a handler with a modified 'TemplateState'. You might want to use +-- this if you had a set of splices which were customised for a specific +-- action. To do that you would do: +-- +-- > heistLocal (bindSplices mySplices) handlerThatNeedsSplices +heistLocal :: HasHeist b + => (TemplateState (Handler b b) -> TemplateState (Handler b b)) + -> Handler b v a + -> Handler b v a +heistLocal = Unclassed.heistLocal' heistLens + + +-- $spliceSection +-- As can be seen in the type signature of heistLocal, the internal +-- TemplateState used by the heist snaplet is parameterized by (Handler b b). +-- The reasons for this are beyond the scope of this discussion, but the +-- result is that 'lift' inside a splice only works with @Handler b b@ +-- actions. When you're writing your own snaplets you obviously would rather +-- work with @Handler b v@ so your local snaplet's state is available. We +-- provide the SnapletHeist monad to make this possible. The general rule is +-- that when you're using Snaplets and Heist, use SnapletHeist instead of +-- HeistT (previously called TemplateMonad) and use SnapletSplice instead of +-- Splice. + diff --git a/src/Snap/Snaplet/HeistNoClass.hs b/src/Snap/Snaplet/HeistNoClass.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/HeistNoClass.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Snap.Snaplet.HeistNoClass + ( Heist + , heistInit + , clearHeistCache + + , addTemplates + , addTemplatesAt + , modifyHeistTS + , modifyHeistTS' + , withHeistTS + , withHeistTS' + , addSplices + , addSplices' + , render + , renderAs + , heistServe + , heistServeSingle + , heistLocal + , withSplices + , renderWithSplices + , heistLocal' + , withSplices' + , renderWithSplices' + + , SnapletHeist + , SnapletSplice + , runSnapletSplice + , liftHeist + , liftWith + , liftHandler + , liftAppHandler + , bindSnapletSplices + ) where + +import Prelude hiding ((.), id) +import Control.Arrow +import Control.Applicative +import Control.Category +import Control.Monad.CatchIO (MonadCatchIO) +import Control.Monad.Reader +import Control.Monad.State +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.UTF8 as U +import Data.Maybe +import Data.Monoid +import Data.Lens.Lazy +import Data.Text (Text) +import qualified Data.Text as T +import System.FilePath.Posix +import Text.Templating.Heist +import Text.Templating.Heist.Splices.Cache + +import Snap.Snaplet +import Snap.Core +import Snap.Util.FileServe + + +------------------------------------------------------------------------------ +-- | The state for the Heist snaplet. To use the Heist snaplet in your app +-- include this in your application state and use 'heistInit' to initialize +-- it. The type parameter b will typically be the base state type for your +-- application. +data Heist b = Heist + { _heistTS :: TemplateState (Handler b b) + , _heistCTS :: CacheTagState + } + + +------------------------------------------------------------------------------ +changeTS :: (TemplateState (Handler a a) -> TemplateState (Handler a a)) + -> Heist a + -> Heist a +changeTS f (Heist ts cts) = Heist (f ts) cts + + +------------------------------------------------------------------------------ +-- | Clears data stored by the cache tag. The cache tag automatically reloads +-- its data when the specified TTL expires, but sometimes you may want to +-- trigger a manual reload. This function lets you do that. +clearHeistCache :: Heist b -> IO () +clearHeistCache = clearCacheTagState . _heistCTS + + +------------------------------------------------------------------------------ +-- SnapletSplice functions +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | This instance is here because we don't want the heist package to depend +-- on anything from snap packages. +instance MonadSnap m => MonadSnap (HeistT m) where + liftSnap = lift . liftSnap + + +------------------------------------------------------------------------------ +-- | Monad for working with Heist's API from within a snaplet. +newtype SnapletHeist b v a = SnapletHeist + (ReaderT (Lens (Snaplet b) (Snaplet v)) (HeistT (Handler b b)) a) + deriving ( Monad + , Functor + , Applicative + , Alternative + , MonadIO + , MonadPlus + , MonadReader (Lens (Snaplet b) (Snaplet v)) + , MonadCatchIO + , MonadSnap + ) + + +------------------------------------------------------------------------------ +-- | Type alias for convenience. +type SnapletSplice b v = SnapletHeist b v Template + + +------------------------------------------------------------------------------ +-- | Runs the SnapletSplice. +runSnapletSplice :: (Lens (Snaplet b) (Snaplet v)) + -> SnapletHeist b v a + -> HeistT (Handler b b) a +runSnapletSplice l (SnapletHeist m) = runReaderT m l + + +withSS :: (Lens (Snaplet b) (Snaplet v) -> Lens (Snaplet b) (Snaplet v')) + -> SnapletHeist b v' a + -> SnapletHeist b v a +withSS f (SnapletHeist m) = SnapletHeist $ withReaderT f m + + +------------------------------------------------------------------------------ +-- | Lifts a HeistT action into SnapletHeist. Use this with all the functions +-- from the Heist API. +liftHeist :: HeistT (Handler b b) a -> SnapletHeist b v a +liftHeist = SnapletHeist . lift + + +------------------------------------------------------------------------------ +-- | Common idiom for the combination of liftHandler and withTop. +liftWith :: (Lens (Snaplet b) (Snaplet v')) + -> Handler b v' a + -> SnapletHeist b v a +liftWith l = liftHeist . lift . withTop' l + + +------------------------------------------------------------------------------ +-- | Lifts a Handler into SnapletHeist. +liftHandler :: Handler b v a -> SnapletHeist b v a +liftHandler m = do + l <- ask + liftWith l m + + +------------------------------------------------------------------------------ +-- | Lifts a (Handler b b) into SnapletHeist. +liftAppHandler :: Handler b b a -> SnapletHeist b v a +liftAppHandler = liftHeist . lift + + +instance MonadState v (SnapletHeist b v) where + get = do + l <- ask + b <- liftAppHandler getSnapletState + return $ getL (snapletValue . l) b + put s = do + l <- ask + b <- liftAppHandler getSnapletState + liftAppHandler $ putSnapletState $ setL (snapletValue . l) s b + + +------------------------------------------------------------------------------ +-- | MonadSnaplet instance gives us access to the snaplet infrastructure. +instance MonadSnaplet SnapletHeist where + getLens = ask + with' l = withSS (l .) + withTop' l = withSS (const id) . with' l + getOpaqueConfig = do + l <- ask + b <- liftAppHandler getSnapletState + return $ getL (snapletConfig . l) b + + +------------------------------------------------------------------------------ +-- | SnapletSplices version of bindSplices. +bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v)) + -> [(Text, SnapletSplice b v)] + -> TemplateState (Handler b b) + -> TemplateState (Handler b b) +bindSnapletSplices l splices = + bindSplices $ map (second $ runSnapletSplice l) splices + + +------------------------------------------------------------------------------ +-- Initializer functions +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | The 'Initializer' for 'Heist'. +heistInit :: FilePath + -> SnapletInit b (Heist b) +heistInit templateDir = + makeSnaplet "heist" "" Nothing $ do + (cacheFunc, cts) <- liftIO mkCacheTag + let origTs = cacheFunc emptyTemplateState + ts <- liftIO $ loadTemplates templateDir origTs >>= + either error return + addRoutes [ ("", heistServe) ] + printInfo $ T.pack $ unwords + [ "...loaded" + , (show $ length $ templateNames ts) + , "templates" + ] + + return $ Heist ts cts + + +addTemplates :: ByteString -> Initializer b (Heist b) () +addTemplates urlPrefix = do + snapletPath <- getSnapletFilePath + addTemplatesAt urlPrefix (snapletPath "templates") + + +addTemplatesAt :: ByteString + -> FilePath + -> Initializer b (Heist b) () +addTemplatesAt urlPrefix templateDir = do + ts <- liftIO $ loadTemplates templateDir emptyTemplateState + >>= either error return + printInfo $ T.pack $ unwords + [ "...adding" + , (show $ length $ templateNames ts) + , "templates from" + , templateDir + , "with route prefix" + , (U.toString urlPrefix) ++ "/" + ] + addPostInitHook $ return . changeTS + (`mappend` addTemplatePathPrefix urlPrefix ts) + + +modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b))) + -> (TemplateState (Handler b b) -> TemplateState (Handler b b)) + -> Initializer b v () +modifyHeistTS' heist f = do + _lens <- getLens + withTop' heist $ addPostInitHook $ return . changeTS f + + +modifyHeistTS :: (Lens b (Snaplet (Heist b))) + -> (TemplateState (Handler b b) -> TemplateState (Handler b b)) + -> Initializer b v () +modifyHeistTS heist f = modifyHeistTS' (subSnaplet heist) f + + +withHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b))) + -> (TemplateState (Handler b b) -> a) + -> Handler b v a +withHeistTS' heist f = withTop' heist $ gets (f . _heistTS) + + +withHeistTS :: (Lens b (Snaplet (Heist b))) + -> (TemplateState (Handler b b) -> a) + -> Handler b v a +withHeistTS heist f = withHeistTS' (subSnaplet heist) f + + +addSplices' :: (Lens (Snaplet b) (Snaplet (Heist b))) + -> [(Text, SnapletSplice b v)] + -> Initializer b v () +addSplices' heist splices = do + _lens <- getLens + withTop' heist $ addPostInitHook $ + return . changeTS (bindSnapletSplices _lens splices) + + +addSplices :: (Lens b (Snaplet (Heist b))) + -> [(Text, SnapletSplice b v)] + -> Initializer b v () +addSplices heist splices = addSplices' (subSnaplet heist) splices + + +------------------------------------------------------------------------------ +-- Handler functions +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | Internal helper function for rendering. +renderHelper :: Maybe MIMEType + -> ByteString + -> Handler b (Heist b) () +renderHelper c t = do + (Heist ts _) <- get + withTop' id $ renderTemplate ts t >>= maybe pass serve + where + serve (b, mime) = do + modifyResponse $ setContentType $ fromMaybe mime c + writeBuilder b + + +render :: ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +render t = renderHelper Nothing t + + +renderAs :: ByteString + -- ^ Content type + -> ByteString + -- ^ Name of the template + -> Handler b (Heist b) () +renderAs ct t = renderHelper (Just ct) t + + +heistServe :: Handler b (Heist b) () +heistServe = + ifTop (render "index") <|> (render . B.pack =<< getSafePath) + + +heistServeSingle :: ByteString + -> Handler b (Heist b) () +heistServeSingle t = + render t <|> error ("Template " ++ show t ++ " not found.") + + +heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b))) + -> (TemplateState (Handler b b) -> TemplateState (Handler b b)) + -> Handler b v a + -> Handler b v a +heistLocal' heist f m = do + hs <- withTop' heist get + withTop' heist $ modify $ changeTS f + res <- m + withTop' heist $ put hs + return res + + +heistLocal :: (Lens b (Snaplet (Heist b))) + -> (TemplateState (Handler b b) -> TemplateState (Handler b b)) + -> Handler b v a + -> Handler b v a +heistLocal heist f m = heistLocal' (subSnaplet heist) f m + + +withSplices' :: (Lens (Snaplet b) (Snaplet (Heist b))) + -> [(Text, SnapletSplice b v)] + -> Handler b v a + -> Handler b v a +withSplices' heist splices m = do + _lens <- getLens + heistLocal' heist (bindSnapletSplices _lens splices) m + + +withSplices :: (Lens b (Snaplet (Heist b))) + -> [(Text, SnapletSplice b v)] + -> Handler b v a + -> Handler b v a +withSplices heist splices m = withSplices' (subSnaplet heist) splices m + + +renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b))) + -> ByteString + -> [(Text, SnapletSplice b v)] + -> Handler b v () +renderWithSplices' heist t splices = + withSplices' heist splices $ withTop' heist $ render t + + +renderWithSplices :: (Lens b (Snaplet (Heist b))) + -> ByteString + -> [(Text, SnapletSplice b v)] + -> Handler b v () +renderWithSplices heist t splices = + renderWithSplices' (subSnaplet heist) t splices + + diff --git a/src/Snap/Snaplet/Internal/Initializer.hs b/src/Snap/Snaplet/Internal/Initializer.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/Initializer.hs @@ -0,0 +1,489 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +module Snap.Snaplet.Internal.Initializer + ( addPostInitHook + , addPostInitHookBase + , toSnapletHook + , bracketInit + , modifyCfg + , nestSnaplet + , embedSnaplet + , makeSnaplet + , nameSnaplet + , onUnload + , addRoutes + , wrapHandlers + , runInitializer + , runSnaplet + , combineConfig + , serveSnaplet + , printInfo + ) where + +import Prelude hiding ((.), id, catch) +import Control.Category +import Control.Concurrent.MVar +import Control.Exception (SomeException) +import Control.Monad +import Control.Monad.CatchIO hiding (Handler) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Writer hiding (pass) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Configurator +import Data.IORef +import Data.Maybe +import Data.Lens.Lazy +import Data.Text (Text) +import qualified Data.Text as T +import Snap.Http.Server +import Snap.Core +import Snap.Util.GZip +import System.Directory +import System.Directory.Tree +import System.FilePath.Posix +import System.IO + +import qualified Snap.Snaplet.Internal.LensT as LT +import qualified Snap.Snaplet.Internal.Lensed as L +import Snap.Snaplet.Internal.Types + + +------------------------------------------------------------------------------ +-- | 'get' for InitializerState. +iGet :: Initializer b v (InitializerState b) +iGet = Initializer $ LT.getBase + + +------------------------------------------------------------------------------ +-- | 'modify' for InitializerState. +iModify :: (InitializerState b -> InitializerState b) -> Initializer b v () +iModify f = Initializer $ do + b <- LT.getBase + LT.putBase $ f b + + +------------------------------------------------------------------------------ +-- | 'gets' for InitializerState. +iGets :: (InitializerState b -> a) -> Initializer b v a +iGets f = Initializer $ do + b <- LT.getBase + return $ f b + + +------------------------------------------------------------------------------ +-- | Converts a plain hook into a Snaplet hook. +toSnapletHook :: (v -> IO v) -> (Snaplet v -> IO (Snaplet v)) +toSnapletHook f (Snaplet cfg val) = do + val' <- f val + return $! Snaplet cfg val' + + +------------------------------------------------------------------------------ +-- | Adds an IO action that modifies the current snaplet state to be run at +-- the end of initialization on the state that was created. This makes it +-- easier to allow one snaplet's state to be modified by another snaplet's +-- initializer. A good example of this is when a snaplet has templates that +-- define its views. The Heist snaplet provides the 'addTemplates' function +-- which allows other snaplets to set up their own templates. 'addTemplates' +-- is implemented using this function. +addPostInitHook :: (v -> IO v) -> Initializer b v () +addPostInitHook = addPostInitHook' . toSnapletHook + + +addPostInitHook' :: (Snaplet v -> IO (Snaplet v)) -> Initializer b v () +addPostInitHook' h = do + h' <- upHook h + addPostInitHookBase h' + + +------------------------------------------------------------------------------ +-- | Variant of addPostInitHook for when you have things wrapped in a Snaplet. +addPostInitHookBase :: (Snaplet b -> IO (Snaplet b)) + -> Initializer b v () +addPostInitHookBase = Initializer . lift . tell . Hook + + +------------------------------------------------------------------------------ +-- | Helper function for transforming hooks. +upHook :: (Snaplet v -> IO (Snaplet v)) + -> Initializer b v (Snaplet b -> IO (Snaplet b)) +upHook h = Initializer $ do + l <- ask + return $ upHook' l h + + +------------------------------------------------------------------------------ +-- | Helper function for transforming hooks. +upHook' :: (Lens b a) -> (a -> IO a) -> b -> IO b +upHook' l h b = do + v <- h (getL l b) + return $ setL l v b + + +------------------------------------------------------------------------------ +-- | Modifies the Initializer's SnapletConfig. +modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v () +modifyCfg f = iModify $ modL curConfig $ \c -> f c + + +------------------------------------------------------------------------------ +-- | If a snaplet has a filesystem presence, this function creates and copies +-- the files if they dont' already exist. +setupFilesystem :: Maybe (IO FilePath) + -- ^ The directory where the snaplet's reference files are + -- stored. Nothing if the snaplet doesn't come with any files + -- that need to be installed. + -> FilePath + -- ^ Directory where the files should be copied. + -> Initializer b v () +setupFilesystem Nothing _ = return () +setupFilesystem (Just getSnapletDataDir) targetDir = do + exists <- liftIO $ doesDirectoryExist targetDir + unless exists $ do + printInfo "...setting up filesystem" + liftIO $ createDirectoryIfMissing True targetDir + srcDir <- liftIO getSnapletDataDir + (_ :/ dTree) <- liftIO $ readDirectoryWith B.readFile srcDir + let (topDir,snapletId) = splitFileName targetDir + _ <- liftIO $ writeDirectoryWith B.writeFile + (topDir :/ dTree { name = snapletId }) + return () + + +------------------------------------------------------------------------------ +-- | All snaplet initializers must be wrapped in a call to @makeSnaplet@, +-- which handles standardized housekeeping common to all snaplets. +-- Common usage will look something like +-- this: +-- +-- @ +-- fooInit :: SnapletInit b Foo +-- fooInit = makeSnaplet \"foo\" \"An example snaplet\" Nothing $ do +-- -- Your initializer code here +-- return $ Foo 42 +-- @ +-- +-- Note that you're writing your initializer code in the Initializer monad, +-- and makeSnaplet converts it into an opaque SnapletInit type. This allows +-- us to use the type system to ensure that the API is used correctly. +makeSnaplet :: Text + -- ^ A default id for this snaplet. This is only used when the + -- end-user has not already set an id using the nameSnaplet function. + -> Text + -- ^ A human readable description of this snaplet. + -> Maybe (IO FilePath) + -- ^ The path to the directory holding the snaplet's reference + -- filesystem content. This will almost always be the directory + -- returned by Cabal's getDataDir command, but it has to be passed in + -- because it is defined in a package-specific import. Setting this + -- value to Nothing doesn't preclude the snaplet from having files in + -- in the filesystem, it just means that they won't be copied there + -- automatically. + -> Initializer b v v + -- ^ Snaplet initializer. + -> SnapletInit b v +makeSnaplet snapletId desc getSnapletDataDir m = SnapletInit $ do + modifyCfg $ \c -> if isNothing $ _scId c + then setL scId (Just snapletId) c else c + sid <- iGets (T.unpack . fromJust . _scId . _curConfig) + topLevel <- iGets _isTopLevel + unless topLevel $ modifyCfg $ \c -> setL scFilePath + (_scFilePath c "snaplets" sid) c + iModify (setL isTopLevel False) + modifyCfg $ modL scUserConfig (subconfig (T.pack sid)) + modifyCfg $ setL scDescription desc + cfg <- iGets _curConfig + printInfo $ T.pack $ concat + ["Initializing " + ,sid + ," @ /" + ,B.unpack $ buildPath $ _scRouteContext cfg + ] + + -- This has to happen here because it needs to be after scFilePath is set + -- up but before snaplet.cfg is read. + setupFilesystem getSnapletDataDir (_scFilePath cfg) + + liftIO $ addToConfig [Optional (_scFilePath cfg "snaplet.cfg")] + (_scUserConfig cfg) + mkSnaplet m + + +------------------------------------------------------------------------------ +-- | Internal function that gets the SnapletConfig out of the initializer +-- state and uses it to create a (Snaplet a). +mkSnaplet :: Initializer b v a -> Initializer b v (Snaplet a) +mkSnaplet m = do + res <- m + cfg <- iGets _curConfig + return $ Snaplet cfg res + + +------------------------------------------------------------------------------ +-- | Brackets an initializer computation, restoring curConfig after the +-- computation returns. +bracketInit :: Initializer b v a -> Initializer b v a +bracketInit m = do + s <- iGet + res <- m + iModify (setL curConfig (_curConfig s)) + return res + + +------------------------------------------------------------------------------ +-- | Handles modifications to InitializerState that need to happen before a +-- snaplet is called with either nestSnaplet or embedSnaplet. +setupSnapletCall :: ByteString -> Initializer b v () +setupSnapletCall rte = do + curId <- iGets (fromJust . _scId . _curConfig) + modifyCfg (modL scAncestry (curId:)) + modifyCfg (modL scId (const Nothing)) + unless (B.null rte) $ modifyCfg (modL scRouteContext (rte:)) + + +------------------------------------------------------------------------------ +-- | Runs another snaplet's initializer and returns the initialized Snaplet +-- value. Calling an initializer with nestSnaplet gives the nested snaplet +-- access to the same base state that the current snaplet has. This makes it +-- possible for the child snaplet to make use of functionality provided by +-- sibling snaplets. +nestSnaplet :: ByteString + -- ^ The root url for all the snaplet's routes. An empty string + -- gives the routes the same root as the parent snaplet's routes. + -> (Lens v (Snaplet v1)) + -- ^ Lens identifying the snaplet + -> SnapletInit b v1 + -- ^ The initializer function for the subsnaplet. + -> Initializer b v (Snaplet v1) +nestSnaplet rte l (SnapletInit snaplet) = with l $ bracketInit $ do + setupSnapletCall rte + snaplet + + +------------------------------------------------------------------------------ +-- | Runs another snaplet's initializer and returns the initialized Snaplet +-- value. The difference between this and nestSnaplet is the first type +-- parameter in the third argument. The \"v1 v1\" makes the child snaplet +-- think that it is top-level, which means that it will not be able to use +-- functionality provided by snaplets included above it in the snaplet tree. +-- This strongly isolates the child snaplet, and allows you to eliminate the b +-- type variable. The embedded snaplet can still get functionality from other +-- snaplets, but only if it nests or embeds the snaplet itself. +embedSnaplet :: ByteString + -- ^ The root url for all the snaplet's routes. An empty string + -- gives the routes the same root as the parent snaplet's routes. + -- + -- NOTE: Because of the stronger isolation provided by + -- embedSnaplet, you should be more careful about using an empty + -- string here. + -> (Lens v (Snaplet v1)) + -- ^ Lens identifying the snaplet + -> SnapletInit v1 v1 + -- ^ The initializer function for the subsnaplet. + -> Initializer b v (Snaplet v1) +embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do + curLens <- getLens + setupSnapletCall rte + chroot rte (subSnaplet l . curLens) snaplet + + +------------------------------------------------------------------------------ +-- | Changes the base state of an initializer. +chroot :: ByteString + -> (Lens (Snaplet b) (Snaplet v1)) + -> Initializer v1 v1 a + -> Initializer b v a +chroot rte l (Initializer m) = do + curState <- iGet + ((a,s), (Hook hook)) <- liftIO $ runWriterT $ LT.runLensT m id $ + curState { + _handlers = [], + _hFilter = id + } + let handler = chrootHandler l $ _hFilter s $ route $ _handlers s + iModify $ modL handlers (++[(rte,handler)]) + . setL cleanup (_cleanup s) + addPostInitHookBase $ upHook' l hook + return a + + +------------------------------------------------------------------------------ +-- | Changes the base state of a handler. +chrootHandler :: (Lens (Snaplet v) (Snaplet b')) + -> Handler b' b' a -> Handler b v a +chrootHandler l (Handler h) = Handler $ do + s <- get + (a, s') <- liftSnap $ L.runLensed h id (getL l s) + modify $ setL l s' + return a + + +------------------------------------------------------------------------------ +-- | Sets a snaplet's name. All snaplets have a default name set by the +-- snaplet author. This function allows you to override that name. You will +-- have to do this if you have more than one instance of the same kind of +-- snaplet because snaplet names must be unique. This function must +-- immediately surround the snaplet's initializer. For example: +-- +-- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@ +nameSnaplet :: Text + -- ^ The snaplet name + -> SnapletInit b v + -- ^ The snaplet initializer function + -> SnapletInit b v +nameSnaplet nm (SnapletInit m) = SnapletInit $ + modifyCfg (setL scId (Just nm)) >> m + + +------------------------------------------------------------------------------ +-- | Adds routing to the current 'Handler'. The new routes are merged with +-- the main routing section and take precedence over existing routing that was +-- previously defined. +addRoutes :: [(ByteString, Handler b v ())] + -> Initializer b v () +addRoutes rs = do + l <- getLens + ctx <- iGets (_scRouteContext . _curConfig) + let rs' = map (\(r,h) -> (buildPath (r:ctx), withTop' l h)) rs + iModify (\v -> modL handlers (++rs') v) + + +------------------------------------------------------------------------------ +-- | Wraps the snaplet's routing. This can be used to provide a snaplet that +-- does per-request setup and cleanup, but then dispatches to the rest of the +-- application. +wrapHandlers :: (Handler b v () -> Handler b v ()) -> Initializer b v () +wrapHandlers f0 = do + f <- mungeFilter f0 + iModify (\v -> modL hFilter (f.) v) + + +------------------------------------------------------------------------------ +mungeFilter :: (Handler b v () -> Handler b v ()) + -> Initializer b v (Handler b b () -> Handler b b ()) +mungeFilter f = do + myLens <- Initializer ask + return $ \m -> with' myLens $ f' m + where + f' (Handler m) = f $ Handler $ L.withTop id m + + +------------------------------------------------------------------------------ +-- | Attaches an unload handler to the snaplet. The unload handler will be +-- called when the server shuts down, or is reloaded. +onUnload :: IO () -> Initializer b v () +onUnload m = iModify (\v -> modL cleanup (m>>) v) + + +------------------------------------------------------------------------------ +-- | +logInitMsg :: IORef Text -> Text -> IO () +logInitMsg ref msg = atomicModifyIORef ref (\cur -> (cur `T.append` msg, ())) + + +------------------------------------------------------------------------------ +-- | Initializers should use this function for all informational or error +-- messages to be displayed to the user. On application startup they will be +-- sent to the console. When executed from the reloader, they will be sent +-- back to the user in the HTTP response. +printInfo :: Text -> Initializer b v () +printInfo msg = do + logRef <- iGets _initMessages + liftIO $ logInitMsg logRef (msg `T.append` "\n") + + +------------------------------------------------------------------------------ +-- | Builds an IO reload action for storage in the SnapletState. +mkReloader :: MVar (Snaplet b) + -> Initializer b b (Snaplet b) + -> IO (Either String String) +mkReloader mvar i = do + !res <- try $ runInitializer mvar i + either bad good res + where + bad e = do + return $ Left $ show (e :: SomeException) + good (b,is) = do + _ <- swapMVar mvar b + msgs <- readIORef $ _initMessages is + return $ Right $ T.unpack msgs + + +------------------------------------------------------------------------------ +-- | Runs a top-level snaplet in the Snap monad. +runBase :: Handler b b a + -> MVar (Snaplet b) + -> Snap a +runBase (Handler m) mvar = do + !b <- liftIO (readMVar mvar) + (!a, _) <- L.runLensed m id b + return $! a + + +------------------------------------------------------------------------------ +-- | +runInitializer :: MVar (Snaplet b) + -> Initializer b b (Snaplet b) + -> IO (Snaplet b, InitializerState b) +runInitializer mvar b@(Initializer i) = do + userConfig <- load [Optional "snaplet.cfg"] + let builtinHandlers = [("/admin/reload", reloadSite)] + let cfg = SnapletConfig [] "" Nothing "" userConfig [] (mkReloader mvar b) + logRef <- newIORef "" + ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $ + InitializerState True (return ()) builtinHandlers id cfg logRef + res' <- hook res + return (res', s) + + +------------------------------------------------------------------------------ +-- | Given a Snaplet initializer, produce the set of messages generated during +-- initialization, a snap handler, and a cleanup action. +runSnaplet :: SnapletInit b b -> IO (Text, Snap (), IO ()) +runSnaplet (SnapletInit b) = do + snapletMVar <- newEmptyMVar + (siteSnaplet, is) <- runInitializer snapletMVar b + putMVar snapletMVar siteSnaplet + + msgs <- liftIO $ readIORef $ _initMessages is + let handler = runBase (_hFilter is $ route $ _handlers is) snapletMVar + + return (msgs, handler, _cleanup is) + + +------------------------------------------------------------------------------ +-- | Given a configuration and a snap handler, complete it and produce the +-- completed configuration as well as a new toplevel handler with things like +-- compression and a 500 handler set up. +combineConfig :: Config Snap a -> Snap () -> IO (Config Snap a, Snap ()) +combineConfig config handler = do + conf <- completeConfig config + + let catch500 = (flip catch $ fromJust $ getErrorHandler conf) + let compress = if fromJust (getCompression conf) + then withCompression else id + let site = compress $ catch500 handler + + return (conf, site) + + +------------------------------------------------------------------------------ +-- | Serves a top-level snaplet as a web application. Reads command-line +-- arguments. FIXME: document this. +serveSnaplet :: Config Snap a -> SnapletInit b b -> IO () +serveSnaplet startConfig initializer = do + (msgs, handler, doCleanup) <- runSnaplet initializer + + config <- commandLineConfig startConfig + (conf, site) <- combineConfig config handler + let serve = simpleHttpServe conf + + liftIO $ hPutStrLn stderr $ T.unpack msgs + _ <- try $ serve $ site + :: IO (Either SomeException ()) + doCleanup + + diff --git a/src/Snap/Snaplet/Internal/LensT.hs b/src/Snap/Snaplet/Internal/LensT.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/LensT.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Snap.Snaplet.Internal.LensT where + +import Control.Applicative +import Control.Category +import Control.Monad.CatchIO +import Control.Monad.Reader +import Control.Monad.State.Class +import Data.Lens.Lazy +import Prelude hiding ((.), id, catch) +import Snap.Core + +import Snap.Snaplet.Internal.RST + + +newtype LensT b v s m a = LensT (RST (Lens b v) s m a) + deriving ( Monad + , MonadTrans + , Functor + , Applicative + , MonadIO + , MonadPlus + , MonadCatchIO + , Alternative + , MonadReader (Lens b v) + , MonadSnap ) + + +------------------------------------------------------------------------------ +instance (Monad m) => MonadState v (LensT b v b m) where + get = lGet + put = lPut + + +------------------------------------------------------------------------------ +getBase :: (Monad m) => LensT b v s m s +getBase = LensT get +{-# INLINE getBase #-} + + +------------------------------------------------------------------------------ +putBase :: (Monad m) => s -> LensT b v s m () +putBase = LensT . put +{-# INLINE putBase #-} + + +------------------------------------------------------------------------------ +lGet :: (Monad m) => LensT b v b m v +lGet = LensT $ do + !l <- ask + !b <- get + return $! l ^$ b +{-# INLINE lGet #-} + + +------------------------------------------------------------------------------ +lPut :: (Monad m) => v -> LensT b v b m () +lPut v = LensT $ do + !l <- ask + !b <- get + put $! (l ^!= v) b +{-# INLINE lPut #-} + + +------------------------------------------------------------------------------ +runLensT :: (Monad m) => + LensT b v s m a + -> Lens b v + -> s + -> m (a, s) +runLensT (LensT m) = runRST m +{-# INLINE runLensT #-} + + +------------------------------------------------------------------------------ +withLensT :: Monad m => + ((Lens b' v') -> (Lens b v)) + -> LensT b v s m a + -> LensT b' v' s m a +withLensT f (LensT m) = LensT $ withRST f m +{-# INLINE withLensT #-} + + +------------------------------------------------------------------------------ +withTop :: Monad m + => (Lens b v') + -> LensT b v' s m a + -> LensT b v s m a +withTop !subLens = withLensT (const subLens) +{-# INLINE withTop #-} + + +------------------------------------------------------------------------------ +with :: Monad m + => (Lens v v') + -> LensT b v' s m a + -> LensT b v s m a +with !subLens = withLensT (subLens .) +{-# INLINE with #-} + + diff --git a/src/Snap/Snaplet/Internal/Lensed.hs b/src/Snap/Snaplet/Internal/Lensed.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/Lensed.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Snap.Snaplet.Internal.Lensed where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Data.Lens.Strict +import Control.Monad.CatchIO +import Control.Monad.Reader.Class +import Control.Monad.State.Class +import Control.Monad.State.Strict +import Control.Category +import Prelude hiding (catch, id, (.)) +import Snap.Core + + +------------------------------------------------------------------------------ +newtype Lensed b v m a = Lensed + { unlensed :: Lens b v -> v -> b -> m (a, v, b) } + + +------------------------------------------------------------------------------ +instance Functor m => Functor (Lensed b v m) where + fmap f (Lensed g) = Lensed $ \l v s -> + (\(a,v',s') -> (f a, v', s')) <$> g l v s + + +------------------------------------------------------------------------------ +instance (Functor m, Monad m) => Applicative (Lensed b v m) where + pure a = Lensed $ \_ v s -> return (a, v, s) + Lensed mf <*> Lensed ma = Lensed $ \l v s -> do + (f, v', s') <- mf l v s + (\(a,v'',s'') -> (f a, v'', s'')) <$> ma l v' s' + + +------------------------------------------------------------------------------ +instance Monad m => Monad (Lensed b v m) where + return a = Lensed $ \_ v s -> return (a, v, s) + Lensed g >>= k = Lensed $ \l v s -> do + (a, v', s') <- g l v s + unlensed (k a) l v' s' + + +------------------------------------------------------------------------------ +instance Monad m => MonadState v (Lensed b v m) where + get = Lensed $ \_ v s -> return (v, v, s) + put v' = Lensed $ \_ _ s -> return ((), v', s) + + +------------------------------------------------------------------------------ +instance Monad m => MonadReader (Lens b v) (Lensed b v m) where + ask = Lensed $ \l v s -> return (l, v, s) + local f g = do + l' <- asks f + withTop l' g + + +------------------------------------------------------------------------------ +instance MonadTrans (Lensed b v) where + lift m = Lensed $ \_ v b -> do + res <- m + return (res, v, b) + + +------------------------------------------------------------------------------ +instance MonadIO m => MonadIO (Lensed b v m) where + liftIO = lift . liftIO + + +------------------------------------------------------------------------------ +instance MonadCatchIO m => MonadCatchIO (Lensed b v m) where + catch (Lensed m) f = Lensed $ \l v b -> m l v b `catch` handler l v b + where + handler l v b e = let (Lensed h) = f e + in h l v b + + block (Lensed m) = Lensed $ \l v b -> block (m l v b) + unblock (Lensed m) = Lensed $ \l v b -> unblock (m l v b) + + +------------------------------------------------------------------------------ +instance MonadPlus m => MonadPlus (Lensed b v m) where + mzero = lift mzero + m `mplus` n = Lensed $ \l v b -> + unlensed m l v b `mplus` unlensed n l v b + + +------------------------------------------------------------------------------ +instance (Monad m, Alternative m) => Alternative (Lensed b v m) where + empty = lift empty + (Lensed m) <|> (Lensed n) = Lensed $ \l v b -> m l v b <|> n l v b + + +------------------------------------------------------------------------------ +instance MonadSnap m => MonadSnap (Lensed b v m) where + liftSnap = lift . liftSnap + + +------------------------------------------------------------------------------ +getBase :: Monad m => Lensed b v m b +getBase = Lensed $ \_ v b -> return (b, v, b) + + +------------------------------------------------------------------------------ +withTop :: Monad m => Lens b v' -> Lensed b v' m a -> Lensed b v m a +withTop l m = globally $ lensedAsState m l + + +------------------------------------------------------------------------------ +with :: Monad m => Lens v v' -> Lensed b v' m a -> Lensed b v m a +with l g = do + l' <- asks (l .) + withTop l' g + + +------------------------------------------------------------------------------ +embed :: Monad m => Lens v v' -> Lensed v v' m a -> Lensed b v m a +embed l m = locally $ lensedAsState m l + + +------------------------------------------------------------------------------ +globally :: Monad m => StateT b m a -> Lensed b v m a +globally (StateT f) = Lensed $ \l v s -> + liftM (\(a, s') -> (a, l ^$ s', s')) $ f (l ^= v $ s) + + +------------------------------------------------------------------------------ +locally :: Monad m => StateT v m a -> Lensed b v m a +locally (StateT f) = Lensed $ \_ v s -> + liftM (\(a, v') -> (a, v', s)) $ f v + + +------------------------------------------------------------------------------ +lensedAsState :: Monad m => Lensed b v m a -> Lens b v -> StateT b m a +lensedAsState (Lensed f) l = StateT $ \s -> do + (a, v', s') <- f l (l ^$ s) s + return (a, l ^= v' $ s') + + +------------------------------------------------------------------------------ +runLensed :: Monad m + => Lensed t1 b m t + -> Lens t1 b + -> t1 + -> m (t, t1) +runLensed (Lensed f) l s = do + (a, v', s') <- f l (l ^$ s) s + return (a, l ^= v' $ s') + diff --git a/src/Snap/Snaplet/Internal/RST.hs b/src/Snap/Snaplet/Internal/RST.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/RST.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Snap.Snaplet.Internal.RST where + +import Control.Applicative +import Control.Category +import Control.Monad.CatchIO +import Control.Monad.Reader +import Control.Monad.State.Class +import Prelude hiding ((.), id, catch) +import Snap.Core + + +------------------------------------------------------------------------------ +-- like RWST, but no writer to bog things down. Also assured strict, inlined +-- monad bind, etc +newtype RST r s m a = RST { runRST :: r -> s -> m (a, s) } + + +evalRST :: Monad m => RST r s m a -> r -> s -> m a +evalRST m r s = do + (a,_) <- runRST m r s + return a +{-# INLINE evalRST #-} + + +execRST :: Monad m => RST r s m a -> r -> s -> m s +execRST m r s = do + (_,!s') <- runRST m r s + return s' +{-# INLINE execRST #-} + + +withRST :: Monad m => (r' -> r) -> RST r s m a -> RST r' s m a +withRST f m = RST $ \r' s -> runRST m (f r') s +{-# INLINE withRST #-} + + +instance (Monad m) => MonadReader r (RST r s m) where + ask = RST $ \r s -> return (r,s) + local f m = RST $ \r s -> runRST m (f r) s + + +instance (Functor m) => Functor (RST r s m) where + fmap f m = RST $ \r s -> fmap (\(a,s') -> (f a, s')) $ runRST m r s + + +instance (Functor m, Monad m) => Applicative (RST r s m) where + pure = return + (<*>) = ap + + +instance (Functor m, MonadPlus m) => Alternative (RST r s m) where + empty = mzero + (<|>) = mplus + + +instance (Monad m) => MonadState s (RST r s m) where + get = RST $ \_ s -> return (s,s) + put x = RST $ \_ _ -> return ((),x) + + +mapRST :: (m (a, s) -> n (b, s)) -> RST r s m a -> RST r s n b +mapRST f m = RST $ \r s -> f (runRST m r s) + + +instance (MonadCatchIO m) => MonadCatchIO (RST r s m) where + m `catch` f = RST $ \r s -> runRST m r s + `catch` \e -> runRST (f e) r s + block = mapRST block + unblock = mapRST unblock + +instance (MonadSnap m) => MonadSnap (RST r s m) where + liftSnap s = lift $ liftSnap s + +rwsBind :: Monad m => + RST r s m a + -> (a -> RST r s m b) + -> RST r s m b +rwsBind m f = RST go + where + go r !s = do + (a, !s') <- runRST m r s + runRST (f a) r s' +{-# INLINE rwsBind #-} + +instance (Monad m) => Monad (RST r s m) where + return a = RST $ \_ s -> return (a, s) + (>>=) = rwsBind + fail msg = RST $ \_ _ -> fail msg + + +instance (MonadPlus m) => MonadPlus (RST r s m) where + mzero = RST $ \_ _ -> mzero + m `mplus` n = RST $ \r s -> runRST m r s `mplus` runRST n r s + + +instance MonadTrans (RST r s) where + lift m = RST $ \_ s -> do + a <- m + return $ s `seq` (a, s) + +instance (MonadIO m) => MonadIO (RST r s m) where + liftIO = lift . liftIO + + + diff --git a/src/Snap/Snaplet/Internal/Types.hs b/src/Snap/Snaplet/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Internal/Types.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} + +module Snap.Snaplet.Internal.Types where + +import Prelude hiding ((.)) +import Control.Applicative +import Control.Category ((.)) +import Control.Monad.CatchIO hiding (Handler) +import Control.Monad.Reader +import Control.Monad.State.Class +import Control.Monad.Trans.Writer hiding (pass) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Configurator.Types +import Data.IORef +import Data.Monoid +import Data.Lens.Lazy +import Data.Lens.Template +import Data.Text (Text) +import qualified Data.Text as T + +import Snap.Core +import qualified Snap.Snaplet.Internal.LensT as LT +import qualified Snap.Snaplet.Internal.Lensed as L + + +------------------------------------------------------------------------------ +-- | An opaque data type holding internal snaplet configuration data. It is +-- exported publicly because the getOpaqueConfig function in MonadSnaplet +-- makes implementing new instances of MonadSnaplet more convenient. +data SnapletConfig = SnapletConfig + { _scAncestry :: [Text] + , _scFilePath :: FilePath + , _scId :: Maybe Text + , _scDescription :: Text + , _scUserConfig :: Config + , _scRouteContext :: [ByteString] + , _reloader :: IO (Either String String) -- might change + } + + +------------------------------------------------------------------------------ +-- | Joins a reversed list of directories into a path. +buildPath :: [ByteString] -> ByteString +buildPath ps = B.intercalate "/" $ reverse ps + + +------------------------------------------------------------------------------ +-- | Joins a reversed list of directories into a path. +getRootURL :: SnapletConfig -> ByteString +getRootURL sc = buildPath $ _scRouteContext sc + + +------------------------------------------------------------------------------ +-- | Snaplet's type parameter 's' here is user-defined and can be any Haskell +-- type. A value of type @Snaplet s@ countains a couple of things: +-- +-- * a value of type @s@, called the \"user state\". +-- +-- * some bookkeeping data the framework uses to plug things together, like +-- the snaplet's configuration, the snaplet's root directory on the +-- filesystem, the snaplet's root URL, and so on. +data Snaplet s = Snaplet + { _snapletConfig :: SnapletConfig + , _snapletValue :: s + } + + +makeLenses [''SnapletConfig, ''Snaplet] + + +------------------------------------------------------------------------------ +-- | A lens referencing the opaque SnapletConfig data type held inside +-- Snaplet. +snapletConfig :: Lens (Snaplet a) SnapletConfig + + +------------------------------------------------------------------------------ +-- | A lens referencing the user-defined state type wrapped by a Snaplet. +snapletValue :: Lens (Snaplet a) a + + +------------------------------------------------------------------------------ +-- | Transforms a lens of the type you get from makeLenses to an similar lens +-- that is more suitable for internal use. +subSnaplet :: (Lens a (Snaplet b)) -> (Lens (Snaplet a) (Snaplet b)) +subSnaplet = (. snapletValue) + + +------------------------------------------------------------------------------ +-- | The m type parameter used in the MonadSnaplet type signatures will +-- usually be either Initializer or Handler, but other monads may sometimes be +-- useful. +-- +-- Minimal complete definition: +-- +-- * 'withTop'', 'with'', 'getLens', and 'getOpaqueConfig'. +-- +class MonadSnaplet m where + -- | Runs a child snaplet action in the current snaplet's context. If you + -- think about snaplet lenses using a filesystem path metaphor, the lens + -- supplied to this snaplet must be a relative path. In other words, the + -- lens's base state must be the same as the current snaplet. + with :: (Lens v (Snaplet v')) + -- ^ A relative lens identifying a snaplet + -> m b v' a + -- ^ Action from the lense's snaplet + -> m b v a + with = with' . subSnaplet + + -- | Like 'with' but doesn't impose the requirement that the action + -- being run be a descendant of the current snaplet. Using our filesystem + -- metaphor again, the lens for this function must be an absolute + -- path--it's base must be the same as the current base. + withTop :: (Lens b (Snaplet v')) + -- ^ An \"absolute\" lens identifying a snaplet + -> m b v' a + -- ^ Action from the lense's snaplet + -> m b v a + withTop l = withTop' (subSnaplet l) + + -- | A variant of 'with' accepting a lens from snaplet to snaplet. Unlike + -- the lens used in the above 'with' function, this lens formulation has + -- an identity, which makes it useful in certain circumstances. The + -- lenses generated by 'makeLenses' will not work with this function, + -- however the lens returned by 'getLens' will. + -- + -- @with = with' . subSnaplet@ + with' :: (Lens (Snaplet v) (Snaplet v')) -> m b v' a -> m b v a + + -- Not providing a definition for this function in terms of withTop' + -- allows us to avoid extra Monad type class constraints, making the type + -- signature easier to read. + -- with' l m = flip withTop m . (l .) =<< getLens + + -- | The absolute version of 'with'' + withTop' :: (Lens (Snaplet b) (Snaplet v')) -> m b v' a -> m b v a + + -- | Gets the lens for the current snaplet. + getLens :: m b v (Lens (Snaplet b) (Snaplet v)) + + -- | Gets the current snaplet's opaque config data type. You'll only use + -- this function when writing MonadSnaplet instances. + getOpaqueConfig :: m b v SnapletConfig + -- NOTE: We can't just use a MonadState (Snaplet v) instance for this + -- because Initializer has SnapletConfig, but doesn't have a full Snaplet. + + +------------------------------------------------------------------------------ +-- | Gets a list of the names of snaplets that are direct ancestors of the +-- current snaplet. +getSnapletAncestry :: (Monad (m b v), MonadSnaplet m) => m b v [Text] +getSnapletAncestry = return . _scAncestry =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets the snaplet's path on the filesystem. +getSnapletFilePath :: (Monad (m b v), MonadSnaplet m) => m b v FilePath +getSnapletFilePath = return . _scFilePath =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets the current snaple's name. +getSnapletName :: (Monad (m b v), MonadSnaplet m) => m b v (Maybe Text) +getSnapletName = return . _scId =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets a human readable description of the snaplet. +getSnapletDescription :: (Monad (m b v), MonadSnaplet m) => m b v Text +getSnapletDescription = return . _scDescription =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets the config data structure for the current snaplet. +getSnapletUserConfig :: (Monad (m b v), MonadSnaplet m) => m b v Config +getSnapletUserConfig = return . _scUserConfig =<< getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Gets the base URL for the current snaplet. Directories get added to +-- the current snaplet path by calls to 'nestSnaplet'. +getSnapletRootURL :: (Monad (m b v), MonadSnaplet m) => m b v ByteString +getSnapletRootURL = liftM getRootURL getOpaqueConfig + + +------------------------------------------------------------------------------ +-- | Snaplet infrastructure is available during runtime request processing +-- through the Handler monad. There aren't very many standalone functions to +-- read about here, but this is deceptive. The key is in the type class +-- instances. Handler is an instance of 'MonadSnap', which means it is the +-- monad you will use to write all your application routes. It also has a +-- 'MonadSnaplet' instance, which gives you all the functionality described +-- above. +newtype Handler b v a = + Handler (L.Lensed (Snaplet b) (Snaplet v) Snap a) + deriving ( Monad + , Functor + , Applicative + , MonadIO + , MonadPlus + , MonadCatchIO + , Alternative + , MonadSnap) + + +------------------------------------------------------------------------------ +-- | Gets the @Snaplet v@ from the current snaplet's state. +getSnapletState :: Handler b v (Snaplet v) +getSnapletState = Handler get + + +------------------------------------------------------------------------------ +-- | Puts a new @Snaplet v@ in the current snaplet's state. +putSnapletState :: Snaplet v -> Handler b v () +putSnapletState = Handler . put + + +------------------------------------------------------------------------------ +-- | Modifies the @Snaplet v@ in the current snaplet's state. +modifySnapletState :: (Snaplet v -> Snaplet v) -> Handler b v () +modifySnapletState f = do + s <- getSnapletState + putSnapletState (f s) + + +------------------------------------------------------------------------------ +-- | Gets the @Snaplet v@ from the current snaplet's state and applies a +-- function to it. +getsSnapletState :: (Snaplet v -> b) -> Handler b1 v b +getsSnapletState f = do + s <- getSnapletState + return (f s) + + +------------------------------------------------------------------------------ +-- | The MonadState instance gives you access to the current snaplet's state. +instance MonadState v (Handler b v) where + get = getsSnapletState _snapletValue + put v = modifySnapletState (setL snapletValue v) + + +instance MonadSnaplet Handler where + getLens = Handler ask + with' !l (Handler !m) = Handler $ L.with l m + withTop' !l (Handler m) = Handler $ L.withTop l m + getOpaqueConfig = Handler $ gets _snapletConfig + + +------------------------------------------------------------------------------ +-- | Handler that reloads the site. +reloadSite :: Handler b v () +reloadSite = failIfNotLocal $ do + cfg <- getOpaqueConfig + !res <- liftIO $ _reloader cfg + either bad good res + where + bad msg = do + writeText $ "Error reloading site!\n\n" + writeText $ T.pack msg + good msg = do + writeText $ T.pack msg + writeText $ "Site successfully reloaded.\n" + failIfNotLocal m = do + rip <- liftM rqRemoteAddr getRequest + if not $ elem rip [ "127.0.0.1" + , "localhost" + , "::1" ] + then pass + else m + + +------------------------------------------------------------------------------ +-- | Information about a partially constructed initializer. Used to +-- automatically aggregate handlers and cleanup actions. +data InitializerState b = InitializerState + { _isTopLevel :: Bool + , _cleanup :: IO () + , _handlers :: [(ByteString, Handler b b ())] + -- ^ Handler routes built up and passed to route. + , _hFilter :: Handler b b () -> Handler b b () + -- ^ Generic filtering of handlers + , _curConfig :: SnapletConfig + -- ^ This snaplet config is the incrementally built config for whatever + -- snaplet is currently being constructed. + , _initMessages :: IORef Text + } + + +------------------------------------------------------------------------------ +-- | Wrapper around IO actions that modify state elements created during +-- initialization. +newtype Hook a = Hook (Snaplet a -> IO (Snaplet a)) + + +instance Monoid (Hook a) where + mempty = Hook return + (Hook a) `mappend` (Hook b) = Hook (a >=> b) + + +------------------------------------------------------------------------------ +-- | Monad used for initializing snaplets. +newtype Initializer b v a = + Initializer (LT.LensT (Snaplet b) + (Snaplet v) + (InitializerState b) + (WriterT (Hook b) IO) + a) + deriving (Applicative, Functor, Monad, MonadIO) + +makeLenses [''InitializerState] + + +instance MonadSnaplet Initializer where + getLens = Initializer ask + with' !l (Initializer !m) = Initializer $ LT.with l m + withTop' !l (Initializer m) = Initializer $ LT.withTop l m + getOpaqueConfig = Initializer $ liftM _curConfig LT.getBase + + +------------------------------------------------------------------------------ +-- | Opaque newtype which gives us compile-time guarantees that the user is +-- using makeSnaplet and either nestSnaplet or embedSnaplet correctly. +newtype SnapletInit b v = SnapletInit (Initializer b v (Snaplet v)) + + +------------------------------------------------------------------------------ +-- | Information needed to reload a site. Instead of having snaplets define +-- their own reload actions, we store the original site initializer and use it +-- instead. +data ReloadInfo b = ReloadInfo + { riRef :: IORef (Snaplet b) + , riAction :: Initializer b b b + } + diff --git a/src/Snap/Snaplet/Session.hs b/src/Snap/Snaplet/Session.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session.hs @@ -0,0 +1,107 @@ +module Snap.Snaplet.Session + +( + SessionManager + , withSession + , commitSession + , setInSession + , getFromSession + , deleteFromSession + , csrfToken + , sessionToList + , resetSession + , touchSession + +) where + +import Control.Monad.State +import Data.Lens.Lazy +import Data.Text (Text) + +import Snap.Snaplet +import Snap.Core + +import Snap.Snaplet.Session.SessionManager + ( SessionManager(..), ISessionManager(..) ) +import qualified Snap.Snaplet.Session.SessionManager as SM + + + +-- | Wrap around a handler, committing any changes in the session at the end +withSession :: (Lens b (Snaplet SessionManager)) + -> Handler b v a + -> Handler b v a +withSession l h = do + a <- h + withTop l commitSession + return a + + +-- | Commit changes to session within the current request cycle +commitSession :: Handler b SessionManager () +commitSession = do + SessionManager b <- loadSession + liftSnap $ commit b + + +-- | Set a key-value pair in the current session +setInSession :: Text -> Text -> Handler b SessionManager () +setInSession k v = do + SessionManager r <- loadSession + let r' = SM.insert k v r + put $ SessionManager r' + + +-- | Get a key from the current session +getFromSession :: Text -> Handler b SessionManager (Maybe Text) +getFromSession k = do + SessionManager r <- loadSession + return $ SM.lookup k r + + +-- | Remove a key from the current session +deleteFromSession :: Text -> Handler b SessionManager () +deleteFromSession k = do + SessionManager r <- loadSession + let r' = SM.delete k r + put $ SessionManager r' + + +-- | Returns a CSRF Token unique to the current session +csrfToken :: Handler b SessionManager Text +csrfToken = do + mgr@(SessionManager r) <- loadSession + put mgr + return $ SM.csrf r + + +-- | Return session contents as an association list +sessionToList :: Handler b SessionManager [(Text, Text)] +sessionToList = do + SessionManager r <- loadSession + return $ SM.toList r + + +-- | Deletes the session cookie, effectively resetting the session +resetSession :: Handler b SessionManager () +resetSession = do + SessionManager r <- loadSession + r' <- liftSnap $ SM.reset r + put $ SessionManager r' + + +-- | Touch the session so the timeout gets refreshed +touchSession :: Handler b SessionManager () +touchSession = do + SessionManager r <- loadSession + let r' = SM.touch r + put $ SessionManager r' + + +-- | Load the session into the manager +loadSession :: Handler b SessionManager SessionManager +loadSession = do + SessionManager r <- get + r' <- liftSnap $ load r + return $ SessionManager r' + diff --git a/src/Snap/Snaplet/Session/Backends/CookieSession.hs b/src/Snap/Snaplet/Session/Backends/CookieSession.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/Backends/CookieSession.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Snap.Snaplet.Session.Backends.CookieSession + +( initCookieSessionManager ) where + +import Control.Monad.Reader +import Data.ByteString (ByteString) +import Data.Generics +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.Hashable (Hashable) +import Data.Serialize (Serialize) +import qualified Data.Serialize as S +import Data.Text (Text) +import Web.ClientSession + +import Snap.Core (Snap) +import Snap.Snaplet +import Snap.Snaplet.Session.Common (mkCSRFToken) +import Snap.Snaplet.Session.SessionManager +import Snap.Snaplet.Session.SecureCookie + + +-- | Session data are kept in a 'HashMap' for this backend +type Session = HashMap Text Text + + +-- | This is what the 'Payload' will be for the CookieSession backend +data CookieSession = CookieSession + { csCSRFToken :: Text + , csSession :: Session +} deriving (Eq, Show) + + +instance Serialize CookieSession where + put (CookieSession a b) = S.put (a,b) + get = (\(a,b) -> CookieSession a b) `fmap` S.get + +instance (Serialize k, Serialize v, Hashable k, Eq k) => + Serialize (HashMap k v) where + put = S.put . HM.toList + get = HM.fromList `fmap` S.get + + +mkCookieSession :: IO CookieSession +mkCookieSession = do + t <- liftIO $ mkCSRFToken + return $ CookieSession t HM.empty + + +-- | The manager data type to be stuffed into 'SessionManager' +data CookieSessionManager = CookieSessionManager { + session :: Maybe CookieSession + -- ^ Per request cache for 'CookieSession' + + , siteKey :: Key + -- ^ A long encryption key used for secure cookie transport + + , cookieName :: ByteString + -- ^ Cookie name for the session system + + , timeOut :: Maybe Int + -- ^ Session cookies will be considered "stale" after this many seconds. +} deriving (Show,Typeable) + + +loadDefSession :: CookieSessionManager -> IO CookieSessionManager +loadDefSession mgr@(CookieSessionManager ses _ _ _) = do + case ses of + Nothing -> do + ses' <- mkCookieSession + return $ mgr { session = Just ses' } + Just _ -> return mgr + + +modSession :: (Session -> Session) -> CookieSession -> CookieSession +modSession f (CookieSession t ses) = CookieSession t (f ses) + + +-- | Initialize a cookie-backed session, returning a 'SessionManager' to be +-- stuffed inside your application's state. This 'SessionManager' will enable +-- the use of all session storage functionality defined in +-- 'Snap.Snaplet.Session' +initCookieSessionManager + :: FilePath -- ^ Path to site-wide encryption key + -> ByteString -- ^ Session cookie name + -> Maybe Int -- ^ Session time-out (replay attack protection) + -> SnapletInit b SessionManager +initCookieSessionManager fp cn to = + makeSnaplet "CookieSession" "A snaplet providing sessions via HTTP cookies." + Nothing $ liftIO $ do + key <- getKey fp + return . SessionManager $ CookieSessionManager Nothing key cn to + + +instance ISessionManager CookieSessionManager where + load mgr@(CookieSessionManager r _ _ _) = do + case r of + Just _ -> return mgr + Nothing -> do + pl <- getPayload mgr + case pl of + Nothing -> liftIO $ loadDefSession mgr + Just (Payload x) -> do + let c = S.decode x + case c of + Left _ -> liftIO $ loadDefSession mgr + Right cs -> return $ mgr { session = Just cs } + + commit mgr@(CookieSessionManager r _ _ _) = do + pl <- case r of + Just r' -> return . Payload $ S.encode r' + Nothing -> liftIO mkCookieSession >>= return . Payload . S.encode + setPayload mgr pl + + reset mgr = do + cs <- liftIO mkCookieSession + return $ mgr { session = Just cs } + + touch = id + + insert k v mgr@(CookieSessionManager r _ _ _) = case r of + Just r' -> mgr { session = Just $ modSession (HM.insert k v) r' } + Nothing -> mgr + + lookup k (CookieSessionManager r _ _ _) = r >>= HM.lookup k . csSession + + delete k mgr@(CookieSessionManager r _ _ _) = case r of + Just r' -> mgr { session = Just $ modSession (HM.delete k) r' } + Nothing -> mgr + + csrf (CookieSessionManager r _ _ _) = case r of + Just r' -> csCSRFToken r' + Nothing -> "" + + toList (CookieSessionManager r _ _ _) = case r of + Just r' -> HM.toList . csSession $ r' + Nothing -> [] + + + +-- | A session payload to be stored in a SecureCookie. +newtype Payload = Payload ByteString + deriving (Eq, Show, Ord, Serialize) + + +-- | Get the current client-side value +getPayload :: CookieSessionManager -> Snap (Maybe Payload) +getPayload mgr = getSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr) + + +-- | Set the client-side value +setPayload :: CookieSessionManager -> Payload -> Snap () +setPayload mgr x = + setSecureCookie (cookieName mgr) (siteKey mgr) (timeOut mgr) x + + diff --git a/src/Snap/Snaplet/Session/Common.hs b/src/Snap/Snaplet/Session/Common.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/Common.hs @@ -0,0 +1,41 @@ +{-| + + This module contains functionality common among multiple back-ends. + +-} + +module Snap.Snaplet.Session.Common where + + +import Numeric +import Data.Serialize +import qualified Data.Serialize as S +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.Text.Encoding as T +import Data.Text (Text) +import System.Random.MWC + + +------------------------------------------------------------------------------ +-- | Generates a random salt of given length +randomToken :: Int -> IO ByteString +randomToken n = + let + mk :: GenIO -> IO Int + mk gen = uniformR (0,15) gen + in do + is <- withSystemRandom $ \gen -> sequence . take n . repeat $ mk gen + return . B.pack . concat . map (flip showHex "") $ is + + +------------------------------------------------------------------------------ +-- | Generate a randomized CSRF token +mkCSRFToken :: IO Text +mkCSRFToken = T.decodeUtf8 `fmap` randomToken 40 + + +instance Serialize Text where + put = S.put . T.encodeUtf8 + get = T.decodeUtf8 `fmap` S.get + diff --git a/src/Snap/Snaplet/Session/SecureCookie.hs b/src/Snap/Snaplet/Session/SecureCookie.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/SecureCookie.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| + + This is a support module meant to back all session back-end implementations. + + It gives us an encrypted and timestamped cookie that can store an arbitrary + serializable payload. For security, it will: + + * Encrypt its payload together with a timestamp. + + * Check the timestamp for session expiration everytime you read from the + cookie. This will limit intercept-and-replay attacks by disallowing + cookies older than the timeout threshold. + +-} + +module Snap.Snaplet.Session.SecureCookie where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans + +import Data.ByteString (ByteString) +import Data.Time +import Data.Time.Clock.POSIX + +import Data.Serialize +import Web.ClientSession + +import Snap.Core + + + +------------------------------------------------------------------------------ +-- | Serialize UTCTime +instance Serialize UTCTime where + put t = put (round (utcTimeToPOSIXSeconds t) :: Integer) + get = posixSecondsToUTCTime . fromInteger <$> get + + +------------------------------------------------------------------------------ +-- | Arbitrary payload with timestamp. +type SecureCookie t = (UTCTime, t) + + +------------------------------------------------------------------------------ +-- Get the payload back +getSecureCookie :: (MonadSnap m, Serialize t) + => ByteString -- ^ Cookie name + -> Key -- ^ Encryption key + -> Maybe Int -- ^ Timeout in seconds + -> m (Maybe t) +getSecureCookie name key timeout = do + rqCookie <- getCookie name + rspCookie <- getResponseCookie name `fmap` getResponse + let ck = rspCookie `mplus` rqCookie + let val = fmap cookieValue ck >>= decrypt key >>= return . decode + let val' = val >>= either (const Nothing) Just + case val' of + Nothing -> return Nothing + Just (ts, t) -> do + to <- checkTimeout timeout ts + return $ case to of + True -> Nothing + False -> Just t + + +------------------------------------------------------------------------------ +-- | Inject the payload +setSecureCookie :: (MonadSnap m, Serialize t) + => ByteString -- ^ Cookie name + -> Key -- ^ Encryption key + -> Maybe Int -- ^ Max age in seconds + -> t -- ^ Serializable payload + -> m () +setSecureCookie name key to val = do + t <- liftIO getCurrentTime + let expire = to >>= Just . flip addUTCTime t . fromIntegral + val' <- liftIO . encryptIO key . encode $ (t, val) + let nc = Cookie name val' expire Nothing (Just "/") False True + modifyResponse $ addResponseCookie nc + + +------------------------------------------------------------------------------ +-- | Validate session against timeout policy. +-- +-- * If timeout is set to 'Nothing', never trigger a time-out. +-- * Othwerwise, do a regular time-out check based on current time and given +-- timestamp. +checkTimeout :: (MonadSnap m) => Maybe Int -> UTCTime -> m Bool +checkTimeout Nothing _ = return False +checkTimeout (Just x) t0 = + let x' = fromIntegral x + in do + t1 <- liftIO getCurrentTime + return $ t1 > addUTCTime x' t0 diff --git a/src/Snap/Snaplet/Session/SessionManager.hs b/src/Snap/Snaplet/Session/SessionManager.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/SessionManager.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module Snap.Snaplet.Session.SessionManager where + +import Data.Text (Text) +import Prelude hiding (lookup) + +import Snap.Core (Snap) + + +-- | Any Haskell record that is a member of the 'ISessionManager' typeclass +-- can be stuffed inside a 'SessionManager' to enable all session-related +-- functionality. +data SessionManager = forall a. ISessionManager a => SessionManager a + + +class ISessionManager r where + + -- | Load a session from given payload. + -- + -- Will always be called before any other operation. If possible, cache and + -- do nothing when called multiple times within the same request cycle. + load :: r -> Snap r + + -- | Commit session, return a possibly updated paylaod + commit :: r -> Snap () + + -- | Reset session + reset :: r -> Snap r + + -- | Touch session + touch :: r -> r + + -- | Insert a key-value pair into session + insert :: Text -> Text -> r -> r + + -- | Lookup a key in session + lookup :: Text -> r -> (Maybe Text) + + -- | Delete a key in session + delete :: Text -> r -> r + + -- | Return a session-specific CSRF protection token. See 'mkCSRFToken' for + -- help in creating the value. + csrf :: r -> Text + + -- | Return all key-value pairs as an association list + toList :: r -> [(Text,Text)] + diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs --- a/src/Snap/Starter.hs +++ b/src/Snap/Starter.hs @@ -19,8 +19,9 @@ ------------------------------------------------------------------------------ -- Creates a value tDir :: ([String], [(String, String)]) -$(buildData "tDirBareBones" "barebones") -$(buildData "tDirDefault" "default") +buildData "tDirBareBones" "barebones" +buildData "tDirDefault" "default" +buildData "tDirTutorial" "tutorial" ------------------------------------------------------------------------------ usage :: String @@ -41,9 +42,30 @@ ------------------------------------------------------------------------------ -data InitFlag = InitBareBones - | InitHelp - | InitExtensions +initUsage :: String +initUsage = unlines + [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter" + , "" + , "Usage:" + , "" + , " snap init [type]" + , "" + , " [type] can be one of:" + , " default - A default project using snaplets and heist" + , " barebones - A barebones project with minimal dependencies" + , " tutorial - The literate Haskell tutorial project" + , "" + , " If [type] is omitted, the default project is generated." + ] + + +printUsage :: [String] -> IO () +printUsage ("init":_) = putStrLn initUsage +printUsage _ = putStrLn usage + +------------------------------------------------------------------------------ +-- Only one option for now +data Option = Help deriving (Show, Eq) @@ -65,42 +87,43 @@ initProject :: [String] -> IO () initProject args = do case getOpt Permute options args of - (flags, _, []) - | InitHelp `elem` flags -> do putStrLn initUsage - exitFailure - | otherwise -> init' flags + (flags, other, []) + | Help `elem` flags -> do printUsage other + exitFailure + | otherwise -> go other + (_, other, errs) -> do putStrLn $ concat errs + printUsage other + exitFailure - (_, _, errs) -> do putStrLn $ concat errs - putStrLn initUsage - exitFailure where - initUsage = usageInfo "Usage\n snap init\n\nOptions:" options - options = - [ Option ['b'] ["barebones"] (NoArg InitBareBones) - "Depend only on -core and -server" - , Option ['h'] ["help"] (NoArg InitHelp) + [ Option ['h'] ["help"] (NoArg Help) "Print this message" - , Option ['e'] ["extensions"] (NoArg InitExtensions) - "Depend on snap w/ extensions (default)" ] - init' flags = do + go ("init":rest) = init' rest + go _ = do + putStrLn "Error: Invalid action!" + putStrLn usage + exitFailure + + init' args' = do cur <- getCurrentDirectory let dirs = splitDirectories cur projName = last dirs setup' = setup projName - case flags of - (_:_) | InitBareBones `elem` flags -> setup' tDirBareBones - | InitExtensions `elem` flags -> setup' tDirDefault - _ -> setup' tDirDefault + case args' of + [] -> setup' tDirDefault + ["barebones"] -> setup' tDirBareBones + ["default"] -> setup' tDirDefault + ["tutorial"] -> setup' tDirTutorial + _ -> do + putStrLn initUsage + exitFailure ------------------------------------------------------------------------------ main :: IO () main = do args <- getArgs - case args of - ("init":args') -> initProject args' - _ -> do putStrLn usage - exitFailure + initProject args diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs --- a/src/Snap/StarterTH.hs +++ b/src/Snap/StarterTH.hs @@ -7,6 +7,7 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax import System.Directory.Tree +import System.FilePath ------------------------------------------------------------------------------ @@ -30,19 +31,18 @@ -- encountered and a list of filenames and content strings. readTree :: FilePath -> IO ([DirData], [FileData]) readTree dir = do - d <- readDirectory $ dir ++ "/." + d <- readDirectory $ dir "." let ps = zipPaths $ "" :/ (free d) fd = F.foldr (:) [] ps - dirs = tail . getDirs [] $ free d - - return (dirs, fd) + dirs = getDirs [] $ free d + return (drop 1 dirs, fd) ------------------------------------------------------------------------------ -- Calls readTree and returns it's value in a quasiquote. dirQ :: FilePath -> Q Exp dirQ tplDir = do - d <- runIO . readTree $ "project_template/" ++ tplDir + d <- runIO . readTree $ "project_template" tplDir lift d diff --git a/test/runTests.sh b/test/runTests.sh deleted file mode 100644 --- a/test/runTests.sh +++ /dev/null @@ -1,21 +0,0 @@ -#!/bin/sh - -set -e - -if [ -z "$DEBUG" ]; then - export DEBUG=testsuite -fi - -SUITE=./dist/build/testsuite/testsuite - -if [ ! -f $SUITE ]; then - cat </dev/null 2>&1 + +cat <= 1.6 -Executable testsuite - hs-source-dirs: suite +Executable snap-testsuite + hs-source-dirs: ../src suite main-is: TestSuite.hs build-depends: - QuickCheck >= 2.3.0.2, - base >= 4 && < 5, - bytestring == 0.9.*, + Glob >= 0.5 && < 0.7, + HUnit >= 1.2 && < 2, + MonadCatchIO-transformers >= 0.2 && < 0.3, + QuickCheck >= 2.3.0.2, + attoparsec (>= 0.8 && < 0.10), + base >= 4 && < 5, + bytestring >= 0.9 && < 0.10, + containers >= 0.3, + data-lens >= 2.0.1 && < 2.1, + data-lens-template >= 2.1.1 && < 2.2, directory, + directory-tree >= 0.10 && < 0.11, filepath, - Glob == 0.5.*, - HUnit >= 1.2 && < 2, - http-enumerator >= 0.7 && <0.8, - process == 1.*, - test-framework >= 0.3.1 && <0.5, - test-framework-hunit >= 0.2.5 && < 0.3, - test-framework-quickcheck2 >= 0.2.6 && < 0.3 - - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded + heist >= 0.6 && < 0.7, + http-enumerator >= 0.6.5.3 && < 0.8, + mtl >= 2, + process == 1.*, + snap-core >= 0.6 && < 0.7, + snap-server >= 0.6 && < 0.7, + test-framework >= 0.4 && < 0.5, + test-framework-hunit >= 0.2.5 && < 0.3, + test-framework-quickcheck2 >= 0.2.6 && < 0.3, + text >= 0.11 && < 0.12, + transformers >= 0.2, + unix >= 2.2.0.0 && < 2.6, + utf8-string >= 0.3 && < 0.4, + template-haskell +-- FIXME + + ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded -fno-warn-unused-do-bind + + +Executable app + hs-source-dirs: ../src suite + main-is: AppMain.hs + + build-depends: + MonadCatchIO-transformers >= 0.2 && < 0.3, + attoparsec (>= 0.8 && < 0.10), + base >= 4 && < 5, + bytestring >= 0.9 && < 0.10, + cereal >= 0.3, + clientsession >= 0.6.0, + configurator == 0.1.*, + containers >= 0.3, + data-lens >= 2.0.1 && < 2.1, + data-lens-template >= 2.1.1 && < 2.2, + directory, + directory-tree >= 0.10 && < 0.11, + filepath, + hashable >= 1.1, + heist >= 0.6 && < 0.7, + mtl >= 2, + mwc-random >= 0.8, + process == 1.*, + snap-core >= 0.6 && < 0.7, + snap-server >= 0.6 && < 0.7, + syb >= 0.1, + time >= 1.1, + text >= 0.11 && < 0.12, + transformers >= 0.2, + unordered-containers >= 0.1.4, + utf8-string >= 0.3 && < 0.4, + template-haskell + --FIXME + + ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded + -fno-warn-unused-do-bind + +Executable nesttest + hs-source-dirs: ../src suite + main-is: NestTest.hs + + build-depends: + MonadCatchIO-transformers >= 0.2 && < 0.3, + attoparsec (>= 0.8 && < 0.10), + base >= 4 && < 5, + bytestring >= 0.9 && < 0.10, + containers >= 0.3, + data-lens >= 2.0.1 && < 2.1, + data-lens-template >= 2.1 && < 2.2, + directory, + directory-tree >= 0.10 && < 0.11, + filepath, + heist >= 0.6 && < 0.7, + mtl >= 2, + process == 1.*, + snap-core >= 0.6 && < 0.7, + snap-server >= 0.6 && < 0.7, + text >= 0.11 && < 0.12, + transformers >= 0.2, + utf8-string >= 0.3 && < 0.4, + template-haskell + --FIXME + + ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded + -fno-warn-unused-do-bind + 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 @@ -16,7 +16,9 @@ import System.FilePath.Glob import System.Process hiding (cwd) +import SafeCWD + testGeneratedProject :: String -- ^ project name and directory -> String -- ^ arguments to @snap init@ -> String -- ^ arguments to @cabal install@ @@ -24,23 +26,28 @@ -> IO () -- ^ action to run when the server goes up -> IO () testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort - testAction = bracket initialize cleanup (const testAction) - where - initialize = do - cwd <- getCurrentDirectory - let projectPath = cwd projName - flip onException (setCurrentDirectory cwd >> - removeDirectoryRecursive projectPath) $ do - makeWorkDirectory projectPath - setCurrentDirectory projectPath + testAction = do + cwd <- getCurrentDirectory + let segments = reverse $ splitPath cwd + projectPath = cwd "test-snap-exe" projName + snapRoot = joinPath $ reverse $ drop 1 segments + snapRepos = joinPath $ reverse $ drop 2 segments + + sandbox = cwd "test-cabal-dev" + + cabalDevArgs = "-s " ++ sandbox + + args = cabalDevArgs ++ " " ++ cabalInstallArgs + + initialize = do snapExe <- findSnap systemOrDie $ snapExe ++ " init " ++ snapInitArgs - snapCoreSrc <- fromEnv "SNAP_CORE_SRC" "../../../snap-core" - snapServerSrc <- fromEnv "SNAP_SERVER_SRC" "../../../snap-server" - xmlhtmlSrc <- fromEnv "XMLHTML_SRC" "../../../xmlhtml" - heistSrc <- fromEnv "HEIST_SRC" "../../../heist" - let snapSrc = "../.." + snapCoreSrc <- fromEnv "SNAP_CORE_SRC" $ snapRepos "snap-core" + snapServerSrc <- fromEnv "SNAP_SERVER_SRC" $ snapRepos "snap-server" + xmlhtmlSrc <- fromEnv "XMLHTML_SRC" $ snapRepos "xmlhtml" + heistSrc <- fromEnv "HEIST_SRC" $ snapRepos "heist" + let snapSrc = snapRoot forM_ [ "snap-core", "snap-server", "xmlhtml", "heist", "snap" ] (pkgCleanUp sandbox) @@ -56,24 +63,32 @@ putStrLn $ "Running \"" ++ cmd ++ "\"" pHandle <- runCommand cmd waitABit - return (cwd, projectPath, pHandle) + return pHandle + findSnap = do + home <- fromEnv "HOME" "." + p1 <- gimmeIfExists $ snapRoot "dist" "build" "snap" "snap" + p2 <- gimmeIfExists $ home ".cabal" "bin" "snap" + p3 <- findExecutable "snap" + + return $ fromMaybe (error "couldn't find snap executable") + (getFirst $ mconcat $ map First [p1,p2,p3]) + + putStrLn $ "Changing directory to "++projectPath + inDir True projectPath $ bracket initialize cleanup (const testAction) + removeDirectoryRecursiveSafe projectPath + where + fromEnv name def = do r <- getEnv name `catch` \(_::SomeException) -> return "" if r == "" then return def else return r - cleanup (cwd, projectPath, pHandle) = do - setCurrentDirectory cwd + cleanup pHandle = do terminateProcess pHandle waitForProcess pHandle - removeDirectoryRecursive projectPath waitABit = threadDelay $ 2*10^(6::Int) - sandbox = "../test-cabal-dev" projName - - cabalDevArgs = "-s " ++ sandbox - pkgCleanUp d pkg = do paths <- globDir1 (compile $ "packages*conf/" ++ pkg ++ "-*") d forM_ paths @@ -83,23 +98,11 @@ putStrLn $ "removing " ++ x removeFile x - args = cabalDevArgs ++ " " ++ cabalInstallArgs - gimmeIfExists p = do b <- doesFileExist p if b then return (Just p) else return Nothing - findSnap = do - home <- fromEnv "HOME" "." - p1 <- gimmeIfExists "../../dist/build/snap/snap" - p2 <- gimmeIfExists $ home ".cabal/bin/snap" - p3 <- findExecutable "snap" - - return $ fromMaybe (error "couldn't find snap executable") - (getFirst $ mconcat $ map First [p1,p2,p3]) - - systemOrDie :: String -> IO () systemOrDie s = do putStrLn $ "Running \"" ++ s ++ "\"" @@ -107,9 +110,3 @@ where check ExitSuccess = return () check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'" - - -makeWorkDirectory :: FilePath -> IO () -makeWorkDirectory p = do - doesDirectoryExist p >>= flip when (removeDirectoryRecursive p) - createDirectory p diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -2,34 +2,83 @@ module Main where +import Control.Concurrent +import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import qualified Network.HTTP.Enumerator as HTTP -import Test.Framework (defaultMain, Test) +import Snap.Http.Server.Config +import Snap.Snaplet +import System.Posix.Process +import System.Posix.Types +--import Test.Framework (defaultMain, Test) +import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test, path) +import Snap.Http.Server (simpleHttpServe) +import Blackbox.App +import qualified Blackbox.Tests +import qualified Snap.Snaplet.Internal.Lensed.Tests +import qualified Snap.Snaplet.Internal.LensT.Tests +import qualified Snap.Snaplet.Internal.RST.Tests +import qualified Snap.Snaplet.Internal.Tests import Snap.TestCommon +import SafeCWD + + +------------------------------------------------------------------------------ main :: IO () -main = defaultMain tests - where tests = [ testBarebones +main = do + Blackbox.Tests.remove "non-cabal-appdir/templates/bad.tpl" + Blackbox.Tests.remove "non-cabal-appdir/templates/good.tpl" + Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet" + + inDir False "non-cabal-appdir" startServer + threadDelay $ 2*10^(6::Int) + defaultMain tests + + where tests = [ internalServerTests , testDefault + , testBarebones + , testTutorial ] +internalServerTests :: Test +internalServerTests = + testGroup "internal server tests" + [ Blackbox.Tests.tests + , Snap.Snaplet.Internal.Lensed.Tests.tests + , Snap.Snaplet.Internal.LensT.Tests.tests + , Snap.Snaplet.Internal.RST.Tests.tests + , Snap.Snaplet.Internal.Tests.tests + ] + +startServer :: IO ProcessID +startServer = forkProcess $ serve (setPort 9753 defaultConfig) app + where + serve config initializer = do + (_, handler, doCleanup) <- runSnaplet initializer + (conf, site) <- combineConfig config handler + _ <- try $ simpleHttpServe conf $ site + :: IO (Either SomeException ()) + doCleanup + + testBarebones :: Test testBarebones = testCase "snap/barebones" go where go = testGeneratedProject "barebonesTest" - "-b" + "barebones" "" port testIt port = 9990 testIt = do - body <- HTTP.simpleHttp "http://127.0.0.1:9990" + body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port) assertEqual "server not up" "hello world" body @@ -44,9 +93,22 @@ port = 9991 testIt = do body <- liftM (S.concat . L.toChunks) $ - HTTP.simpleHttp "http://127.0.0.1:9991" + HTTP.simpleHttp $ "http://127.0.0.1:"++(show port) assertBool "response contains phrase 'it works!'" $ "It works!" `S.isInfixOf` body --- TODO: test hint code here +testTutorial :: Test +testTutorial = testCase "snap/tutorial" go + where + go = testGeneratedProject "tutorialTest" + "tutorial" + "" + port + testIt + port = 9992 + testIt = do + body <- HTTP.simpleHttp $ "http://127.0.0.1:"++(show port)++"/hello" + assertEqual "server not up" "hello world" body + +