diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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: diff --git a/commands/happstack.hs b/commands/happstack.hs --- a/commands/happstack.hs +++ b/commands/happstack.hs @@ -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 " putStrLn "Possible commands:" + putStrLn " build auto ...: invoke the auto-builder" putStrLn " new project : 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 () diff --git a/happstack.cabal b/happstack.cabal --- a/happstack.cabal +++ b/happstack.cabal @@ -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 diff --git a/src/Happstack/Server/HSP/HTML.hs b/src/Happstack/Server/HSP/HTML.hs --- a/src/Happstack/Server/HSP/HTML.hs +++ b/src/Happstack/Server/HSP/HTML.hs @@ -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 $ ... +-- 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) diff --git a/src/Happstack/Server/HStringTemplate.hs b/src/Happstack/Server/HStringTemplate.hs --- a/src/Happstack/Server/HStringTemplate.hs +++ b/src/Happstack/Server/HStringTemplate.hs @@ -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" diff --git a/templates/project/bin/build.bat b/templates/project/bin/build.bat --- a/templates/project/bin/build.bat +++ b/templates/project/bin/build.bat @@ -1,1 +1,1 @@ -ghc -isrc src\Main.hs --make -o dist\app +ghc -isrc src\Main.hs --make -o app diff --git a/templates/project/bin/build.sh b/templates/project/bin/build.sh --- a/templates/project/bin/build.sh +++ b/templates/project/bin/build.sh @@ -1,2 +1,2 @@ #!/bin/sh -ghc -isrc src/Main.hs --make -o dist/app +ghc -isrc src/Main.hs --make -o app diff --git a/templates/project/guestbook.cabal b/templates/project/guestbook.cabal --- a/templates/project/guestbook.cabal +++ b/templates/project/guestbook.cabal @@ -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 diff --git a/templates/project/src/App/Control.hs b/templates/project/src/App/Control.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/App/Control.hs @@ -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 diff --git a/templates/project/src/App/Logger.hs b/templates/project/src/App/Logger.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/App/Logger.hs @@ -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]) diff --git a/templates/project/src/App/State.hs b/templates/project/src/App/State.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/App/State.hs @@ -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 []) diff --git a/templates/project/src/App/View.hs b/templates/project/src/App/View.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/App/View.hs @@ -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 $ + + + <% title %> + + + + + + +
+
+

Links

+ +
+
+ +
+
+ +
+
+
14
Feb
+

Happstack Guestbook

+
+

+ Hey congrats! You're using + Happstack 0.3. + This is a guestbook example which you can freely change to your + whims and fancies. +

+

+ This page is written using Haskell Server Pages (HSP). For an example + of a page using HStringTemplate, look at the + dynamic README. +

+

Leave a message for the next visitor here...

+
+


+


+

+
+
+
+
+ + <% body %> +
+
+ +
+
Theme : sIMPRESS v2 by Dezinerfolio
+
+ + + + +renderREADME :: (MonadIO m) => ClockTime -> m Response +renderREADME now = webST "readme" [("time", dateStr now)] + diff --git a/templates/project/src/AppControl.hs b/templates/project/src/AppControl.hs deleted file mode 100644 --- a/templates/project/src/AppControl.hs +++ /dev/null @@ -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 - diff --git a/templates/project/src/AppLogger.hs b/templates/project/src/AppLogger.hs deleted file mode 100644 --- a/templates/project/src/AppLogger.hs +++ /dev/null @@ -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 - diff --git a/templates/project/src/AppState.hs b/templates/project/src/AppState.hs deleted file mode 100644 --- a/templates/project/src/AppState.hs +++ /dev/null @@ -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]) - diff --git a/templates/project/src/AppView.hs b/templates/project/src/AppView.hs deleted file mode 100644 --- a/templates/project/src/AppView.hs +++ /dev/null @@ -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) = - <% -
  • - <% author %> said:

    - <% map p (lines message) %> -
    - <% dateStr date %> -
    • - %> - where p str =

    <% str %>

    - -instance (XMLGenerator m) => (EmbedAsChild m GuestBook) where - asChild (GuestBook entries) = - <% -
    -

    Words of Wisdom

    -
    -
      - <% zip entries (cycle [False,True]) %> -
    -
    - %> - -renderFromBody title body = webHSP $ pageFromBody title body -pageFromBody :: (EmbedAsChild (HSPT' IO) xml) => String -> xml -> HSP XML -pageFromBody title body = - withMetaData html4Strict $ - - - <% title %> - - - - - - -
    -
    -

    Links

    - -
    -
    - -
    -
    - -
    -
    -
    14
    Feb
    -

    Happstack Guestbook

    -
    -

    - Hey congrats! You're using - Happstack 0.2. - This is a guestbook example which you can freely change to your - whims and fancies. -

    -

    - This page is written using Haskell Server Pages (HSP). For an example - of a page using HStringTemplate, look at the - dynamic README. -

    -

    Leave a message for the next visitor here...

    -
    -


    -


    -

    -
    -
    -
    -
    - - <% body %> -
    -
    - -
    -
    Theme : sIMPRESS v2 by Dezinerfolio
    -
    - - - - -renderREADME now = do - webST "readme" [("time", dateStr now)] - diff --git a/templates/project/src/GuestBook.hs b/templates/project/src/GuestBook.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/GuestBook.hs @@ -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 diff --git a/templates/project/src/GuestBook/Control.hs b/templates/project/src/GuestBook/Control.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/GuestBook/Control.hs @@ -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 $
    <% gb %>
    -- FIXME: remove
    + +-- 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 diff --git a/templates/project/src/GuestBook/State.hs b/templates/project/src/GuestBook/State.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/GuestBook/State.hs @@ -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]) diff --git a/templates/project/src/GuestBook/View.hs b/templates/project/src/GuestBook/View.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/GuestBook/View.hs @@ -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) = + <% +
  • + <% author %> said:

    + <% map p (lines message) %> +
    + <% dateStr date %> +
    • + %> + where p str =

    <% str %>

    + +instance (XMLGenerator m) => (EmbedAsChild m GuestBook) where + asChild (GuestBook entries) = + <% +
    +

    Words of Wisdom

    +
    +
      + <% zip entries (cycle [False,True]) %> +
    +
    + %> + +seeOtherXML :: (XMLGenerator m) => String -> XMLGenT m (HSX.XML m) +seeOtherXML url = <% url %> diff --git a/templates/project/src/Main.hs b/templates/project/src/Main.hs --- a/templates/project/src/Main.hs +++ b/templates/project/src/Main.hs @@ -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 diff --git a/tests/Happstack/Tests.hs b/tests/Happstack/Tests.hs --- a/tests/Happstack/Tests.hs +++ b/tests/Happstack/Tests.hs @@ -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 ] diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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