snap 0.3.1 → 0.4
raw patch · 27 files changed
+1114/−411 lines, 27 filesdep +blaze-builderdep ~heistdep ~snap-coredep ~snap-serverbinary-added
Dependencies added: blaze-builder
Dependency ranges changed: heist, snap-core, snap-server
Files
- TODO +17/−0
- extra/haddock.css +435/−0
- extra/hscolour.css +15/−0
- extra/logo.gif binary
- project_template/barebones/foo.cabal +2/−2
- project_template/barebones/src/Main.hs +1/−1
- project_template/default/foo.cabal +8/−9
- project_template/default/resources/templates/echo.tpl +1/−2
- project_template/default/resources/templates/index.tpl +1/−2
- project_template/default/src/Main.hs +38/−36
- project_template/default/src/Site.hs +4/−3
- project_template/default/src/Snap/Extension/Timer.hs +3/−4
- snap.cabal +20/−9
- src/Snap/Extension.hs +75/−76
- src/Snap/Extension/Heist.hs +20/−11
- src/Snap/Extension/Heist/Impl.hs +39/−26
- src/Snap/Extension/Loader/Devel.hs +53/−142
- src/Snap/Extension/Loader/Devel/Evaluator.hs +137/−0
- src/Snap/Extension/Loader/Devel/Helper.hs +0/−43
- src/Snap/Extension/Loader/Devel/Signal.hs +43/−0
- src/Snap/Extension/Loader/Devel/TreeWatcher.hs +46/−0
- src/Snap/Heist.hs +0/−44
- src/Snap/StarterTH.hs +2/−1
- test/runTests.sh +21/−0
- test/snap-testsuite.cabal +24/−0
- test/suite/Snap/TestCommon.hs +57/−0
- test/suite/TestSuite.hs +52/−0
+ TODO view
@@ -0,0 +1,17 @@+TODO+----++Check for space issues in development vs production modes+ -- last thing before release++document EVERYTHING.+ -- low-level per-function documentation+ -- mid-level per-module documentation+ -- high-level design documentation++Extract ghc options via TH to include in hint configuration.+ -- wait for new release of hint++Fix broken SIGINT handler installed by the ghc api via hint.+ -- patch submitted for hint+ -- I can work around this in my code if needed
+ extra/haddock.css view
@@ -0,0 +1,435 @@+/* -------- Global things --------- */+HTML {+ background-color: #f0f3ff;+ width: 100%;+}++BODY { + -moz-border-radius:5px;+ -webkit-border-radius:5px;+ width: 50em;+ margin: 2em auto;+ padding: 0;+ background-color: #ffffff;+ color: #000000;+ font-size: 110%;+ font-family: Georgia, serif;+ }++A:link { color: #5200A3; text-decoration: none }+A:visited { color: #5200A3; text-decoration: none }+A:hover { color: #5200A3; text-decoration: none; border-bottom:#5200A3 dashed 1px; }++TABLE.vanilla {+ width: 100%;+ border-width: 0px;+ /* I can't seem to specify cellspacing or cellpadding properly using CSS... */+}++DL {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ letter-spacing: -0.01em;+ margin: 0;+}++.vanilla .vanilla dl { font-size: 80%; }+.vanilla .vanilla dl dl { padding-left: 0; font-size: 95%; }++TD.section1, TD.section2, TD.section3, TD.section4, TD.doc, DL {+ padding: 0 30px 0 34px;+}++TABLE.vanilla2 {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ border-width: 0px;+}++/* <TT> font is a little too small in MSIE */+TT, PRE, CODE {+ font-family: Monaco,+ "DejaVu Sans Mono",+ "Bitstream Vera Sans Mono",+ "Lucida Console",+ monospace;+ font-size: 90%;+}++LI P { margin: 0pt } ++P { margin-top: 0; margin-bottom: 0.75em; }++TD {+ border-width: 0px;+}++TABLE.narrow {+ border-width: 0px;+}++TD.s8 { height: 0; margin:0; padding: 0 }+TD.s15 { height: 20px; }++SPAN.keyword { text-decoration: underline; }++/* Resize the buttom image to match the text size */+IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em }++/* --------- Contents page ---------- */++DIV.node {+ padding-left: 3em;+}++DIV.cnode {+ padding-left: 1.75em;+}++SPAN.pkg {+ position: absolute;+ left: 50em;+}++/* --------- Documentation elements ---------- */++TD FONT { font-weight: bold; letter-spacing: -0.02em; }++TD.children {+ padding-left: 25px;+ }++TD.synopsis {+ padding: 2px;+ background-color: #f0f0f0;+ font-size: 80%;+ font-family: Monaco,+ "DejaVu Sans Mono",+ "Bitstream Vera Sans Mono",+ "Lucida Console",+ monospace;++ }++TD.decl { + padding: 4px 8px;+ background-color: #FAFAFA; + border-bottom: #F2F2F2 solid 1px;+ border-top: #FCFCFC solid 1px;+ font-size: 80%;+ font-family: Monaco,+ "DejaVu Sans Mono",+ "Bitstream Vera Sans Mono",+ "Lucida Console",+ monospace;++ vertical-align: top;+ }++TD.decl TD.decl {+ font-size: 100%;+ padding: 4px 0;+ border: 0;+}++TD.topdecl {+ padding: 20px 30px 0.5ex 30px;+ font-size: 80%;+ font-family: Monaco,+ "DejaVu Sans Mono",+ "Bitstream Vera Sans Mono",+ "Lucida Console",+ monospace;+;+ vertical-align: top;+}++.vanilla .vanilla .vanilla .topdecl {+ padding-left: 0;+ padding-right: 0;+}++.vanilla .vanilla .vanilla {+ padding-left: 30px;+}++.decl .vanilla {+ padding-left: 0px !important;+}++.body .vanilla .body {+ padding-left: 0;+ padding-right: 0;+}++.body .vanilla .body .decl {+ padding-left: 12px;+}++.body .vanilla .body div .vanilla .decl {+ padding-left: 12px;+}++TABLE.declbar {+ background-color: #f0f0f0;+ border-spacing: 0px;+ border-bottom:1px solid #d7d7df;+ border-right:1px solid #d7d7df;+ border-top:1px solid #f4f4f9;+ border-left:1px solid #f4f4f9;+ padding: 4px;+ }++TD.declname {+ width: 100%;+ padding-right: 4px;+ }++TD.declbut {+ padding-left: 8px;+ padding-right: 5px;+ border-left-width: 1px;+ border-left-color: #000099;+ border-left-style: solid;+ white-space: nowrap;+ font-size: x-small;+ }++/* + arg is just like decl, except that wrapping is not allowed. It is+ used for function and constructor arguments which have a text box+ to the right, where if wrapping is allowed the text box squashes up+ the declaration by wrapping it.+*/+TD.arg { + padding: 2px 12px;+ background-color: #f0f0f0; + font-size: 80%;+ font-family: Monaco,+ "DejaVu Sans Mono",+ "Bitstream Vera Sans Mono",+ "Lucida Console",+ monospace;++ vertical-align: top;+ white-space: nowrap;+ }++TD.recfield { padding-left: 20px }++TD.doc { + padding-left: 38px;+ font-size: 95%;+ line-height: 1.66;+ }++TD.ndoc { + font-size: 95%;+ line-height: 1.66;+ padding: 2px 4px 2px 8px;+ }++TD.rdoc { + padding: 2px;+ padding-left: 30px;+ width: 100%;+ font-size: 80%;+ font-style: italic;+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ }++TD.body { + padding: 0 30px;+ }++TD.pkg {+ width: 100%;+ padding-left: 30px+}++TABLE.indexsearch TR.indexrow {+ display: none;+}+TABLE.indexsearch TR.indexshow {+ display: table-row;+}++TD.indexentry {+ vertical-align: top;+ padding: 0 30px+ }++TD.indexannot {+ vertical-align: top;+ padding-left: 20px;+ white-space: nowrap+ }++TD.indexlinks {+ width: 100%+ }++/* ------- Section Headings ------- */++TD.section1, TD.section2, TD.section3, TD.section4, TD.section5 {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+}++TD.section1 {+ padding-top: 14px;+ font-weight: bold;+ letter-spacing: -0.02em;+ font-size: 140%+ }++TD.section2 {+ padding-top: 4px;+ font-weight: bold;+ letter-spacing: -0.02em;+ font-size: 120%+ }++TD.section3 {+ padding-top: 5px;+ font-weight: bold;+ letter-spacing: -0.02em;+ font-size: 105%+ }++TD.section4 {+ font-weight: bold;+ padding-top: 12px;+ padding-bottom: 4px;+ letter-spacing: -0.02em;+ font-size: 90%+ }++/* -------------- The title bar at the top of the page */++TD.infohead {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ color: #ffffff;+ font-weight: bold;+ padding: 0 30px;+ text-align: left;+}++TD.infoval {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ color: #ffffff;+ padding: 0 30px;+ text-align: left;+}++TD.topbar {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ background-color: #3465a4;+ padding: 5px;+ -moz-border-radius-topleft:5px;+ -moz-border-radius-topright:5px;+ -webkit-border-radius-topleft:5px;+ -webkit-border-radius-topright:5px;+}++TD.title {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ color: #ffffff;+ padding-left: 30px;+ letter-spacing: -0.02em;+ font-weight: bold;+ width: 100%+ }++TD.topbut {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ padding-left: 5px;+ padding-right: 5px;+ border-left-width: 1px;+ border-left-color: #ffffff;+ border-left-style: solid;+ letter-spacing: -0.02em;+ font-weight: bold;+ white-space: nowrap;+ }++TD.topbut A:link {+ color: #ffffff+ }++TD.topbut A:visited {+ color: #ffff00+ }++TD.topbut A:hover {+ background-color: #C9D3DE;+ }++TD.topbut:hover {+ background-color: #C9D3DE;+ }++TD.modulebar { + font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ color: #141B24;+ background-color: #C9D3DE;+ padding: 5px;+ border-top-width: 1px;+ border-top-color: #ffffff;+ border-top-style: solid;+ -moz-border-radius-bottomleft:5px;+ -moz-border-radius-bottomright:5px;+ -webkit-border-radius-bottomleft:5px;+ -webkit-border-radius-bottomright:5px;++ }++/* --------- The page footer --------- */++TD.botbar {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ -moz-border-radius:5px;+ -webkit-border-radius:5px;+ background-color: #3465a4;+ color: #ffffff;+ padding: 5px+ }+TD.botbar A:link {+ color: #ffffff;+ text-decoration: underline+ }+TD.botbar A:visited {+ color: #ffff00+ }+TD.botbar A:hover {+ background-color: #6060ff+ }++/* --------- Mini Synopsis for Frame View --------- */++.outer {+ margin: 0 0;+ padding: 0 0;+}++.mini-synopsis {+ padding: 0.25em 0.25em;+}++.mini-synopsis H1 { font-size: 120%; }+.mini-synopsis H2 { font-size: 107%; }+.mini-synopsis H3 { font-size: 100%; }+.mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 {+ font-family: "Gill Sans", "Helvetica Neue","Arial",sans-serif;+ margin-top: 0.5em;+ margin-bottom: 0.25em;+ padding: 0 0;+ font-weight: bold; letter-spacing: -0.02em;+}++.mini-synopsis H1 { border-bottom: 1px solid #ccc; }++.mini-topbar {+ font-size: 120%;+ background: #0077dd;+ padding: 0.25em;+}++
+ extra/hscolour.css view
@@ -0,0 +1,15 @@+body { font-size: 90%; }++pre, code, body {+ font-family: Monaco,+ "DejaVu Sans Mono",+ "Bitstream Vera Sans Mono",+ "Lucida Console",+ monospace;+}++.hs-keyglyph, .hs-layout {color: #5200A3;}+.hs-keyword {color: #3465a4; font-weight: bold;}+.hs-comment, .hs-comment a {color: #579; }+.hs-str, .hs-chr {color: #141B24;}+.hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {}
+ extra/logo.gif view
binary file changed (absent → 607 bytes)
project_template/barebones/foo.cabal view
@@ -19,8 +19,8 @@ bytestring >= 0.9.1 && < 0.10, MonadCatchIO-transformers >= 0.2.1 && < 0.3, mtl >= 2 && < 3,- snap-core >= 0.3 && <0.4,- snap-server >= 0.3 && <0.4+ snap-core == 0.4.*,+ snap-server == 0.4.* if impl(ghc >= 6.12.0) ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
project_template/barebones/src/Main.hs view
@@ -12,7 +12,7 @@ route [ ("foo", writeBS "bar") , ("echo/:echoparam", echoHandler) ] <|>- dir "static" (fileServe ".")+ dir "static" (serveDirectory ".") echoHandler :: Snap () echoHandler = do
project_template/default/foo.cabal view
@@ -18,23 +18,22 @@ hs-source-dirs: src main-is: Main.hs - if !flag(development)- cpp-options: -DPRODUCTION- else+ if flag(development)+ cpp-options: -DDEVELOPMENT 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,+ heist >= 0.5 && < 0.6, 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,+ snap == 0.4.*,+ snap-core == 0.4.*,+ snap-server == 0.4.*, text >= 0.11 && < 0.12,- time >= 1.1 && < 1.3+ time >= 1.1 && < 1.3,+ xmlhtml == 0.1.* extensions: TypeSynonymInstances MultiParamTypeClasses
project_template/default/resources/templates/echo.tpl view
@@ -1,5 +1,4 @@-<!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">+<html> <head> <title>Echo Page</title> </head>
project_template/default/resources/templates/index.tpl view
@@ -1,5 +1,4 @@-<!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">+<html> <head> <title>Snap web server</title> <link rel="stylesheet" type="text/css" href="screen.css"/>
project_template/default/src/Main.hs view
@@ -3,61 +3,63 @@ {-| -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.+This is the entry point for this web server application. It supports+easily switching between interpreting source and running statically+compiled code. -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.+In either mode, the generated program should be run from the root of+the project tree. When it is run, it locates its templates, static+content, and source files in development mode, relative to the current+working directory. -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.+When compiled with the development flag, only changes to the+libraries, your cabal file, or this file should require a recompile to+be picked up. Everything else is interpreted at runtime. There are a+few consequences of this. -Second, the generated server binary is MUCH larger, since it links in the GHC-API (via the hint library).+First, this is much slower. Running the interpreter takes a+significant chunk of time (a couple tenths of a second on the author's+machine, at this time), regardless of the simplicity of the loaded+code. In order to recompile and re-load server state as infrequently+as possible, the source directories are watched for updates, as are+any extra directories specified below. -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.+Second, the generated server binary is MUCH larger, since it links in+the GHC API (via the hint library). -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.+Third, and the reason you would ever want to actually compile with+development mode, is that it enables a faster development cycle. You+can simply edit a file, save your changes, and hit reload to see your+changes reflected immediately. -When this is compiled 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.+When this is compiled without the development flag, all the actions+are statically compiled in. This results in faster execution, a+smaller binary size, and having to recompile the server for any code+change. -} module Main where -#ifdef PRODUCTION-import Snap.Extension.Server-#else+#ifdef DEVELOPMENT import Snap.Extension.Loader.Devel import Snap.Http.Server (quickHttpServe)+#else+import Snap.Extension.Server #endif import Application import Site main :: IO ()-#ifdef PRODUCTION-main = quickHttpServe applicationInitializer site-#else+#ifdef DEVELOPMENT main = do- snap <- $(loadSnapTH 'applicationInitializer 'site)+ -- All source directories will be watched for updates+ -- automatically. If any extra directories should be watched for+ -- updates, include them here.+ snap <- $(let extraWatcheDirs = ["resources/templates"]+ in loadSnapTH 'applicationInitializer 'site extraWatcheDirs) quickHttpServe snap+#else+main = quickHttpServe applicationInitializer site #endif
project_template/default/src/Site.hs view
@@ -13,6 +13,7 @@ import Control.Applicative import Data.Maybe+import qualified Data.Text.Encoding as T import Snap.Extension.Heist import Snap.Extension.Timer import Snap.Util.FileServe@@ -31,7 +32,7 @@ index :: Application () index = ifTop $ heistLocal (bindSplices indexSplices) $ render "index" where- indexSplices = + indexSplices = [ ("start-time", startTimeSplice) , ("current-time", currentTimeSplice) ]@@ -42,7 +43,7 @@ echo :: Application () echo = do message <- decodedParam "stuff"- heistLocal (bindString "message" message) $ render "echo"+ heistLocal (bindString "message" (T.decodeUtf8 message)) $ render "echo" where decodedParam p = fromMaybe "" <$> getParam p @@ -53,4 +54,4 @@ site = route [ ("/", index) , ("/echo/:stuff", echo) ]- <|> fileServe "resources/static"+ <|> serveDirectory "resources/static"
project_template/default/src/Snap/Extension/Timer.hs view
@@ -25,10 +25,9 @@ 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)+import Text.XmlHtml ------------------------------------------------------------------------------@@ -43,7 +42,7 @@ startTimeSplice :: MonadTimer m => Splice m startTimeSplice = do time <- lift startTime- return $ [mkText $ encodeUtf8 $ T.pack $ show $ time]+ return $ [TextNode $ T.pack $ show $ time] ------------------------------------------------------------------------------@@ -51,4 +50,4 @@ currentTimeSplice :: MonadTimer m => Splice m currentTimeSplice = do time <- lift $ liftIO getCurrentTime- return $ [mkText $ encodeUtf8 $ T.pack $ show $ time]+ return $ [TextNode $ T.pack $ show $ time]
snap.cabal view
@@ -1,5 +1,5 @@ name: snap-version: 0.3.1+version: 0.4 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@@ -16,6 +16,7 @@ LICENSE, README.md, README.SNAP.md,+ TODO, project_template/barebones/foo.cabal, project_template/barebones/src/Main.hs, project_template/default/foo.cabal,@@ -28,8 +29,16 @@ 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+ 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/suite/Snap/TestCommon.hs,+ test/suite/TestSuite.hs + Library hs-source-dirs: src @@ -38,21 +47,23 @@ Snap.Extension.Heist.Impl, Snap.Extension.Loader.Devel, Snap.Extension.Server,- Snap.Extension,- Snap.Heist+ Snap.Extension other-modules:- Snap.Extension.Loader.Devel.Helper+ Snap.Extension.Loader.Devel.Evaluator,+ Snap.Extension.Loader.Devel.Signal,+ Snap.Extension.Loader.Devel.TreeWatcher build-depends: base >= 4 && < 5,+ blaze-builder >= 0.2.1.4 && <0.3, 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.1 && <0.4,- heist >= 0.4 && < 0.5,+ snap-core == 0.4.*,+ heist >= 0.5 && < 0.6, hint >= 0.3.3.1 && < 0.4, template-haskell >= 2.3 && < 2.6, time >= 1.0 && < 1.3@@ -90,8 +101,8 @@ mtl >= 2, old-locale, old-time,- snap-core >= 0.3.1 && <0.4,- snap-server >= 0.3.1 && <0.4,+ snap-core >= 0.4 && <0.5,+ snap-server >= 0.4 && <0.5, template-haskell >= 2.3 && < 2.6, text >= 0.11 && <0.12, time,
src/Snap/Extension.hs view
@@ -1,23 +1,22 @@ {-# 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 @@ -26,12 +25,13 @@ , InitializerState(..) , runInitializer , runInitializerWithReloadAction- , runInitializerHint+ , runInitializerWithoutReloadAction , mkInitializer , defaultReloadHandler , nullReloadHandler ) where +import Blaze.ByteString.Builder import Control.Applicative import Control.Exception (SomeException) import Control.Monad@@ -43,8 +43,8 @@ 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 Prelude hiding (catch, init)+import Snap.Iteratee (enumBuilder, (>==>)) import Snap.Types import System.IO @@ -67,14 +67,14 @@ -} {- $using- + Every extension has an interface and at least one implementation of that- interface. - + 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,@@ -82,14 +82,14 @@ 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.+ 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. @@ -112,15 +112,15 @@ { 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.+ 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@@ -130,14 +130,14 @@ 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:+ 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.- + @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@@ -153,11 +153,11 @@ 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 + With these instances, our application's monad App is now a MonadHeist giving it access to operations like:- - @render :: MonadHeist m => ByteString -> m ()@ - ++ @render :: MonadHeist m => ByteString -> m ()@+ and @heistLocal :: (TemplateState n -> TemplateState n) -> m a -> m a@@@ -165,11 +165,11 @@ -} {- $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@@ -186,8 +186,8 @@ 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. - + 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@@ -210,28 +210,29 @@ main :: IO () main = do (snap,cleanup,reload) <- runInitializer appInitializer appSite- let site = snap + 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+ 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.+ 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:+ 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@@ -246,10 +247,10 @@ 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:+ 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 @@ -366,9 +367,9 @@ -- ^ 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+ -- 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.@@ -408,28 +409,24 @@ 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+-- | 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+ 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 ------------------------------------------------------------------------------@@ -455,9 +452,10 @@ 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')+ 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') ------------------------------------------------------------------------------@@ -471,11 +469,12 @@ 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"]+ 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 (>==> enumBS msg) emptyResponse+ $ modifyResponseBody (>==> enumBuilder (fromByteString msg))+ emptyResponse where failIfNotLocal m = do rip <- liftM rqRemoteAddr getRequest
src/Snap/Extension/Heist.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-| @@ -13,22 +14,25 @@ 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.+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 +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 @@ -40,6 +44,10 @@ -- 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:@@ -50,7 +58,7 @@ -- | Analogous to 'fileServe'. If the template specified in the request -- path is not found, it returns 'empty'. heistServe :: m ()- heistServe = fmap rqPathInfo getRequest >>= render+ heistServe = ifTop (render "index") <|> (render . B.pack =<< getSafePath) -- | Analogous to 'fileServeSingle'. If the given template is not found, -- this throws an error.@@ -60,11 +68,12 @@ --------------------------------------------------------------------------------- | Helper function for common use case: +-- | 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+renderWithSplices+ :: (MonadHeist n m)+ => ByteString -- ^ Template to render+ -> [(Text, Splice n)] -- ^ Splice mapping -> m ()-renderWithSplices sps t = heistLocal bsps $ render t+renderWithSplices t sps = heistLocal bsps $ render t where bsps = bindSplices sps
src/Snap/Extension/Heist/Impl.hs view
@@ -47,8 +47,8 @@ -} module Snap.Extension.Heist.Impl- ( - + (+ -- * Heist State Definitions HeistState , HasHeistState(..)@@ -63,7 +63,9 @@ import Control.Concurrent.MVar import Control.Monad.Reader-import qualified Data.ByteString as B+import Data.ByteString (ByteString)+import Data.Maybe+import Data.Text (Text) import Snap.Extension import Snap.Extension.Heist import Snap.Types@@ -73,7 +75,7 @@ ------------------------------------------------------------------------------ -- | Your application's state must include a 'HeistState' in order for your--- application to be a 'MonadHeist'. +-- 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',@@ -140,40 +142,51 @@ -------------------------------------------------------------------------------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)+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 -> 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)+ 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'. -- -- Typical use cases are dynamically generated components that are present in--- many of your views. +-- many of your views. -- -- Example Usage: --@@ -181,17 +194,17 @@ -- appInit :: Initializer AppState -- appInit = do -- hs <- heistInitializer \"templates\"--- registerSplices hs $ +-- registerSplices hs $ -- [ (\"tabs\", tabsSplice)--- , (\"loginLogout\", loginLogoutSplice) ] +-- , (\"loginLogout\", loginLogoutSplice) ] -- @ registerSplices- :: (MonadSnap m, MonadIO n) - => HeistState m + :: (MonadSnap m, MonadIO n)+ => HeistState m -- ^ Heist state that you are going to embed in your application's state.- -> [(B.ByteString, Splice m)] + -> [(Text, Splice m)] -- ^ Your splices. -> n () registerSplices s sps = liftIO $ do let mv = _tsMVar s- modifyMVar_ mv $ (return . bindSplices sps) + modifyMVar_ mv $ (return . bindSplices sps)
src/Snap/Extension/Loader/Devel.hs view
@@ -9,30 +9,25 @@ ( 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 Control.Monad (liftM2) +import Data.List (groupBy, intercalate, isPrefixOf, nub) import Data.Maybe (catMaybes)-import Data.Time.Clock+import Data.Time.Clock (diffUTCTime, getCurrentTime) 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+import Snap.Extension (runInitializerWithoutReloadAction)+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@@ -41,20 +36,15 @@ -- -- This could be considered a TH wrapper around a function ----- > loadSnap :: Initializer s -> SnapExtend s () -> IO (Snap ())+-- > loadSnap :: Initializer s -> SnapExtend s () -> [String] -> 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+loadSnapTH :: Name -> Name -> [String] -> Q Exp+loadSnapTH initializer action additionalWatchDirs = do args <- runIO getArgs let initMod = nameModule initializer@@ -62,23 +52,15 @@ 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 |]-+ modules = catMaybes [initMod, actMod]+ srcPaths = additionalWatchDirs ++ getSrcPaths args --- 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) |]+ -- The let in this block causes an extra static type check that the+ -- types of the names passed in were correct at compile time.+ [| let _ = runInitializerWithoutReloadAction $(varE initializer)+ $(varE action)+ in hintSnap opts modules srcPaths initBase actBase |] ------------------------------------------------------------------------------@@ -107,6 +89,14 @@ ------------------------------------------------------------------------------+-- | 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@@ -114,12 +104,6 @@ -- 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.@@ -129,34 +113,43 @@ -- 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 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+hintSnap opts modules srcPaths initialization handler =+ protectedHintEvaluator initialize test loader+ where+ action = intercalate " " [ "runInitializerWithoutReloadAction"+ , initialization+ , handler+ ]+ interpreter = do+ loadModules . nub $ modules+ let imports = "Prelude" :+ "Snap.Extension" :+ "Snap.Types" :+ modules+ setImports . nub $ imports - interpret action (as :: Snap ())+ interpret action (as :: HintLoadable) - loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter+ loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter - -- Protect the interpreter from concurrent and high-speed serial- -- access.- loadAction <- protectedActionEvaluator 3 $ protectHandlers loadInterpreter+ formatOnError (Left err) = error $ format err+ formatOnError (Right a) = a - return $ do- interpreterResult <- liftIO loadAction- case interpreterResult of- Left err -> error $ format err- Right handlerAction -> handlerAction+ 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@@ -166,85 +159,3 @@ 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
+ src/Snap/Extension/Loader/Devel/Evaluator.hs view
@@ -0,0 +1,137 @@+{-# 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 ())+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.+ return $ 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+ 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 ()
− src/Snap/Extension/Loader/Devel/Helper.hs
@@ -1,43 +0,0 @@-{-# 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
+ src/Snap/Extension/Loader/Devel/Signal.hs view
@@ -0,0 +1,43 @@+{-# 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
+ src/Snap/Extension/Loader/Devel/TreeWatcher.hs view
@@ -0,0 +1,46 @@+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 adtEq entries+ adtEq (n1 :/ dt1) (n2 :/ dt2) = n1 == n2 && dtEq dt1 dt2++ dtEq (Dir n1 d1) (Dir n2 d2) = n1 == n2 && and (zipWith dtEq d1 d2)+ dtEq (File n1 t1) (File n2 t2) = n1 == n2 && t1 == t2+ dtEq _ _ = False+++------------------------------------------------------------------------------+-- | 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
− src/Snap/Heist.hs
@@ -1,44 +0,0 @@-{-# 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)
src/Snap/StarterTH.hs view
@@ -19,7 +19,8 @@ ------------------------------------------------------------------------------ -- 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 prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) :+ concatMap (getDirs (n:prefix)) c getDirs _ (File _ _) = [] getDirs _ (Failed _ _) = []
+ test/runTests.sh view
@@ -0,0 +1,21 @@+#!/bin/sh++set -e++if [ -z "$DEBUG" ]; then+ export DEBUG=testsuite+fi++SUITE=./dist/build/testsuite/testsuite++if [ ! -f $SUITE ]; then+ cat <<EOF+Testsuite executable not found, please run:+ cabal configure -ftest+then+ cabal build+EOF+ exit;+fi++./dist/build/testsuite/testsuite -j1 $*
+ test/snap-testsuite.cabal view
@@ -0,0 +1,24 @@+name: snap-testsuite+version: 0.0.1+build-type: Simple+cabal-version: >= 1.6++Executable testsuite+ hs-source-dirs: suite+ main-is: TestSuite.hs++ build-depends:+ QuickCheck >= 2.3.0.2,+ base >= 4 && < 5,+ bytestring == 0.9.*,+ directory,+ filepath,+ HUnit >= 1.2 && < 2,+ http-enumerator >= 0.2.1.5 && <0.3,+ process == 1.*,+ test-framework >= 0.3.1 && <0.4,+ 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+ -fno-warn-unused-do-bind
+ test/suite/Snap/TestCommon.hs view
@@ -0,0 +1,57 @@+module Snap.TestCommon where++import Control.Concurrent+import Control.Exception+import Control.Monad (when)+import System.Cmd+import System.Directory+import System.Exit+import System.FilePath+import System.Process++testGeneratedProject :: String -- ^ project name and directory+ -> String -- ^ arguments to @snap init@+ -> String -- ^ arguments to @cabal install@+ -> Int -- ^ port to run http server on+ -> 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+ systemOrDie $ "snap init " ++ snapInitArgs+ systemOrDie $ "cabal install " ++ cabalInstallArgs+ let cmd = ("." </> "dist" </> "build" </> projName </> projName)+ ++ " -p " ++ show httpPort+ putStrLn $ "Running \"" ++ cmd ++ "\""+ pHandle <- runCommand cmd+ waitABit+ return (cwd, projectPath, pHandle)++ cleanup (cwd, projectPath, pHandle) = do+ setCurrentDirectory cwd+ terminateProcess pHandle+ waitForProcess pHandle+ removeDirectoryRecursive projectPath++ waitABit = threadDelay $ 2*10^(6::Int)++systemOrDie :: String -> IO ()+systemOrDie s = do+ putStrLn $ "Running \"" ++ s ++ "\""+ system s >>= check+ where+ check ExitSuccess = return ()+ check _ = throwIO $ ErrorCall $ "command failed: '" ++ s ++ "'"+++makeWorkDirectory :: FilePath -> IO ()+makeWorkDirectory p = do+ doesDirectoryExist p >>= flip when (removeDirectoryRecursive p)+ createDirectory p
+ test/suite/TestSuite.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++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 Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test, path)++import Snap.TestCommon++main :: IO ()+main = defaultMain tests+ where tests = [ testBarebones+ , testDefault+ ]+++testBarebones :: Test+testBarebones = testCase "snap/barebones" go+ where+ go = testGeneratedProject "barebonesTest"+ "-b"+ ""+ port+ testIt+ port = 9990+ testIt = do+ body <- HTTP.simpleHttp "http://127.0.0.1:9990"+ assertEqual "server not up" "hello world" body+++testDefault :: Test+testDefault = testCase "snap/default" go+ where+ go = testGeneratedProject "defaultTest"+ ""+ ""+ port+ testIt+ port = 9991+ testIt = do+ body <- liftM (S.concat . L.toChunks) $+ HTTP.simpleHttp "http://127.0.0.1:9991"+ assertBool "response contains phrase 'it works!'"+ $ "It works!" `S.isInfixOf` body+++-- TODO: test hint code here