diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,8 @@ +Ozgun Ataman +Doug Beardsley +Gregory Collins +Shu-yu Guo +Carl Howells +Shane O'Brien +James Sanders +Jacob Stanley diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.SNAP.md b/README.SNAP.md new file mode 100644 --- /dev/null +++ b/README.SNAP.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/project_template/barebones/foo.cabal b/project_template/barebones/foo.cabal new file mode 100644 --- /dev/null +++ b/project_template/barebones/foo.cabal @@ -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 diff --git a/project_template/barebones/src/Main.hs b/project_template/barebones/src/Main.hs new file mode 100644 --- /dev/null +++ b/project_template/barebones/src/Main.hs @@ -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 diff --git a/project_template/default/foo.cabal b/project_template/default/foo.cabal new file mode 100644 --- /dev/null +++ b/project_template/default/foo.cabal @@ -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 + diff --git a/project_template/default/log/access.log b/project_template/default/log/access.log new file mode 100644 --- /dev/null +++ b/project_template/default/log/access.log diff --git a/project_template/default/log/error.log b/project_template/default/log/error.log new file mode 100644 --- /dev/null +++ b/project_template/default/log/error.log diff --git a/project_template/default/resources/static/screen.css b/project_template/default/resources/static/screen.css new file mode 100644 --- /dev/null +++ b/project_template/default/resources/static/screen.css @@ -0,0 +1,26 @@ +html { + padding: 0; + margin: 0; + background-color: #ffffff; + font-family: Verdana, Helvetica, sans-serif; +} +body { + padding: 0; + margin: 0; +} +a { + text-decoration: underline; +} +a :hover { + cursor: pointer; + text-decoration: underline; +} +img { + border: none; +} +#content { + padding-left: 1em; +} +#info { + font-size: 60%; +} diff --git a/project_template/default/resources/templates/echo.tpl b/project_template/default/resources/templates/echo.tpl new file mode 100644 --- /dev/null +++ b/project_template/default/resources/templates/echo.tpl @@ -0,0 +1,14 @@ + + + + Echo Page + + +
+

Is there an echo in here?

+
+

You wanted me to say this?

+

""

+

Return

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

It works!

+

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

+

+ Echo test: + cats + dogs + fish +

+ + + + + + + + + +
Config generated at:
Page generated at:
+
+ + diff --git a/project_template/default/src/Application.hs b/project_template/default/src/Application.hs new file mode 100644 --- /dev/null +++ b/project_template/default/src/Application.hs @@ -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 diff --git a/project_template/default/src/Main.hs b/project_template/default/src/Main.hs new file mode 100644 --- /dev/null +++ b/project_template/default/src/Main.hs @@ -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 diff --git a/project_template/default/src/Site.hs b/project_template/default/src/Site.hs new file mode 100644 --- /dev/null +++ b/project_template/default/src/Site.hs @@ -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" diff --git a/project_template/default/src/Snap/Extension/Timer.hs b/project_template/default/src/Snap/Extension/Timer.hs new file mode 100644 --- /dev/null +++ b/project_template/default/src/Snap/Extension/Timer.hs @@ -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] diff --git a/project_template/default/src/Snap/Extension/Timer/Impl.hs b/project_template/default/src/Snap/Extension/Timer/Impl.hs new file mode 100644 --- /dev/null +++ b/project_template/default/src/Snap/Extension/Timer/Impl.hs @@ -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 diff --git a/snap.cabal b/snap.cabal new file mode 100644 --- /dev/null +++ b/snap.cabal @@ -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 diff --git a/src/Snap/Extension.hs b/src/Snap/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extension.hs @@ -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 diff --git a/src/Snap/Extension/Heist.hs b/src/Snap/Extension/Heist.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extension/Heist.hs @@ -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 diff --git a/src/Snap/Extension/Heist/Impl.hs b/src/Snap/Extension/Heist/Impl.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extension/Heist/Impl.hs @@ -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) diff --git a/src/Snap/Extension/Loader/Devel.hs b/src/Snap/Extension/Loader/Devel.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extension/Loader/Devel.hs @@ -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 diff --git a/src/Snap/Extension/Loader/Devel/Helper.hs b/src/Snap/Extension/Loader/Devel/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extension/Loader/Devel/Helper.hs @@ -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 diff --git a/src/Snap/Extension/Server.hs b/src/Snap/Extension/Server.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extension/Server.hs @@ -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 diff --git a/src/Snap/Heist.hs b/src/Snap/Heist.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Heist.hs @@ -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) diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Starter.hs @@ -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 " + , "" + , " 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 diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs new file mode 100644 --- /dev/null +++ b/src/Snap/StarterTH.hs @@ -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]