snap (empty) → 0.3.0

raw patch · 28 files changed

+2143/−0 lines, 28 filesdep +MonadCatchIO-transformersdep +attoparsecdep +basesetup-changed

Dependencies added: MonadCatchIO-transformers, attoparsec, base, bytestring, bytestring-nums, cereal, containers, directory, directory-tree, dlist, enumerator, filepath, haskell98, heist, hint, mtl, old-locale, old-time, snap-core, snap-server, template-haskell, text, time, unix, unix-compat, zlib

Files

• CONTRIBUTORS +8/−0
• LICENSE +27/−0
• README.SNAP.md +42/−0
• README.md +62/−0
• Setup.hs +3/−0
• project_template/barebones/foo.cabal +29/−0
• project_template/barebones/src/Main.hs +21/−0
• project_template/default/foo.cabal +47/−0
• project_template/default/log/access.log +0/−0
• project_template/default/log/error.log +0/−0
• project_template/default/resources/static/screen.css +26/−0
• project_template/default/resources/templates/echo.tpl +14/−0
• project_template/default/resources/templates/index.tpl +33/−0
• project_template/default/src/Application.hs +58/−0
• project_template/default/src/Main.hs +63/−0
• project_template/default/src/Site.hs +56/−0
• project_template/default/src/Snap/Extension/Timer.hs +54/−0
• project_template/default/src/Snap/Extension/Timer/Impl.hs +67/−0
• snap.cabal +112/−0
• src/Snap/Extension.hs +502/−0
• src/Snap/Extension/Heist.hs +70/−0
• src/Snap/Extension/Heist/Impl.hs +197/−0
• src/Snap/Extension/Loader/Devel.hs +250/−0
• src/Snap/Extension/Loader/Devel/Helper.hs +43/−0
• src/Snap/Extension/Server.hs +153/−0
• src/Snap/Heist.hs +44/−0
• src/Snap/Starter.hs +105/−0
• src/Snap/StarterTH.hs +57/−0

@@ -0,0 +1,8 @@+Ozgun Ataman <ozataman@gmail.com>+Doug Beardsley <mightybyte@gmail.com>+Gregory Collins <greg@gregorycollins.net>+Shu-yu Guo <shu@rfrn.org>+Carl Howells <chowells79@gmail.com>+Shane O'Brien <shane@duairc.com>+James Sanders <jimmyjazz14@gmail.com>+Jacob Stanley <jystic@jystic.com>

@@ -0,0 +1,27 @@+Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS)+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this+list of conditions and the following disclaimer in the documentation and/or+other materials provided with the distribution.++Neither the name of the Snap Framework authors nor the names of its+contributors may be used to endorse or promote products derived from this+software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,42 @@+Snap Framework+--------------++Snap is a simple and fast web development framework and server written in+Haskell. For more information or to download the latest version, you can visit+the Snap project website at http://snapframework.com/.+++Snap Status and Features+------------------------++This developer prerelease contains only the Snap core system, namely:++  * a high-speed HTTP server, with an optional high-concurrency backend using+    the [libev](http://software.schmorp.de/pkg/libev.html) library++  * 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++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.+++Snap Philosophy+---------------++Snap aims to be the *de facto* web toolkit for Haskell, on the basis of:++  * High performance++  * High design standards++  * Simplicity and ease of use, even for Haskell beginners++  * Excellent documentation++  * Robustness and high test coverage

@@ -0,0 +1,62 @@+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)).+++## Library contents++This is the `snap` executable and supporting library, which contains:++  * a command-line utility for creating initial Snap applications++  * a library allowing Snap applications to recompile actions on the+    fly in development mode, with no performance loss in production+    mode.+++Building snap+=============++The snap tool and library are built using+ [Cabal](http://www.haskell.org/cabal/) and+[Hackage](http://hackage.haskell.org/packages/hackage.html). Just run++    cabal install++from the `snap` toplevel directory.+++## Building the Haddock Documentation++The haddock documentation can be built using the supplied `haddock.sh` shell+script:++    ./haddock.sh++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+    $ cabal build++From here you can invoke the testsuite by running:++    $ ./runTestsAndCoverage.sh+++The testsuite generates an `hpc` test coverage report in `test/dist/hpc`.

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

@@ -0,0 +1,29 @@+Name:                projname+Version:             0.1+Synopsis:            Project Synopsis Here+Description:         Project Description Here+License:             AllRightsReserved+Author:              Author+Maintainer:          maintainer@example.com+Stability:           Experimental+Category:            Web+Build-type:          Simple+Cabal-version:       >=1.2++Executable projname+  hs-source-dirs: src+  main-is: Main.hs++  Build-depends:+    base >= 4 && < 5,+    bytestring >= 0.9.1 && < 0.10,+    MonadCatchIO-transformers >= 0.2.1 && < 0.3,+    mtl >= 2 && < 3,+    snap-core >= 0.3 && <0.4,+    snap-server >= 0.3 && <0.4++  if impl(ghc >= 6.12.0)+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2+                 -fno-warn-unused-do-bind+  else+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2

@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import           Control.Applicative+import           Snap.Types+import           Snap.Util.FileServe+import           Snap.Http.Server++main :: IO ()+main = quickHttpServe $+    ifTop (writeBS "hello world") <|>+    route [ ("foo", writeBS "bar")+          , ("echo/:echoparam", echoHandler)+          ] <|>+    dir "static" (fileServe ".")++echoHandler :: Snap ()+echoHandler = do+    param <- getParam "echoparam"+    maybe (writeBS "must specify echo/param in URL")+          writeBS param

@@ -0,0 +1,47 @@+Name:                projname+Version:             0.1+Synopsis:            Project Synopsis Here+Description:         Project Description Here+License:             AllRightsReserved+Author:              Author+Maintainer:          maintainer@example.com+Stability:           Experimental+Category:            Web+Build-type:          Simple+Cabal-version:       >=1.2++Flag development+  Description: Whether to build the server in development (interpreted) mode+  Default: False++Executable projname+  hs-source-dirs: src+  main-is: Main.hs++  if !flag(development)+    cpp-options: -DPRODUCTION+  else+    build-depends: hint >= 0.3.2 && < 0.4++  Build-depends:+    base >= 4 && < 5,+    bytestring >= 0.9.1 && < 0.10,+    heist >= 0.4 && < 0.5,+    hexpat >= 0.19 && < 0.20,+    MonadCatchIO-transformers >= 0.2.1 && < 0.3,+    mtl >= 2 && < 3,+    snap >= 0.3 && < 0.4,+    snap-core >= 0.3 && < 0.4,+    snap-server >= 0.3 && <0.4,+    text >= 0.11 && < 0.12,+    time >= 1.1 && < 1.3++  extensions: TypeSynonymInstances MultiParamTypeClasses++  if impl(ghc >= 6.12.0)+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2+                 -fno-warn-orphans -fno-warn-unused-do-bind+  else+    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2+                 -fno-warn-orphans+

@@ -0,0 +1,26 @@+html {+   padding: 0;+   margin: 0;+   background-color: #ffffff;+   font-family: Verdana, Helvetica, sans-serif;+}+body {+   padding: 0;+   margin: 0;+}+a {+   text-decoration: underline;+}+a :hover {+   cursor: pointer;+   text-decoration: underline;+}+img {+   border: none;+}+#content {+   padding-left: 1em;+}+#info {+   font-size: 60%;+}

@@ -0,0 +1,14 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+  <head>+    <title>Echo Page</title>+  </head>+  <body>+    <div id="content">+      <h1>Is there an echo in here?</h1>+    </div>+    <p>You wanted me to say this?</p>+    <p>"<message/>"</p>+    <p><a href="/">Return</a></p>+  </body>+</html>

@@ -0,0 +1,33 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+  <head>+    <title>Snap web server</title>+    <link rel="stylesheet" type="text/css" href="screen.css"/>+  </head>+  <body>+    <div id="content">+      <h1>It works!</h1>+      <p>+        This is a simple demo page served using+        <a href="http://snapframework.com/docs/tutorials/heist">Heist</a>+        and the <a href="http://snapframework.com/">Snap</a> web framework.+      </p>+      <p>+        Echo test:+        <a href="/echo/cats">cats</a>+        <a href="/echo/dogs">dogs</a>+        <a href="/echo/fish">fish</a>+      </p>+      <table id="info">+        <tr>+          <td>Config generated at:</td>+          <td><start-time/></td>+        </tr>+        <tr>+          <td>Page generated at:</td>+          <td><current-time/></td>+        </tr>+      </table>+    </div>+  </body>+</html>

@@ -0,0 +1,58 @@+{-++This module defines our application's monad and any application-specific+information it requires.++-}++module Application+  ( Application+  , applicationInitializer+  ) where++import           Snap.Extension+import           Snap.Extension.Heist.Impl+import           Snap.Extension.Timer.Impl+++------------------------------------------------------------------------------+-- | '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+++------------------------------------------------------------------------------+-- | '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+    }+++------------------------------------------------------------------------------+instance HasHeistState Application ApplicationState where+    getHeistState     = templateState+    setHeistState s a = a { templateState = s }+++------------------------------------------------------------------------------+instance HasTimerState ApplicationState where+    getTimerState     = timerState+    setTimerState s a = a { timerState = s }+++------------------------------------------------------------------------------+-- | 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"+    timer <- timerInitializer+    return $ ApplicationState heist timer

@@ -0,0 +1,63 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++{-|++This is the entry point for this web server application.  It supports easily+switching between interpreting source and running statically compiled code.++In either mode, the generated program should be run from the root of the+project tree.  It locates its templates, static content, and source files in +development mode, relative to the current working directory when it is run.++When compiled without the production flag, only changes to the libraries, your+cabal file, or this file should require a recompile to be picked up.+Everything else is interpreted at runtime.  There are a few consequences of+this.++First, this is much slower.  Running the interpreter seems to take about+300ms, regardless of the simplicity of the loaded code.  The results of the+interpreter process are cached for a few seconds, to hopefully ensure that+the the interpreter is only invoked once for each load of a page and the+resources it depends on.++Second, the generated server binary is MUCH larger, since it links in the GHC+API (via the hint library).++Third, it results in initialization\/cleanup code defined by the @Initializer@+being called for each request.  This is to ensure that the current state is+compatible with the running action.  If your application state takes a long+time to load or clean up, the penalty will be visible.++Fourth, and the reason you would ever want to actually compile without+production mode, is that it enables a *much* faster development cycle. You can+simply edit a file, save your changes, and hit reload to see your changes+reflected immediately.++When this is compiled with the production flag, all the actions are statically+compiled in.  This results in much faster execution, a smaller binary size,+only running initialization and cleanup once per application run, and having+to recompile the server for any code change.++-}++module Main where++#ifdef PRODUCTION+import           Snap.Extension.Server+#else+import           Snap.Extension.Loader.Devel+import           Snap.Http.Server (quickHttpServe)+#endif++import           Application+import           Site++main :: IO ()+#ifdef PRODUCTION+main = quickHttpServe applicationInitializer site+#else+main = do+    snap <- $(loadSnapTH 'applicationInitializer 'site)+    quickHttpServe snap+#endif

@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}++{-|++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.++-}++module Site+  ( site+  ) where++import           Control.Applicative+import           Data.Maybe+import           Snap.Extension.Heist+import           Snap.Extension.Timer+import           Snap.Util.FileServe+import           Snap.Types+import           Text.Templating.Heist++import           Application+++------------------------------------------------------------------------------+-- | Renders the front page of the sample site.+--+-- 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 = ifTop $ heistLocal (bindSplices indexSplices) $ render "index"+  where+    indexSplices = +        [ ("start-time",   startTimeSplice)+        , ("current-time", currentTimeSplice)+        ]+++------------------------------------------------------------------------------+-- | Renders the echo page.+echo :: Application ()+echo = do+    message <- decodedParam "stuff"+    heistLocal (bindString "message" message) $ render "echo"+  where+    decodedParam p = fromMaybe "" <$> getParam p+++------------------------------------------------------------------------------+-- | The main entry point handler.+site :: Application ()+site = route [ ("/",            index)+             , ("/echo/:stuff", echo)+             ]+       <|> fileServe "resources/static"

@@ -0,0 +1,54 @@+{-|++'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           Data.Text.Encoding+import           Snap.Types+import           Text.Templating.Heist+import           Text.XML.Expat.Tree hiding (Node)+++------------------------------------------------------------------------------+-- | 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 $ [mkText $ encodeUtf8 $ 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 $ [mkText $ encodeUtf8 $ T.pack $ show $ time]

@@ -0,0 +1,67 @@+{-# 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 you appliaction'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

@@ -0,0 +1,112 @@+name:           snap+version:        0.3.0+synopsis:       Snap: A Haskell Web Framework (Core)+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+maintainer:     snap@snapframework.com+build-type:     Simple+cabal-version:  >= 1.6+homepage:       http://snapframework.com/+category:       Web++extra-source-files:+  CONTRIBUTORS,+  LICENSE,+  README.md,+  README.SNAP.md,+  project_template/barebones/foo.cabal,+  project_template/barebones/src/Main.hs,+  project_template/default/foo.cabal,+  project_template/default/log/access.log,+  project_template/default/log/error.log,+  project_template/default/resources/static/screen.css,+  project_template/default/resources/templates/echo.tpl,+  project_template/default/resources/templates/index.tpl,+  project_template/default/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++Library+  hs-source-dirs: src++  exposed-modules:+    Snap.Extension.Heist,+    Snap.Extension.Heist.Impl,+    Snap.Extension.Loader.Devel,+    Snap.Extension.Server,+    Snap.Extension,+    Snap.Heist++  other-modules:+    Snap.Extension.Loader.Devel.Helper++  build-depends:+    base >= 4 && < 5,+    bytestring >= 0.9.1 && < 0.10,+    directory >= 1.0 && < 1.2,+    enumerator == 0.4.*,+    filepath >= 1.1 && <1.3,+    MonadCatchIO-transformers >= 0.2.1 && < 0.3,+    snap-core == 0.3.*,+    heist >= 0.4 && < 0.5,+    hint >= 0.3.3.1 && < 0.4,+    template-haskell >= 2.3 && < 2.6,+    time >= 1.0 && < 1.3++  if !os(windows) {+      build-depends:    unix >= 2.2.0.0 && < 2.5+  }++  if impl(ghc >= 6.12.0)+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+                 -fno-warn-orphans -fno-warn-unused-do-bind+  else+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+                 -fno-warn-orphans++Executable snap+  hs-source-dirs: src+  main-is: Snap/Starter.hs++  other-modules: Snap.StarterTH++  build-depends:+    attoparsec >= 0.8.0.2 && < 0.9,+    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.*,+    filepath >= 1.1 && <1.3,+    haskell98,+    mtl >= 2,+    old-locale,+    old-time,+    snap-core == 0.3.*,+    snap-server == 0.3.*,+    template-haskell >= 2.3 && < 2.6,+    text >= 0.11 && <0.12,+    time,+    unix-compat,+    zlib++  ghc-prof-options: -prof -auto-all++  if impl(ghc >= 6.12.0)+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+                 -fno-warn-orphans -fno-warn-unused-do-bind+  else+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+                 -fno-warn-orphans++source-repository head+  type:     git+  location: http://git.snapframework.com/snap.git

@@ -0,0 +1,502 @@+{-# 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+  , runInitializerHint+  , mkInitializer+  , defaultReloadHandler+  , nullReloadHandler+  ) where++import           Control.Applicative+import           Control.Exception (SomeException)+import           Control.Monad+import           Control.Monad.CatchIO+import           Control.Monad.Reader+import           Control.Monad.Trans+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)+import           Snap.Iteratee (enumBS, (>==>))+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, this is what you would do:++  @+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)++------------------------------------------------------------------------------+-- | Runs an initializer, obtains state, runs the handler, and tears everything+-- down all in one request. Used with the hint backend which reloads everything+-- every time.+runInitializerHint :: Initializer s+                   -- ^ The Initializer value+                   -> SnapExtend s ()+                   -- ^ An action in your application's monad.+                   -> Snap ()+runInitializerHint (Initializer r) (SnapExtend m) = do+    liftIO (r True) >>= either+                          -- Left s: no cleanup action+                          (\s -> runReaderT m s)+                          f+  where+    f (SCR s a _) = runReaderT m s `finally` liftIO a+++------------------------------------------------------------------------------+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 "Sucess" showE m, "\n"]+        msg           = mconcat $ map format ms+    finishWith $ setContentType "text/plain; charset=utf-8"+        $ setContentLength (fromIntegral $ B.length msg)+        $ modifyResponseBody (>==> enumBS 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

@@ -0,0 +1,70 @@+{-# 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           Snap.Types+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 ()++    -- | 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 = fmap rqPathInfo getRequest >>= render++    -- | 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, Splice n)]   -- ^ Splice mapping+  -> ByteString   -- ^ Template to render+  -> m ()+renderWithSplices sps t = heistLocal bsps $ render t+  where bsps = bindSplices sps

@@ -0,0 +1,197 @@+{-# 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 qualified Data.ByteString as B+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 you appliaction'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'. It takes one argument, a path to a+-- template directory containing @.tpl@ files.+heistInitializer :: MonadSnap m => FilePath -> Initializer (HeistState m)+heistInitializer p = do+    heistState <- liftIO $ do+        (origTs,sts) <- bindStaticTag $ 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+        (HeistState _ _ tsMVar _ modifier) <- asks getHeistState+        ts <- liftIO $ fmap modifier $ readMVar tsMVar+        renderTemplate ts t >>= maybe pass (\html -> do+            modifyResponse $ setContentType "text/html; charset=utf-8"+            modifyResponse $ setContentLength (fromIntegral $ B.length html)+            writeBS html)++    heistLocal f = local $ modifyHeistState $ \s ->+        s { _modifier = f . _modifier s }+++------------------------------------------------------------------------------+instance HasHeistState m s => MonadHeist m (ReaderT s m) where+    render t     = ReaderT $ \s -> do+        let (HeistState _ _ tsMVar _ modifier) = getHeistState s+        ts <- liftIO $ fmap modifier $ readMVar tsMVar+        renderTemplate ts t >>= maybe pass (\html -> do+            modifyResponse $ setContentType "text/html; charset=utf-8"+            modifyResponse $ setContentLength (fromIntegral $ B.length html)+            writeBS html)++    heistLocal f = local $ modifyHeistState $ \s ->+        s { _modifier = f . _modifier s }+++------------------------------------------------------------------------------+-- | 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'.+--+-- 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.+  -> [(B.ByteString, Splice m)]   +  -- ^ Your splices.+  -> n ()+registerSplices s sps = liftIO $ do+  let mv = _tsMVar s+  modifyMVar_ mv $ (return . bindSplices sps) 

@@ -0,0 +1,250 @@+{-# 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+  ) where++import           Data.List (groupBy, intercalate, isPrefixOf, nub)++import           Control.Concurrent (forkIO, myThreadId)+import           Control.Concurrent.MVar+import           Control.Exception+import           Control.Monad (when)+import           Control.Monad.Trans (liftIO)++import           Data.Maybe (catMaybes)+import           Data.Time.Clock++import           Language.Haskell.Interpreter hiding (lift, liftIO)+import           Language.Haskell.Interpreter.Unsafe++import           Language.Haskell.TH++import           Prelude hiding (catch)++import           System.Environment (getArgs)++------------------------------------------------------------------------------+import           Snap.Types+import           Snap.Extension (runInitializerHint)+import           Snap.Extension.Loader.Devel.Helper++------------------------------------------------------------------------------+-- | 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 () -> IO (Snap ())+--+-- with a magical implementation.+--+-- The returned Snap action runs the 'Initializer', runs the 'Snap' handler,+-- and does the cleanup.  This means that the whole application state will be+-- loaded and unloaded for each request.  To make this worthwhile, those steps+-- should be made quite fast.+--+-- 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 -> Q Exp+loadSnapTH initializer action = do+    args <- runIO getArgs++    let initMod = nameModule initializer+        initBase = nameBase initializer+        actMod = nameModule action+        actBase = nameBase action++        modules = catMaybes [initMod, actMod]+        opts = getHintOpts args++    let static = typecheck initializer action++    -- The let in this block causes the static expression to be+    -- pattern-matched, providing an extra check that the types were+    -- correct at compile-time, at least.+    [| let _ = $static :: IO (Snap ())+       in hintSnap opts modules initBase actBase |]+++-- Used to typecheck the initializer & action splices.+typecheck :: Name -> Name -> Q Exp+typecheck initializer action = do+    let [initE, actE] = map varE [initializer, action]+    [| return (runInitializerHint $initE $actE) |]+++------------------------------------------------------------------------------+-- | 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 = init' $ dropWhile (not . ("-package" `isPrefixOf`)) args+    copy = map (intercalate " ") . groupBy (\_ s -> not $ "-" `isPrefixOf` s)++    opts = hideAll ++ srcOpts ++ copy toCopy++    init' [] = []+    init' xs = init xs+++------------------------------------------------------------------------------+-- | This function creates the Snap handler that actually is+-- responsible for doing the dynamic loading of actions via hint,+-- given all of the configuration information that the interpreter+-- needs.  It also ensures safe concurrent access to the interpreter,+-- and caches the interpreter results for a short time before allowing+-- it to run again.+--+-- This constructs an expression of type Snap (), that is essentially+--+-- > bracketSnap initialization cleanup handler+--+-- for the values of initialization, cleanup, and handler passed in.+--+-- 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   -- ^ The name of the initializer action+         -> String   -- ^ The name of the SnapExtend action+         -> IO (Snap ())+hintSnap opts modules initialization handler = do+    let action = intercalate " " [ "runInitializerHint"+                                 , initialization+                                 , handler+                                 ]+        interpreter = do+            loadModules . nub $ modules+            let imports = ["Prelude", "Snap.Types", "Snap.Extension"] ++ modules+            setImports . nub $ imports++            interpret action (as :: Snap ())++        loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter++    -- Protect the interpreter from concurrent and high-speed serial+    -- access.+    loadAction <- protectedActionEvaluator 3 $ protectHandlers loadInterpreter++    return $ do+        interpreterResult <- liftIO loadAction+        case interpreterResult of+            Left err -> error $ format err+            Right handlerAction -> handlerAction+++------------------------------------------------------------------------------+-- | 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)+++------------------------------------------------------------------------------+-- | Create a wrapper for an action that protects the action from+-- concurrent or rapid evaluation.+--+-- There will be at least the passed-in 'NominalDiffTime' delay+-- between the finish of one execution of the action the start of the+-- next.  Concurrent calls to the wrapper, and calls within the delay+-- period, end up with the same calculated value returned.+--+-- 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 delay time has expired after the exception was raised.+protectedActionEvaluator :: NominalDiffTime -> IO a -> IO (IO a)+protectedActionEvaluator minReEval action = do+    -- The list of requesters waiting for a result.  Contains the+    -- ThreadId in case of exceptions, and an empty MVar awaiting a+    -- successful result.+    --+    -- type: MVar [(ThreadId, MVar a)]+    readerContainer <- newMVar []++    -- Contains the previous result, and the time it was stored, if a+    -- previous result has been computed.  The result stored is either+    -- the actual result, or the exception thrown by the calculation.+    --+    -- type: MVar (Maybe (Either SomeException a, UTCTime))+    resultContainer <- newMVar Nothing++    -- 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.+    return $ do+        existingResult <- readMVar resultContainer+        now <- getCurrentTime++        case existingResult of+            Just (res, ts) | diffUTCTime now ts < minReEval ->+                -- There's an existing result, and it's still valid+                case res of+                    Right val -> return val+                    Left  e   -> throwIO e+            _ -> 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, kick off evaluation of+                -- the action in a new thread. This is slightly+                -- careful to block asynchronous exceptions to that+                -- thread except when actually running the action.+                when (null readers) $ do+                    let runAndFill = block $ do+                            a <- unblock action+                            clearAndNotify (Right a) (flip putMVar a . snd)++                        killWaiting :: SomeException -> IO ()+                        killWaiting e = block $ do+                            clearAndNotify (Left e) (flip throwTo e . fst)+                            throwIO e++                        clearAndNotify r f = do+                            t <- getCurrentTime+                            _ <- swapMVar resultContainer $ Just (r, t)+                            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

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

@@ -0,0 +1,153 @@+{-# 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           Snap.Http.Server (simpleHttpServe)+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 -> ConfigExtend s+completeConfig c = case getListen c' of+                    [] -> addListen (ListenHttp "0.0.0.0" 8000) c'+                    _ -> c'+  where c' = mappend defaultConfig c+++------------------------------------------------------------------------------+-- | 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+    (snap, cleanup) <- runInitializerWithReloadAction+                         verbose+                         initializer+                         (catch500 handler)+                         reloader+    let site = compress $ snap+    mapM_ printListen $ C.getListen config+    _   <- try $ serve $ site :: IO (Either SomeException ())+    putStr "\n"+    cleanup+    output "Shutting down..."++  where+    conf     = completeConfig config+    verbose  = fromJust $ getVerbose conf+    output   = when verbose . hPutStrLn stderr+    reloader = fromJust $ getReloadHandler conf+    compress = if fromJust $ getCompression conf then withCompression else id+    catch500 = flip catch $ fromJust $ getErrorHandler conf+    serve    = simpleHttpServe config++    listenToString (C.ListenHttp host port) =+        concat ["http://", fromUTF8 host, ":", show port, "/"]+    listenToString (C.ListenHttps host port _ _) =+        concat ["https://", fromUTF8 host, ":", show port, "/"]++    printListen l = output $ "Listening on " ++ listenToString l+++------------------------------------------------------------------------------+-- | Starts serving HTTP using the given handler. The configuration is read+-- from the options given on the command-line, as returned by+-- 'commandLineConfig'.+quickHttpServe :: Initializer s+               -- ^ The 'Initializer' function for the application's monad+               -> SnapExtend s ()+               -- ^ The application to be served+               -> IO ()+quickHttpServe r m = commandLineConfig emptyConfig >>= \c -> httpServe c r m++------------------------------------------------------------------------------+fromUTF8 :: ByteString -> String+fromUTF8 = T.unpack . T.decodeUtf8

@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module contains convenience functions for helping render+-- Heist templates from Snap.+module Snap.Heist where++------------------------------------------------------------------------------+import           Control.Applicative+import           Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import           Snap.Types+import           Snap.Util.FileServe+import           Text.Templating.Heist+++------------------------------------------------------------------------------+-- | This is a convenience function.  It calls 'render' with the+-- content type set to @text/html; charset=utf-8@.+renderHtml :: (MonadSnap m) => TemplateState m -> ByteString -> m ()+renderHtml = render "text/html; charset=utf-8"+++------------------------------------------------------------------------------+-- | Renders a template with the provided content type.  If the+-- template cannot be loaded, 'pass' is called and the next handler is tried.+render :: (MonadSnap m)+       => ByteString      -- ^ the content type to include in the response+       -> TemplateState m -- ^ the TemplateState that contains the template+       -> ByteString      -- ^ the name of the template+       -> m ()+render contentType ts template = do+    bytes <- renderTemplate ts template+    flip (maybe pass) bytes $ \x -> do+        modifyResponse $ setContentType contentType+                       . setContentLength (fromIntegral $ B.length x)+        writeBS x+++------------------------------------------------------------------------------+-- | Handles the rendering of any template in TemplateState.+handleAllTemplates :: (MonadSnap m)+                   => TemplateState m -> m ()+handleAllTemplates ts =+    ifTop (renderHtml ts "index") <|>+    (renderHtml ts . B.pack =<< getSafePath)

@@ -0,0 +1,105 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++------------------------------------------------------------------------------+import           Char+import           Data.List+import qualified Data.ByteString.Char8 as S+import qualified Data.Text as T+import           Snap.Http.Server (snapServerVersion)+import           System+import           System.Directory+import           System.Console.GetOpt+import           System.FilePath+------------------------------------------------------------------------------++import Snap.StarterTH+++------------------------------------------------------------------------------+-- Creates a value tDir :: ([String], [(String, String)])+$(buildData "tDirBareBones" "barebones")+$(buildData "tDirDefault"   "default")++------------------------------------------------------------------------------+usage :: String+usage = unlines+    [ "Snap " ++ (S.unpack snapServerVersion) ++ " Project Kickstarter"+    , ""+    , "Usage:"+    , ""+    , "  snap <action>"+    , ""+    , "    <action> can be one of:"+    , "      init - create a new project directory structure in the " +++        "current directory"+    , ""+    , "  Note: you can use --help after any of the above actions to get help "+    , "  on that action"+    ]+++------------------------------------------------------------------------------+data InitFlag = InitBareBones+              | InitHelp+              | InitExtensions+  deriving (Show, Eq)+++setup :: String -> ([FilePath], [(String, String)]) -> IO ()+setup projName tDir = do+    mapM createDirectory (fst tDir)+    mapM_ write (snd tDir)+  where+    write (f,c) =+        if isSuffixOf "foo.cabal" f+          then writeFile (projName ++ ".cabal") (insertProjName $ T.pack c)+          else writeFile f c+    isNameChar c = isAlphaNum c || c == '-'+    insertProjName c = T.unpack $ T.replace+                           (T.pack "projname")+                           (T.pack $ filter isNameChar projName) c++------------------------------------------------------------------------------+initProject :: [String] -> IO ()+initProject args = do+    case getOpt Permute options args of+      (flags, _, [])+        | InitHelp `elem` flags -> do putStrLn initUsage+                                      exitFailure+        | otherwise             -> init' flags++      (_, _, 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)+                 "Print this message"+        , Option ['e'] ["extensions"] (NoArg InitExtensions)+                 "Depend on snap w/ extensions (default)"+        ]++    init' flags = 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+++------------------------------------------------------------------------------+main :: IO ()+main = do+    args <- getArgs+    case args of+        ("init":args') -> initProject args'+        _              -> do putStrLn usage+                             exitFailure

@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}+module Snap.StarterTH where++------------------------------------------------------------------------------+import qualified Data.Foldable as F+import           Data.List+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax+import           System.Directory.Tree+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- Convenience types+type FileData = (String, String)+type DirData = FilePath+++------------------------------------------------------------------------------+-- Gets all the directorys in a DirTree+getDirs :: [FilePath] -> DirTree a -> [FilePath]+getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) : concatMap (getDirs (n:prefix)) c+getDirs _ (File _ _) = []+getDirs _ (Failed _ _) = []+++------------------------------------------------------------------------------+-- Reads a directory and returns a tuple of the list of all directories+-- encountered and a list of filenames and content strings.+readTree :: FilePath -> IO ([DirData], [FileData])+readTree dir = do+    d <- readDirectory $ dir ++ "/."+    let ps = zipPaths $ "" :/ (free d)+        fd = F.foldr (:) [] ps+        dirs = tail . getDirs [] $ free d++    return (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+    lift d+++------------------------------------------------------------------------------+-- Creates a declaration assigning the specified name the value returned by+-- dirQ.+buildData :: String -> FilePath -> Q [Dec]+buildData dirName tplDir = do+    let dir = mkName dirName++    typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |]+    v <- valD (varP dir) (normalB $ dirQ tplDir) []+    return [typeSig, v]