happstack 0.2.1 → 0.3.1
raw patch · 23 files changed
+448/−353 lines, 23 filesdep ~happstack-datadep ~happstack-ixsetdep ~happstack-server
Dependency ranges changed: happstack-data, happstack-ixset, happstack-server, happstack-state, happstack-util
Files
- CHANGELOG +18/−0
- commands/happstack.hs +51/−67
- happstack.cabal +33/−23
- src/Happstack/Server/HSP/HTML.hs +6/−1
- src/Happstack/Server/HStringTemplate.hs +1/−1
- templates/project/bin/build.bat +1/−1
- templates/project/bin/build.sh +1/−1
- templates/project/guestbook.cabal +8/−5
- templates/project/src/App/Control.hs +21/−0
- templates/project/src/App/Logger.hs +31/−0
- templates/project/src/App/State.hs +27/−0
- templates/project/src/App/View.hs +99/−0
- templates/project/src/AppControl.hs +0/−43
- templates/project/src/AppLogger.hs +0/−25
- templates/project/src/AppState.hs +0/−59
- templates/project/src/AppView.hs +0/−118
- templates/project/src/GuestBook.hs +10/−0
- templates/project/src/GuestBook/Control.hs +41/−0
- templates/project/src/GuestBook/State.hs +45/−0
- templates/project/src/GuestBook/View.hs +47/−0
- templates/project/src/Main.hs +6/−7
- tests/Happstack/Tests.hs +1/−1
- tests/Test.hs +1/−1
CHANGELOG view
@@ -1,3 +1,20 @@+Happstack 0.3+ * Modularization of the example application using the component system+ * All packages now require Cabal >= 1.6+ * Repository metadata added to cabal description+ * Moved Combined Logging from Happstack.Server to Happstack.Server.AccessLog.Combined+ * Added Happstack.Util.Mail: a simple email interface which utilizes a smarthost+ * SimpleHTTP: look and lookPairs now assume utf-8 from the browser+ * Space leak fixed in Happstack.Util.Timeout+ * A fix for an issue where alphanumeric Accept-Encoding Requests made the parser fail+ * Fixes for some command-line browsers such as links+ * Guards now have fall-through semantics+ * Various updates & additions to documentation+ * Code beautification+ * Bugfix to Happstack.Util.Cron to accept intervals up to maxBound+ * addition of a strict version of fileServe "fileServeStrict"+ * fileServe (lazy) behaves more reliably now and escapes before any filters can be applied+ Happstack 0.2 * Module namespace refactoring from HAppS to Happstack HAppS.Server -> Happstack.Server@@ -18,6 +35,7 @@ * happstack-server once again builds on Windows * Nearly all the exported functions have been documented! * Cookie fix from happstack-helpers was integrated into the main code+ * Combined Logging via Happstack.Server NOTICE Happstack 0.1 * Cabal packaging name change:
commands/happstack.hs view
@@ -1,96 +1,80 @@ -- happstack command-module Main where+module Main (main) where +import Control.Monad (filterM, liftM, mapM, mapM_) import Paths_happstack (getDataDir) import System.Environment (getArgs)-import System.Directory (createDirectoryIfMissing, doesFileExist, copyFile)-import System.FilePath ((</>))-import Control.Monad (mapM_)+import System.Directory+ ( canonicalizePath+ , createDirectoryIfMissing+ , doesFileExist+ , doesDirectoryExist+ , copyFile+ )+import System.FilePath ((</>), makeRelative)+import Happstack.Util.AutoBuild (autoBuild)+import Happstack.Util.FileManip (always, find) data Command = NewProjectCmd FilePath+ | BuildAutoCmd String String [String] | HelpCmd main :: IO () main = do args <- getArgs- case (processArgs args) of- NewProjectCmd dir -> do- newProject dir+ case processArgs args of+ NewProjectCmd dir -> newProject dir+ BuildAutoCmd buildCmd binPath binArgs -> buildAuto buildCmd binPath binArgs HelpCmd -> do putStrLn "Usage: happstack <command>" putStrLn "Possible commands:"+ putStrLn " build auto <buildCmd> <binPath> <binArgs>...: invoke the auto-builder" putStrLn " new project <dir>: create a new happstack project" processArgs :: [String] -> Command+processArgs ("build" : "auto" : buildCmd : binPath : binArgs) =+ BuildAutoCmd buildCmd binPath binArgs processArgs ["new", "project", dir] = NewProjectCmd dir processArgs ["help"] = HelpCmd processArgs _ = HelpCmd +buildAuto :: String -> String -> [String] -> IO ()+buildAuto = autoBuild+ newProject :: FilePath -> IO ()-newProject destDir = do- dataDir <- getDataDir- - -- create destDir if needed- createDirectoryIfMissing True destDir- - -- create folders- mapM_ (createDirectoryIfMissing False) (destinationFolders destDir)- - -- copy files- mapM_ cp $ zip (sourceFiles dataDir) (destinationFiles destDir)+newProject destDir' = do+ dataDir <- liftM (</> "templates" </> "project") getDataDir+ destDir <- canonicalizePath destDir'+ + -- create destDir if needed+ createDir destDir++ -- create dirs+ srcDirs <- getSourceDirs dataDir+ let destDirs = map ((destDir </>) . makeRelative dataDir) srcDirs+ mapM_ createDir destDirs++ -- create files+ srcFiles <- getSourceFiles dataDir+ let destFiles = map ((destDir </>) . makeRelative dataDir) srcFiles+ mapM_ cp $ zip srcFiles destFiles+ where createDir = createDirectoryIfMissing True --- destination folders that need to be created-destinationFolders destDir =- map- (destDir </>) - [ "bin"- , "dist"- , "public"- , "public/theme"- , "public/theme/images"- , "src"- , "templates"- ]- --- source files for project skeleton (needs to know dataDir location)-sourceFiles dataDir =- map (dataDir </>) projectFiles+-- only source dirs+getSourceDirs :: FilePath -> IO [FilePath]+getSourceDirs dataDir = filterM doesDirectoryExist =<< getSourceData dataDir --- destination files for project skeleton-destinationFiles destDir =- map ((destDir </>) . removePrefix) projectFiles- where removePrefix = drop $ length "templates/project/" +-- only source files+getSourceFiles :: FilePath -> IO [FilePath]+getSourceFiles dataDir = filterM doesFileExist =<< getSourceData dataDir --- all files in the data dir-projectFiles = - [ "templates/project/bin/build.bat"- , "templates/project/bin/build.sh"- , "templates/project/bin/run-interactive.bat"- , "templates/project/bin/run-interactive.sh"- , "templates/project/bin/run.bat"- , "templates/project/bin/run.sh"- , "templates/project/guestbook.cabal"- , "templates/project/public/theme/images/blockquote.gif"- , "templates/project/public/theme/images/date.gif"- , "templates/project/public/theme/images/entrymeta.gif"- , "templates/project/public/theme/images/grunge.gif"- , "templates/project/public/theme/images/header_loop.gif"- , "templates/project/public/theme/images/logo.gif"- , "templates/project/public/theme/images/menu_hili.gif"- , "templates/project/public/theme/images/menu_hover.gif"- , "templates/project/public/theme/images/peel.gif"- , "templates/project/public/theme/images/ql_rss.gif"- , "templates/project/public/theme/readme.txt"- , "templates/project/public/theme/style.css"- , "templates/project/Setup.hs"- , "templates/project/src/AppControl.hs"- , "templates/project/src/AppLogger.hs"- , "templates/project/src/AppState.hs"- , "templates/project/src/AppView.hs"- , "templates/project/src/Main.hs"- , "templates/project/templates/readme.st"- ]+-- source data for project skeleton+getSourceData :: FilePath -> IO [FilePath]+getSourceData rawDataDir = do+ dataDir <- canonicalizePath rawDataDir+ all <- mapM canonicalizePath =<< (find always always dataDir)+ return $ filter (/= dataDir) all -- does not work for folders cp :: (FilePath, FilePath) -> IO ()
happstack.cabal view
@@ -1,5 +1,5 @@ Name: happstack-Version: 0.2.1+Version: 0.3.1 Synopsis: The haskell application server stack + code generation Description: The haskell application server stack License: BSD3@@ -9,38 +9,47 @@ homepage: http://happstack.com Category: Web, Distributed Computing Build-Type: Simple-Cabal-Version: >= 1.4+Cabal-Version: >= 1.6 data-files: CHANGELOG CREDITS RELEASE_NOTES- templates/project/bin/build.bat- templates/project/bin/build.sh+ templates/project/bin/run.bat templates/project/bin/run-interactive.bat+ templates/project/bin/build.sh templates/project/bin/run-interactive.sh- templates/project/bin/run.bat templates/project/bin/run.sh+ templates/project/bin/build.bat+ templates/project/Setup.hs+ templates/project/templates/readme.st+ templates/project/src/GuestBook.hs+ templates/project/src/Main.hs+ templates/project/src/App/Control.hs+ templates/project/src/App/View.hs+ templates/project/src/App/State.hs+ templates/project/src/App/Logger.hs+ templates/project/src/GuestBook/Control.hs+ templates/project/src/GuestBook/View.hs+ templates/project/src/GuestBook/State.hs templates/project/guestbook.cabal- templates/project/public/theme/images/blockquote.gif- templates/project/public/theme/images/date.gif- templates/project/public/theme/images/entrymeta.gif+ templates/project/public/theme/images/menu_hover.gif templates/project/public/theme/images/grunge.gif- templates/project/public/theme/images/header_loop.gif+ templates/project/public/theme/images/entrymeta.gif+ templates/project/public/theme/images/date.gif templates/project/public/theme/images/logo.gif- templates/project/public/theme/images/menu_hili.gif- templates/project/public/theme/images/menu_hover.gif templates/project/public/theme/images/peel.gif+ templates/project/public/theme/images/menu_hili.gif templates/project/public/theme/images/ql_rss.gif+ templates/project/public/theme/images/blockquote.gif+ templates/project/public/theme/images/header_loop.gif templates/project/public/theme/readme.txt templates/project/public/theme/style.css- templates/project/Setup.hs- templates/project/src/AppControl.hs- templates/project/src/AppLogger.hs- templates/project/src/AppState.hs- templates/project/src/AppView.hs- templates/project/src/Main.hs- templates/project/templates/readme.st +source-repository head+ type: darcs+ subdir: happstack+ location: http://patch-tag.com/publicrepos/happstack+ Flag base4 Description: Choose the even newer, even smaller, split-up base package. @@ -58,11 +67,11 @@ build-depends: base >= 3, bytestring,- happstack-data >= 0.2.1 && < 0.3,- happstack-ixset >= 0.2.1 && < 0.3,- happstack-server >= 0.2.1 && < 0.3,- happstack-state >= 0.2.1 && < 0.3,- happstack-util >= 0.2.1 && < 0.3,+ happstack-data >= 0.3 && < 0.4,+ happstack-ixset >= 0.3 && < 0.4,+ happstack-server >= 0.3 && < 0.4,+ happstack-state >= 0.3 && < 0.4,+ happstack-util >= 0.3 && < 0.4, hslogger, hsp >= 0.4.5 && < 0.5, HStringTemplate >= 0.4.3 && < 0.5,@@ -83,6 +92,7 @@ ghc-options: -Wall Executable happstack+ ghc-options: -threaded build-depends: directory >= 1, filepath >= 1
src/Happstack/Server/HSP/HTML.hs view
@@ -7,6 +7,7 @@ import Control.Monad.Trans (MonadIO(), liftIO) import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Lazy.UTF8 as L+import Control.Monad (liftM) import Happstack.Server ( ToMessage(toMessage, toContentType, toResponse) , Response()@@ -32,6 +33,10 @@ toMessage (Nothing, xml) = L.fromString (renderAsHTML xml) +-- | Converts a @HSP XML@ to a Happstack Response.+-- Since @HSP XML@ is the type returned by using literal HTML syntax+-- with HSP, you can wrap up your HTML as webHSP $ <html>...</html>+-- to use it with Happstack. webHSP :: (MonadIO m) => HSP XML -> m Response-webHSP hsp = return . toResponse =<< liftIO (evalHSP Nothing hsp)+webHSP hsp = toResponse `liftM` liftIO (evalHSP Nothing hsp)
src/Happstack/Server/HStringTemplate.hs view
@@ -26,7 +26,7 @@ toContentType _ = B.pack "text/plain;charset=utf-8" toMessage = L.pack . render --- renders a name template with attrs+-- | @webST name attrs@ renders a name template with attrs webST :: (MonadIO m) => String -> [(String, String)] -> m Response webST name attrs = do grp :: STGroup String <- liftIO $ directoryGroupLazy "templates"
templates/project/bin/build.bat view
@@ -1,1 +1,1 @@-ghc -isrc src\Main.hs --make -o dist\app+ghc -isrc src\Main.hs --make -o app
templates/project/bin/build.sh view
@@ -1,2 +1,2 @@ #!/bin/sh-ghc -isrc src/Main.hs --make -o dist/app+ghc -isrc src/Main.hs --make -o app
templates/project/guestbook.cabal view
@@ -15,7 +15,6 @@ public/theme/images/date.gif public/theme/images/ql_rss.gif public/theme/images/header_loop.gif- public/theme/images/Thumbs.db public/theme/images/blockquote.gif public/theme/images/menu_hili.gif public/theme/images/grunge.gif@@ -30,13 +29,17 @@ Library Exposed-Modules:- AppControl,- AppLogger,- AppState+ App.Control,+ App.Logger,+ App.State,+ App.View,+ GuestBook.Control,+ GuestBook.State,+ GuestBook.View hs-source-dirs: src GHC-Options: -threaded -Wall -Wwarn -O2 -fno-warn-name-shadowing -fno-warn-missing-signatures -fwarn-tabs -fno-warn-unused-binds -fno-warn-orphans -fwarn-unused-imports- Build-depends: happstack-state, happstack-server, hslogger, mtl, old-time, old-locale, hsx, hsp, happstack, utf8-string, happstack-data+ Build-depends: happstack-state, happstack-server, hslogger, mtl, old-time, old-locale, hsx, hsp, happstack, utf8-string, happstack-data, extensible-exceptions if flag(base4) Build-Depends: base >= 4 && < 5, syb
+ templates/project/src/App/Control.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+module App.Control (appHandler) where++import App.View+import Control.Monad(msum)+import Control.Monad.Trans(liftIO, MonadIO)+import GuestBook+import Happstack.Server+import System.Time (getClockTime)++appHandler :: ServerPartT IO Response+appHandler = msum+ [ methodM GET >> seeOther "/entries" (toResponse ()) -- matches /+ , renderFromBody "GuestBook" =<< guestBookHandler+ , dir "README" getREADME -- StringTemplate example+ , fileServe ["index.html"] "public" -- static files+ ]++getREADME :: ServerPartT IO Response+getREADME = + methodM GET >> liftIO getClockTime >>= renderREADME
+ templates/project/src/App/Logger.hs view
@@ -0,0 +1,31 @@+module App.Logger (setupLogger) where++import System.Log.Logger+ ( Priority(..)+ , rootLoggerName+ , setLevel+ , setHandlers+ , updateGlobalLogger+ )+import System.Log.Handler.Simple (fileHandler, streamHandler)+import System.IO (stdout)++setupLogger = do+ appLog <- fileHandler "app.log" INFO+ accessLog <- fileHandler "access.log" INFO+ stdoutLog <- streamHandler stdout NOTICE++ -- Root Log+ updateGlobalLogger+ rootLoggerName+ (setLevel DEBUG . setHandlers [appLog])++ -- Access Log+ updateGlobalLogger+ "Happstack.Server.AccessLog.Combined"+ (setLevel INFO . setHandlers [accessLog])++ -- Server Log+ updateGlobalLogger+ "Happstack.Server"+ (setLevel NOTICE . setHandlers [stdoutLog])
+ templates/project/src/App/State.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable,+ FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,+ UndecidableInstances, TypeOperators+ #-}+module App.State where+import Happstack.Data+import Happstack.State+import GuestBook++-- |top-level application state+-- in this case, the top-level state itself does not contain any state+$(deriveAll [''Show, ''Eq, ''Ord, ''Default]+ [d|+ data AppState = AppState+ |])++$(deriveSerialize ''AppState)+instance Version AppState++-- |top-level application component+-- we depend on the GuestBook component+instance Component AppState where+ type Dependencies AppState = GuestBook :+: End+ initialValue = defaultValue+ +-- create types for event serialization+$(mkMethods ''AppState [])
+ templates/project/src/App/View.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module App.View where++import HSP+import System.Locale (defaultTimeLocale)+import System.Time (ClockTime(..), formatCalendarTime, toUTCTime)+import Control.Monad.Trans (MonadIO)+import Happstack.Server (Response)+import Happstack.Server.HStringTemplate (webST)+import Happstack.Server.HSP.HTML (webHSP)++-- * Convenience Functions++dateStr :: ClockTime -> String+dateStr ct =+ formatCalendarTime+ defaultTimeLocale+ "%a, %B %d, %Y at %H:%M:%S (UTC)"+ (toUTCTime ct)++-- * Main Implementation++renderFromBody :: (MonadIO m, EmbedAsChild (HSPT' IO) xml) => String -> xml -> m Response+renderFromBody title = webHSP . pageFromBody title++pageFromBody :: (EmbedAsChild (HSPT' IO) xml) => String -> xml -> HSP XML+pageFromBody title body =+ withMetaData html4Strict $+ <html>+ <head>+ <title><% title %></title>+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />+ <link rel="stylesheet" type="text/css" href="/theme/style.css" media="screen" />+ </head>+ <body>+ <div id="header">+ <div class="grunge"></div>+ <div class="peel"></div>+ <div class="topnavi">+ <ul>+ <li class="current_page_item"><a href="/" title="Guestbook">Guestbook</a></li>+ </ul>+ </div>+ </div>++ <div class="side1">+ <div class="sbar_section">+ <h2>Links</h2>+ <ul>+ <li class="cat-item cat-item-1"><a href="http://happstack.com/" title="happstack" accesskey="H"><span class="accesskey">H</span>appstack</a></li>+ <li class="cat-item cat-item-2"><a href="http://happstack.com/tutorials.html" title="happstack" accesskey="T"><span class="accesskey">T</span>utorials</a></li>+ </ul>+ </div>+ </div>++ <div class="wrap">+ <div class="innercont_main">++ <div class="post">+ <div class="posttop">+ <div class="date">14<div>Feb</div></div>+ <h1 class="posttitle">Happstack Guestbook</h1>+ <div class="storycontent">+ <p>+ Hey congrats! You're using+ <a href="http://happstack.com">Happstack</a> 0.3.+ This is a guestbook example which you can freely change to your+ whims and fancies.+ </p>+ <p>+ This page is written using Haskell Server Pages (HSP). For an example+ of a page using HStringTemplate, look at the+ <a href="/README">dynamic README</a>.+ </p>+ <p>Leave a message for the next visitor here...</p>+ <form action="/entries" method="post" enctype="multipart/form-data;charset=UTF-8" accept-charset="UTF-8">+ <p><label for="author">A<span class="accesskey">u</span>thor</label><br /><input type="text" name="author" id="author" tabindex="1" accesskey="U" /></p>+ <p><label for="message"><span class="accesskey">M</span>essage</label><br /><textarea cols="80" rows="10" name="message" id="message" tabindex="2" accesskey="M"></textarea></p>+ <p><input type="submit" tabindex="3" accesskey="L" value="Leave GuestBook Entry" /></p>+ </form>+ </div>+ </div>+ </div>++ <% body %>+ </div>+ </div>+ + <div class="footer">+ <div class="finalfooter">Theme : <a href="http://www.dezinerfolio.com/2007/10/10/just-another-wodpress-theme" title="sIMPRESS v2 theme">sIMPRESS v2</a> by <a href="http://dezinerfolio.com" title="Dezinerfolio">Dezinerfolio</a></div>+ </div>++ </body>+ </html>++renderREADME :: (MonadIO m) => ClockTime -> m Response+renderREADME now = webST "readme" [("time", dateStr now)]+
− templates/project/src/AppControl.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}-module AppControl (appHandler) where--import AppState-import AppView-import Control.Applicative((<$>))-import Control.Monad(msum)-import Control.Monad.Trans(liftIO, MonadIO)-import Data.ByteString.Lazy.UTF8 (toString)-import Happstack.Data (defaultValue)-import Happstack.Server-import Happstack.State (update,query)-import System.Time (getClockTime)--appHandler :: ServerPartT IO Response-appHandler = msum- [ methodM GET >> seeOther "/entries" (toResponse ()) -- matches /- , dir "entries" $ msum[postEntry, getEntries] -- RESTful /entries- , dir "README" getREADME -- StringTemplate example- , fileServe ["index.html"] "public" -- static files- ]--getEntries = methodM GET >> do- gb <- query ReadGuestBook- renderFromBody "Happstack Guestbook Example" gb--getREADME = methodM GET >> do- now <- liftIO getClockTime- renderREADME now--postEntry = methodM POST >> do -- only accept a post method- Just entry <- getData -- get the data- now <- liftIO getClockTime- update $ AddGuestBookEntry entry{date=now}- seeOther "/entries" (toResponse ())---- this tells happstack how to turn post data into a datatype using 'withData'-instance FromData GuestBookEntry where- fromData = do- author <- toString <$> lookBS "author"- message <- toString <$> lookBS "message"- return $ GuestBookEntry (if (null author) then "Anonymous" else author) message defaultValue-
− templates/project/src/AppLogger.hs
@@ -1,25 +0,0 @@-module AppLogger (setupLogger) where--import System.Log.Logger- ( Priority(..)- , setLevel- , setHandlers- , getLogger- , getRootLogger- , saveGlobalLogger- )-import System.Log.Handler.Simple (fileHandler, streamHandler)-import System.IO (stdout)--setupLogger = do- logFileHandler <- fileHandler ("app.log") DEBUG- stdoutHandler <- streamHandler stdout DEBUG-- -- Log Everything to app.log- server <- getRootLogger- saveGlobalLogger $ setLevel DEBUG $ setHandlers [logFileHandler] server-- -- Log Happstack.Server messages of at least INFO priority to stdout- server <- getLogger "Happstack.Server"- saveGlobalLogger $ setLevel INFO $ setHandlers [stdoutHandler] server-
− templates/project/src/AppState.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable,- FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,- UndecidableInstances- #-}-module AppState where-import Happstack.Data-import Happstack.State-import Control.Monad.Reader (ask)-import Control.Monad.State (get, put)-import Happstack.State.ClockTime---- GuestBookEntry: simple guest book entry-$(deriveAll [''Show, ''Eq, ''Ord]- [d|- data GuestBookEntry = GuestBookEntry- { author :: String- , message :: String- , date :: ClockTime- }- - newtype GuestBook = GuestBook { guestBookEntries :: [GuestBookEntry] }- |]- )--$(deriveSerialize ''GuestBookEntry)-instance Version GuestBookEntry--$(deriveSerialize ''GuestBook)-instance Version GuestBook---- AppState: define our own component, 'AppState' for data persistence-$(deriveAll [''Show, ''Eq, ''Ord]- [d|- data AppState = AppState- { guestBook :: GuestBook- }- |])-$(deriveSerialize ''AppState)-instance Version AppState--instance Component AppState where- type Dependencies AppState = End- initialValue = AppState (GuestBook []) -- empty list of GuestBookEntry's---- readGuestBook: get the guestBook from AppState-readGuestBook :: Query AppState GuestBook-readGuestBook = do- state <- ask- return $ guestBook state- -addGuestBookEntry :: GuestBookEntry -> Update AppState ()-addGuestBookEntry e = do- st <- get- let (GuestBook gb) = guestBook st- put st{guestBook=GuestBook (e:gb)}- --- create types for event serialization-$(mkMethods ''AppState ['readGuestBook, 'addGuestBookEntry])-
− templates/project/src/AppView.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}-module AppView where--import AppState-import HSP-import System.Locale (defaultTimeLocale)-import System.Time (formatCalendarTime, toUTCTime)-import Control.Monad.Trans (MonadIO)-import Happstack.Server.HStringTemplate (webST)-import Happstack.Server.HSP.HTML (webHSP)---- Convenience Functions-dateStr ct =- formatCalendarTime- defaultTimeLocale- "%a, %B %d, %Y at %H:%M:%S (UTC)"- (toUTCTime ct)---- Main Implementation-instance (XMLGenerator m) => (EmbedAsChild m (GuestBookEntry, Bool)) where- asChild ((GuestBookEntry author message date), alt) =- <%- <li class=(if alt then "alt" else "")>- <strong><% author %></strong> said:<br /><br />- <% map p (lines message) %>- <br />- <small class="commentmetadata"><% dateStr date %></small> - </li>- %>- where p str = <p><% str %></p>--instance (XMLGenerator m) => (EmbedAsChild m GuestBook) where- asChild (GuestBook entries) = - <% - <div>- <h2 id="comments" class="h2comment">Words of Wisdom</h2>- <div class="clear" />- <ul class="commentlist">- <% zip entries (cycle [False,True]) %>- </ul>- </div>- %>--renderFromBody title body = webHSP $ pageFromBody title body-pageFromBody :: (EmbedAsChild (HSPT' IO) xml) => String -> xml -> HSP XML-pageFromBody title body =- withMetaData html4Strict $- <html>- <head>- <title><% title %></title>- <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />- <link rel="stylesheet" type="text/css" href="/theme/style.css" media="screen" />- </head>- <body>- <div id="header">- <div class="grunge"></div>- <div class="peel"></div>- <div class="topnavi">- <ul>- <li class="current_page_item"><a href="/" title="Guestbook">Guestbook</a></li>- </ul>- </div>- </div>-- <div class="side1">- <div class="sbar_section">- <h2>Links</h2>- <ul>- <li class="cat-item cat-item-1"><a href="http://happstack.com/" title="happstack" accesskey="H"><span class="accesskey">H</span>appstack</a></li>- <li class="cat-item cat-item-2"><a href="http://happstack.com/tutorials.html" title="happstack" accesskey="T"><span class="accesskey">T</span>utorials</a></li>- </ul>- </div>- </div>-- <div class="wrap">- <div class="innercont_main">-- <div class="post">- <div class="posttop">- <div class="date">14<div>Feb</div></div>- <h1 class="posttitle">Happstack Guestbook</h1>- <div class="storycontent">- <p>- Hey congrats! You're using- <a href="http://happstack.com">Happstack</a> 0.2.- This is a guestbook example which you can freely change to your- whims and fancies.- </p>- <p>- This page is written using Haskell Server Pages (HSP). For an example- of a page using HStringTemplate, look at the- <a href="/README">dynamic README</a>.- </p>- <p>Leave a message for the next visitor here...</p>- <form action="/entries" method="post" enctype="multipart/form-data:charset=UTF-8" accept-charset="UTF-8">- <p><label for="author">A<span class="accesskey">u</span>thor</label><br /><input type="text" name="author" id="author" tabindex="1" accesskey="U" /></p>- <p><label for="message"><span class="accesskey">M</span>essage</label><br /><textarea cols="80" rows="10" name="message" id="message" tabindex="2" accesskey="M"></textarea></p>- <p><input type="submit" tabindex="3" accesskey="L" value="Leave GuestBook Entry" /></p>- </form>- </div>- </div>- </div>-- <% body %>- </div>- </div>- - <div class="footer">- <div class="finalfooter">Theme : <a href="http://www.dezinerfolio.com/2007/10/10/just-another-wodpress-theme" title="sIMPRESS v2 theme">sIMPRESS v2</a> by <a href="http://dezinerfolio.com" title="Dezinerfolio">Dezinerfolio</a></div>- </div>-- </body>- </html>--renderREADME now = do- webST "readme" [("time", dateStr now)]-
+ templates/project/src/GuestBook.hs view
@@ -0,0 +1,10 @@+module GuestBook + ( module GuestBook.Control+ , module GuestBook.State+ , module GuestBook.View+ )+ where++import GuestBook.Control+import GuestBook.State+import GuestBook.View
+ templates/project/src/GuestBook/Control.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module GuestBook.Control where++import Control.Applicative((<$>))+import Control.Monad(msum)+import Control.Monad.Trans(liftIO)+import Data.ByteString.Lazy.UTF8 (toString)+import GuestBook.State (GuestBookEntry(..),AddGuestBookEntry(..),ReadGuestBook(..))+import GuestBook.View+import Happstack.Server+import Happstack.Data(defaultValue)+import Happstack.State(query,update)+import HSP+import System.Time(getClockTime)++guestBookHandler :: ServerPartT IO (HSP XML)+guestBookHandler =+ dir "entries" $ msum [postEntry, getEntries] -- RESTful /entries++postEntry :: ServerPartT IO (HSP XML)+postEntry = methodM POST >> do -- only accept a post method+ Just entry <- getData -- get the data+ now <- liftIO getClockTime+ update $ AddGuestBookEntry entry{date=now}+ seeOther "/entries" (seeOtherXML "/entries")++-- |show all the entries in the guestbook+-- argument is a callback function +getEntries :: ServerPartT IO (HSP XML)+getEntries = + methodM GET >> + do gb <- query ReadGuestBook+ ok $ <div><% gb %></div> -- FIXME: remove <div />++-- this tells happstack how to turn post data into a datatype using 'withData'+instance FromData GuestBookEntry where+ fromData = do+ author <- look "author"+ message <- look "message"+ return $ GuestBookEntry (if null author then "Anonymous" else author) message defaultValue
+ templates/project/src/GuestBook/State.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable,+ FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,+ UndecidableInstances+ #-}+module GuestBook.State where+import Happstack.Data+import Happstack.State+import Control.Monad.Reader (ask)+import Control.Monad.State (modify)+import Happstack.State.ClockTime++$(deriveAll [''Show, ''Eq, ''Ord, ''Default]+ [d|+ -- |GuestBookEntry: simple guest book entry+ data GuestBookEntry = GuestBookEntry+ { author :: String+ , message :: String+ , date :: ClockTime+ }++ -- |GuestBook: a list of GuestBookEntry+ newtype GuestBook = GuestBook { guestBookEntries :: [GuestBookEntry] }+ |])++$(deriveSerialize ''GuestBookEntry)+instance Version GuestBookEntry++$(deriveSerialize ''GuestBook)+instance Version GuestBook++-- | get the 'GuestBook'+readGuestBook :: Query GuestBook GuestBook+readGuestBook = ask+ +-- | add a 'GuestBookEntry' to the 'GuestBook'+addGuestBookEntry :: GuestBookEntry -> Update GuestBook ()+addGuestBookEntry e = modify $ \(GuestBook gb) -> (GuestBook (e:gb))++-- |make Guestbook its own Component+instance Component GuestBook where+ type Dependencies GuestBook = End+ initialValue = defaultValue+ +-- create types for event serialization+$(mkMethods ''GuestBook ['readGuestBook, 'addGuestBookEntry])
+ templates/project/src/GuestBook/View.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -F -pgmFtrhsx #-}+module GuestBook.View where++import GuestBook.State (GuestBook(..),GuestBookEntry(..))+import HSP+import qualified HSX.XMLGenerator as HSX (XML)+import System.Locale (defaultTimeLocale)+import System.Time(ClockTime(..), formatCalendarTime, toUTCTime)++-- * Convenience Functions++dateStr :: ClockTime -> String+dateStr ct =+ formatCalendarTime+ defaultTimeLocale+ "%a, %B %d, %Y at %H:%M:%S (UTC)"+ (toUTCTime ct)++-- * Main Implementation++instance (XMLGenerator m) => (EmbedAsChild m (GuestBookEntry, Bool)) where+ asChild ((GuestBookEntry author message date), alt) =+ <%+ <li class=(if alt then "alt" else "")>+ <strong><% author %></strong> said:<br /><br />+ <% map p (lines message) %>+ <br />+ <small class="commentmetadata"><% dateStr date %></small> + </li>+ %>+ where p str = <p><% str %></p>++instance (XMLGenerator m) => (EmbedAsChild m GuestBook) where+ asChild (GuestBook entries) = + <% + <div>+ <h2 id="comments" class="h2comment">Words of Wisdom</h2>+ <div class="clear" />+ <ul class="commentlist">+ <% zip entries (cycle [False,True]) %>+ </ul>+ </div>+ %>++seeOtherXML :: (XMLGenerator m) => String -> XMLGenT m (HSX.XML m)+seeOtherXML url = <a href=url alt="303 see other"><% url %></a>
templates/project/src/Main.hs view
@@ -1,6 +1,6 @@ module Main where -import Control.Concurrent (MVar(..), forkIO, killThread)+import Control.Concurrent (MVar, forkIO, killThread) import Happstack.Util.Cron (cron) import Happstack.State (waitForTermination) import Happstack.Server@@ -20,13 +20,13 @@ , shutdownSystem , createCheckpoint )-import System.Environment (getArgs, getProgName)+import System.Environment (getArgs) import System.Log.Logger (Priority(..), logM) import System.Exit (exitFailure) import System.Console.GetOpt -import AppLogger (setupLogger)-import AppState (AppState(..))-import AppControl (appHandler)+import App.Logger (setupLogger)+import App.State (AppState(..))+import App.Control (appHandler) stateProxy :: Proxy AppState stateProxy = Proxy@@ -90,6 +90,5 @@ (_,_,errs) -> Left errs startSystemState' :: (Component st, Methods st) => String -> Proxy st -> IO (MVar TxControl)-startSystemState' path proxy =- runTxSystem (Queue (FileSaver path)) proxy+startSystemState' = runTxSystem . Queue . FileSaver
tests/Happstack/Tests.hs view
@@ -9,4 +9,4 @@ import Test.HUnit allTests :: Test-allTests = ("happstack" ~: [ Util.allTests, Data.allTests, IxSet.allTests, State.allTests, Server.allTests, Contrib.allTests ])+allTests = "happstack" ~: [ Util.allTests, Data.allTests, IxSet.allTests, State.allTests, Server.allTests, Contrib.allTests ]
tests/Test.hs view
@@ -14,6 +14,6 @@ else do (c,st) <- runTestText putTextToShowS allTests putStrLn (st "") return c- case (failures c) + (errors c) of+ case failures c + errors c of 0 -> return () n -> exitFailure