happstack 0.5.0.3 → 7.0.2
raw patch · 45 files changed
Files
- CHANGELOG +0/−72
- CREDITS +0/−33
- RELEASE_NOTES +0/−216
- commands/happstack.hs +0/−86
- happstack.cabal +9/−80
- src/HSP/Google/Analytics.hs +0/−62
- src/HSP/Identity.hs +0/−100
- src/HSP/IdentityT.hs +0/−125
- src/HSP/ServerPartT.hs +0/−102
- src/HSP/WebT.hs +0/−102
- src/Happstack/Server/HSP/HTML.hs +0/−46
- src/Happstack/Server/HSX.hs +0/−18
- src/Happstack/Server/HStringTemplate.hs +0/−39
- src/Happstack/State/ClockTime.hs +0/−18
- templates/project/Setup.hs +0/−13
- templates/project/bin/build.bat +0/−1
- templates/project/bin/build.sh +0/−2
- templates/project/bin/run-interactive.bat +0/−1
- templates/project/bin/run-interactive.sh +0/−2
- templates/project/bin/run.bat +0/−1
- templates/project/bin/run.sh +0/−2
- templates/project/guestbook.cabal +0/−41
- templates/project/public/theme/images/blockquote.gif binary
- templates/project/public/theme/images/date.gif binary
- templates/project/public/theme/images/entrymeta.gif binary
- templates/project/public/theme/images/grunge.gif binary
- templates/project/public/theme/images/header_loop.gif binary
- templates/project/public/theme/images/logo.gif binary
- templates/project/public/theme/images/menu_hili.gif binary
- templates/project/public/theme/images/menu_hover.gif binary
- templates/project/public/theme/images/peel.gif binary
- templates/project/public/theme/images/ql_rss.gif binary
- templates/project/public/theme/readme.txt +0/−1
- templates/project/public/theme/style.css +0/−349
- templates/project/src/App/Control.hs +0/−21
- templates/project/src/App/Logger.hs +0/−66
- templates/project/src/App/State.hs +0/−27
- templates/project/src/App/View.hs +0/−102
- templates/project/src/GuestBook.hs +0/−10
- templates/project/src/GuestBook/Control.hs +0/−46
- templates/project/src/GuestBook/State.hs +0/−45
- templates/project/src/GuestBook/State2.hs +0/−59
- templates/project/src/GuestBook/View.hs +0/−49
- templates/project/src/Main.hs +0/−193
- templates/project/templates/readme.st +0/−6
− CHANGELOG
@@ -1,72 +0,0 @@-Happstack 0.4- * happstack-server: Added support for SendFile with an alternate constructor for 'Response'- data Response = Response { rsCode :: Int,- rsHeaders :: Headers,- rsFlags :: RsFlags,- rsBody :: L.ByteString,- rsValidator :: Maybe (Response -> IO Response)- }- | SendFile { rsCode :: Int,- rsHeaders :: Headers,- rsFlags :: RsFlags,- rsValidator :: Maybe (Response -> IO Response),- sfHandle :: Handle, -- file handle to send from- sfOffset :: Integer, -- offset to start at- sfCount :: Integer -- number of bytes to send- }- deriving (Show,Typeable) - * happstack-server: fileServe uses SendFile so the memory efficiency & performance should be much better- * happstack-server: added guards 'host' and 'withHost' to SimpleHTTP- * happstack-server: nuked Happstack.Server.S3 since other hackage libraries cover this functionality these days-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- HAppS.State -> Happstack.State- HAppS.Util -> Happstack.Util- HAppS.IxSet -> Happstack.IxSet- HAppS.Data -> Happstack.Data- HAppS.Contrib -> Happstack.Contrib- * Creation of additional package 'happstack'- * Code generation tool added for creating "quick start" project folders- * Removed dependency of happstack-server on happstack-state- * Removed dependency of happstack-server on happstack-ixset- * Module Cron module moved from happstack-server to happstack-util- * Moved Atom, HList, HListBase from happstack-data to happstack-contrib- * Monadic machinery for ServerPartT and WebT trimmed / cleaned / optimized (Daniel Rogers)- * New experimental gzip filter in happstack-server (similar to apache mod_deflate)- * Builtin support for HSP, HStringTemplate (see example template / release notes)- * 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:- HAppS-Server -> happstack-server- HAppS-State -> happstack-state- HAppS-Util -> happstack-util- HAppS-IxSet -> happstack-ixset- HAppS-Data -> happstack-data- * Creation of additional package 'happstack-contrib' (HAppS.Contrib)- * Moved Facebook module from happstack-server to happstack-contrib- * Fixed various warnings- * Removed dead modules and many dead code blocks- * Turned name resolution off for peers in HTTP.Listen (fixes getNameInfo crash)-
− CREDITS
@@ -1,33 +0,0 @@--- This file exists to honor the various contributions by individuals to--- the Happstack Project. Among these there will undoubtedly be ones I have--- missed. Please contact the mailing list at happs@googlegroups.com if updates--- need to be made. Much thanks to all our contributors!--- --- Sincerely,--- Matthew Elder <matt@mattelder.org>--Alex Jacobson- - HAppS founder- - HAppS Evangelist-Andrea Vezzosi- - Worked on original HAppS Project-Creighton Hogg- - Code Cleanup- - Maintainer of HAppS/Happstack Tutorial-Doug Beardsley- - Creator of various HAppS tutorials-Matthew Elder <matt@mattelder.org>- - Happstack Founder- - HAppS/Happstack Evangelist- - Code Generation Tool (Project Template)-Jeremy Shaw- - Creator of many example applications- - Hyena integration- - HSP Integration- - Made Project Template Pretty-Lemmih (replace with real name?)- - Worked on original HAppS Project- - Multimaster Support-Thomas Hartman- - Creator of HAppS Tutorial-
− RELEASE_NOTES
@@ -1,216 +0,0 @@-Happstack 0.2 Release Notes-================================================================================-- Project / Code generation tool- -------------------------------- There is now a code generation tool for Happstack. This is inspired by the- 'rails' command.- - 1. First install happstack (cabal install happstack)- - 2. Make sure the cabal bin dir is in your path- - in linux this is- ~/.cabal/bin- - in windows this is- C:\Documents and Settings\<username>\Application Data\cabal\bin- where <username> is your windows username.- - 3. Run this command:- happstack new project <dir>- where <dir> is the folder you want to create the project in.- - 4. It will create several folders:- - bin (scripts for your project go here)- - dist (where deployment files will go)- - public (static files for the http server)- - src (project source code goes here)- - templates (HStringTemplate files go here)- - 5. There are three scripts to get your project kick-started- - bin/build (build a static compiled binary at dist/app)- - bin/run (run the project dynamically)- - bin/run-interactive (run the project interactively in ghci)- Each script has a .sh version if you are on *nix and a .bat version if- you are on windows.- - 6. By default, your project will bind to port 8000 on every ip address your- machine has.- - 7. There are five source files in the src folder by default- - AppControl.hs (routing and controller code goes here)- - AppState.hs (MACID state objects are defined here)- - AppView.hs (presentation / view code goes here)- - AppLogger.hs (controls logging for the hslogger system)- - Main.hs (entry point to your app, is has the routines needed to- run your application)- - 8. Enjoy!- - The WebT/ServerPartT change- -------------------------------- WebT and ServerPartT have been substantially refactored. They are now built- from simpler monads. ServerPartT is now the only monad you have to deal- with, most of the time. I.e. you almost never have to look at WebT again.- You just have do blocks in ServerPartT. Inside ServerPartT you can get your- request (askRq), modify your request (localRq), exit immediately- (finishWith), exit failure (mzero), and alter your response filters- (composeFilter, setFilter, getFilter) It also lifts ErrorT, ReaderT, WriterT- and StateT, so you can embed one of those as well. As a bonus, nearly all- the functions you expected to take a WebT or to operate only within a WebT- can now work inside a ServerPartT directly. The monad stack handles all the- data threading.- - That being said, here are a list of the non-backwards compatible changes.- ServerPartT, WebT, unServerPartT and unWebT now have different semantics. To- get existing code to compile you can change your methods like so:-- ServerPartT -> withRequest- WebT -> mkWebT- unServerPartT -> runServerPartT- unWebT -> ununWebT or runWebT depending on what you're going for.-- By just making the above changes, your existing code should continue to work- as before. However, at this point, any old code you have can be greatly- simplified. For example, you will never have to use anyRequest or- withRequest to change from ServerPartT to WebT. You never have to interact- with WebT directly. You can do everything in a ServerPartT do block. The- examples provided in the documentation (especially basicAuth') just barely- touch on the power of ServerPartT now. Notice that basicAuth' mixes reading- requests and altering responses all without exposing WebT, constructing a- ServerPartT, or really doing any data threading at all.-- As a quick example:-- This:- uriRest :: Monad m => (String -> ServerPartT m a) -> ServerPartT m a- uriRest handle = withRequest $ \rq ->- unServerPartT (handle (rqURL rq)) rq-- Becomes this:- uriRest :: (ServerMonad m, Monad m) => (String -> m a) -> m a- uriRest handle = askRq >>= handle . rqURL-- Every single function that uses withRequest, anyRequest, unServerPartT,- unWebT or ununWebT can be rewritten to take advantage of these simple monad- behaviors. Additionally, a lot of functions were added to make it easier to- work entirely inside a do block.- - getHeaderM, addHeaderM, getData, getDataFn, escape', finishWith, getFilter,- setFilter, composeFilter, applyFilter, setResponseCode, guardRq, methodM,- methodOnly, nullDir, requireM-- The following were deprecated since they duplicate functionality- - noHandle -> Use mzero- multi -> Use msum- method -> you should be able to use methodSP though you'll need to fix- your typing- modifyResponse -> use composeFilter-- Also, this release sees the return of simpleHTTP', though not as you knew it- before. simpleHTTP must take a ServerPartT IO a. simpleHTTP' lets you use- Any ServerPartT m a, as long as you provide a function for unwrapping your- interior monad into an IO monad. This is particularly important since- ServerPartT has lifting instances for WriterT, StateT, ErrorT, and ReaderT,- thus embedding your favorite monad transformer into ServerPartT is easier- than ever.-- Documentation- -------------------------------- This release also adds substantial documentation for the package- Happstack.Server.SimpleHTTP which convers most of the new structures added,- as well as many of your old favorites. Be sure to check it out.-- Removing list types from SimpleHTTP- -------------------------------- Having most of the methods in SimpleHTTP take array types was cumbersome,- since often you only had one part and had to wrap it up. All methods that- used to take a list of ServerPartTs now only take a single ServerPartT. To- convert your list of ServerPartT into a single ServerPartT, use msum.-- For example:- simpleHTTP nullConf [spart1, spart2]- Becomes:- simpleHTTP nullConf $ msum [spart1, spart2]- - The functions affected by this change are:- simpleHTTP, dir, path, anyPath, withData, withDataFn, require, requireM,- xslt, debugFilter, applyRequest, basicAuth, and errorHandlerSP-- Gzip/Deflate encoding- ------------------------------- There is now a ServerPartT for gzip/deflate encoding, in- Happstack.Server.Parts.compressedResponseFilter-- Guidlines for porting existing HAppS and Happstack <= 0.1 code to 0.2- -------------------------------- The first change you should do is change the following functions- as described above.- ServerPartT -> withRequest- WebT -> mkWebT- unServerPartT -> runServerPartT- unWebT -> ununWebT- - Next, work on prepending $ msum in front of every list of ServerPartTs, or- deleting lists that are no longer necessary.-- After this point, you should be able to get your app compiled and running.- To further clean up your code and take advantage of the new functionality in- ServerPartT, the general procedure is as follows:-- - consider studying the revised examples in happstack-server/Examples. They- all use the new idioms.- - - delete your type signatures that reference WebT or ServerPartT, as after- the first step they will all have changed dramatically-- - delete all uses of withRequest and anyRequest (they aren't needed anymore)-- - change the idiom 'method m $' to 'methodM m >>'-- - change 'withRequest \rq -> do ...' to 'do { rq <- askRq; ... }'-- - change withData \myDat $ \dat -> do ... to- do dat <- getData >>= maybe mzero return- ... - - - change withDataFn fn \myDat $ \dat -> do ... to- do dat <- getDataFn fn >>= maybe mzero return- ...-- - change all references of noHandle to mzero- - - you can probably benefit from some do blocks at this point-- - if you're passing around the request explictly, stop. You can just- "rq <- askRq" whenever you need it.-- - consider embedding your favorite monad transformer into your ServerPartTs.- To make this work, you'll want to read the documentation for simpleHTTP',- mapServerPartT, and WebT- - - consider reading the newly minted documentation for- Happstack.Server.SimpleHTTP. Hopefully you'll learn something.-- Windows Bin Path Caveats- ------------------------------- By default when you install say ghc 6.8.3 or 6.10.1, windows won't setup the paths.- You need to perform these steps after running the installer for ghc:- 1. Right Click on "My Computer"- 2. Left Click on "Properties"- 3. Advanced Tab- 4. Environmental Variables- 5. Add or Edit existing 'PATH' variable- If you have ghc 6.8.3 for instance:- 1. Prepend "C:\ghc\ghc-6.8.3;C:\ghc\ghc-6.8.3\bin;" to the Variable value- 2. Click OK- 3. Restart and cmd windows you have open- 6. Now all the commands should work i.e. ghci, ghc-pkg, perl etc.- 7. You will need happy to compile happstack- Follow these steps:- 1. Install happy via cabal install or the manual method- 2. Prepend "C:\Documents and Settings\user\Application Data\cabal\bin"- to your Environment Path variable where user is your username.- 3. Now any binaries installed by cabal packages will also be in your- command path.-
− commands/happstack.hs
@@ -1,86 +0,0 @@--- happstack command-module Main (main) where--import Control.Monad (filterM, liftM, mapM, mapM_)-import Paths_happstack (getDataDir)-import System.Environment (getArgs)-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 -> 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 <- 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- --- only source dirs-getSourceDirs :: FilePath -> IO [FilePath]-getSourceDirs dataDir = filterM doesDirectoryExist =<< getSourceData dataDir---- only source files-getSourceFiles :: FilePath -> IO [FilePath]-getSourceFiles dataDir = filterM doesFileExist =<< getSourceData dataDir---- 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 ()-cp (src, dest) = do- exists <- doesFileExist dest- if exists- then putStrLn $ "File exists already, skipping: " ++ dest- else copyFile src dest-
happstack.cabal view
@@ -1,5 +1,5 @@ Name: happstack-Version: 0.5.0.3+Version: 7.0.2 Synopsis: The haskell application server stack + code generation Description: The haskell application server stack License: BSD3@@ -11,45 +11,10 @@ Build-Type: Simple Cabal-Version: >= 1.6 -data-files: CHANGELOG- CREDITS- RELEASE_NOTES- 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.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/src/GuestBook/State2.hs- templates/project/guestbook.cabal- templates/project/public/theme/images/menu_hover.gif- templates/project/public/theme/images/grunge.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/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- source-repository head type: darcs subdir: happstack- location: http://patch-tag.com/r/mae/happstack/pullrepo+ location: http://hub.darcs.net/stepcut/happstack Flag base4 Description: Choose the even newer, even smaller, split-up base package.@@ -59,61 +24,25 @@ Default: False Library- exposed-modules: Happstack.Server.HSP.HTML- Happstack.Server.HSX- Happstack.Server.HStringTemplate- Happstack.State.ClockTime- HSP.Identity- HSP.IdentityT- HSP.ServerPartT- HSP.WebT- HSP.Google.Analytics if flag(tests) Exposed-modules: Happstack.Tests other-modules: Paths_happstack - build-depends: base >= 3,- bytestring,- happstack-data >= 0.5 && < 0.6,- happstack-ixset >= 0.5 && < 0.6,- happstack-server >= 0.5 && < 0.6,- happstack-state >= 0.5 && < 0.6,- happstack-util >= 0.5 && < 0.6,- harp >= 0.4 && < 0.5,- hslogger,- hsx >= 0.7 && < 0.8,- hsp >= 0.5.2 && < 0.6,- HStringTemplate >= 0.4.3 && < 0.7,- mtl >= 1.1 && < 2.1,- old-time,- utf8-string,- text- - if flag(base4)- Build-Depends: base >= 4 && < 5, syb- else- build-depends: haskell-src-exts == 0.3.9,- HStringTemplate < 0.6+ build-depends: base >= 3 && <5,+ happstack-server >= 7.0 && < 7.4 - hs-source-dirs: src if flag(tests) hs-source-dirs: tests - ghc-options: -Wall--Executable happstack- ghc-options: -threaded- build-depends: directory >= 1,- filepath >= 1- - hs-source-dirs: commands- main-is: happstack.hs-+ if impl(ghc >= 6.12)+ ghc-options: -Wall -fno-warn-unused-do-bind+ else+ ghc-options: -Wall Executable happstack-tests Main-Is: Test.hs GHC-Options: -threaded- hs-source-dirs: tests, src+ hs-source-dirs: tests if flag(tests) Buildable: True Build-depends: HUnit
− src/HSP/Google/Analytics.hs
@@ -1,62 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts -F -pgmFtrhsx #-}-module HSP.Google.Analytics - ( UACCT(..)- , analytics- , addAnalytics- ) where--import Data.Generics (Data, Typeable)-import HSP-import Prelude hiding (head)--newtype UACCT = UACCT String -- ^ The UACCT provided to you by Google- deriving (Read, Show, Eq, Ord, Typeable, Data)---- | create the google analytics script tags--- NOTE: you must put the <% analytics yourUACCT %> immediately before the </body> tag--- See also: addAnalytics-analytics :: (XMLGenerator m) => UACCT -> GenXMLList m-analytics (UACCT uacct) =- do a <- <script type="text/javascript">- var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");- document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));- </script>- b <- <script type="text/javascript">- var pageTracker = _gat._getTracker("<% uacct %>");- pageTracker._initData();- pageTracker._trackPageview();- </script>- return [a,b]---- | automatically add the google analytics scipt tags immediately before the </body> element--- NOTE: this function is not idepotent-addAnalytics :: ( AppendChild m XML- , EmbedAsChild m XML- , EmbedAsAttr m Attribute- , XMLGenerator m) - => UACCT - -> XMLGenT m XML - -> GenXML m-addAnalytics uacct pg =- do page <- pg- a <- analytics uacct- case page of- <html hattrs><[ head, body ]></html> ->- <html hattrs>- <% head %>- <% body <: a %>- </html>- o -> error ("Failed to add analytics." ++ show o)--{- Example Analytics Code from Google:--<script type="text/javascript">-var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");-document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));-</script>-<script type="text/javascript">-var pageTracker = _gat._getTracker("UA-4353757-1");-pageTracker._initData();-pageTracker._trackPageview();-</script>--}
− src/HSP/Identity.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module HSP.Identity - ( Ident- , evalIdentity- ) where--import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import HSP-import Control.Monad.Identity (Identity(Identity, runIdentity))-import qualified HSX.XMLGenerator as HSX--instance HSX.XMLGenerator Identity--instance HSX.XMLGen Identity where- type HSX.XML Identity = XML- newtype HSX.Child Identity = IChild { unIChild :: XML }- newtype HSX.Attribute Identity = IAttr { unIAttr :: Attribute }- genElement n attrs children = HSX.XMLGenT $ Identity (Element- (toName n)- (map unIAttr $ concatMap runIdentity $ map HSX.unXMLGenT attrs)- (map unIChild $ concatMap runIdentity $ map HSX.unXMLGenT children)- )- xmlToChild = IChild- pcdataToChild = HSX.xmlToChild . pcdata--instance IsAttrValue Identity T.Text where- toAttrValue = toAttrValue . T.unpack--instance IsAttrValue Identity TL.Text where- toAttrValue = toAttrValue . TL.unpack--instance EmbedAsAttr Identity Attribute where- asAttr = return . (:[]) . IAttr --instance EmbedAsAttr Identity (Attr String Char) where- asAttr (n := c) = asAttr (n := [c])--instance EmbedAsAttr Identity (Attr String String) where- asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)--instance EmbedAsAttr Identity (Attr String Bool) where- asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true")- asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")--instance EmbedAsAttr Identity (Attr String Int) where- asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))--instance (IsName n) => (EmbedAsAttr Identity (Attr n TL.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)--instance (IsName n) => (EmbedAsAttr Identity (Attr n T.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)--instance EmbedAsChild Identity Char where- asChild = XMLGenT . Identity . (:[]) . IChild . pcdata . (:[])--instance EmbedAsChild Identity String where- asChild = XMLGenT . Identity . (:[]) . IChild . pcdata--instance (EmbedAsChild Identity TL.Text) where- asChild = asChild . TL.unpack--instance (EmbedAsChild Identity T.Text) where- asChild = asChild . T.unpack--instance EmbedAsChild Identity XML where- asChild = XMLGenT . Identity . (:[]) . IChild--instance EmbedAsChild Identity () where- asChild () = return []--instance AppendChild Identity XML where- appAll xml children = do- chs <- children- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n as (cs ++ (map stripChild chs))--stripAttr :: HSX.Attribute Identity -> Attribute-stripAttr (IAttr a) = a--stripChild :: HSX.Child Identity -> XML-stripChild (IChild c) = c--instance SetAttr Identity XML where- setAll xml hats = do- attrs <- hats- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs--insert :: Attribute -> Attributes -> Attributes-insert = (:)--evalIdentity :: XMLGenT Identity XML -> XML-evalIdentity = runIdentity . HSX.unXMLGenT--type Ident = XMLGenT Identity
− src/HSP/IdentityT.hs
@@ -1,125 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-}-module HSP.IdentityT - ( evalIdentityT- , IdentT- , IdentityT(..)- ) where--import Control.Applicative (Applicative((<*>), pure))-import Control.Monad (MonadPlus)-import Control.Monad.Writer (MonadWriter)-import Control.Monad.Reader (MonadReader)-import Control.Monad.State (MonadState)-import Control.Monad.RWS (MonadRWS)-import Control.Monad.Trans (MonadTrans(lift), MonadIO(liftIO))-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import HSP-import qualified HSX.XMLGenerator as HSX---- * IdentityT Monad Transformer--newtype IdentityT m a = IdentityT { runIdentityT :: m a }- deriving (Functor, Monad, MonadWriter w, MonadReader r, MonadState s, MonadRWS r w s, MonadIO, MonadPlus)--instance (Applicative f) => Applicative (IdentityT f) where- pure = IdentityT . pure - (IdentityT f) <*> (IdentityT a) = IdentityT (f <*> a)--instance MonadTrans IdentityT where- lift = IdentityT---- * HSX.XMLGenerator for IdentityT--instance (Monad m, Functor m) => HSX.XMLGenerator (IdentityT m)--instance (Functor m, Monad m) => HSX.XMLGen (IdentityT m) where- type HSX.XML (IdentityT m) = XML- newtype HSX.Child (IdentityT m) = IChild { unIChild :: XML }- newtype HSX.Attribute (IdentityT m) = IAttr { unIAttr :: Attribute }- genElement n attrs children = HSX.XMLGenT $ - do attrs' <- HSX.unXMLGenT (fmap (map unIAttr . concat) (sequence attrs))- children' <- HSX.unXMLGenT (fmap (map unIChild . concat) (sequence children))- return (Element (toName n) attrs' children')- xmlToChild = IChild- pcdataToChild = HSX.xmlToChild . pcdata--instance (Monad m, Functor m) => IsAttrValue (IdentityT m) T.Text where- toAttrValue = toAttrValue . T.unpack--instance (Monad m, Functor m) => IsAttrValue (IdentityT m) TL.Text where- toAttrValue = toAttrValue . TL.unpack--instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) Attribute where- asAttr = return . (:[]) . IAttr --instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Char) where- asAttr (n := c) = asAttr (n := [c])--instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String String) where- asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)--instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Bool) where- asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true")- asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")--instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Int) where- asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))--instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (IdentityT m) (Attr n TL.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)--instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (IdentityT m) (Attr n T.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)--instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) Char where- asChild = XMLGenT . return . (:[]) . IChild . pcdata . (:[])--instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) String where- asChild = XMLGenT . return . (:[]) . IChild . pcdata--instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) (IdentityT m String) where- asChild c = - do c' <- lift c- lift . return . (:[]) . IChild . pcdata $ c'--instance (Monad m, Functor m) => (EmbedAsChild (IdentityT m) TL.Text) where- asChild = asChild . TL.unpack--instance (Monad m, Functor m) => (EmbedAsChild (IdentityT m) T.Text) where- asChild = asChild . T.unpack--instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) XML where- asChild = XMLGenT . return . (:[]) . IChild--instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) () where- asChild () = return []--instance (Monad m, Functor m) => AppendChild (IdentityT m) XML where- appAll xml children = do- chs <- children- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n as (cs ++ (map stripChild chs))--stripAttr :: (Monad m, Functor m) => HSX.Attribute (IdentityT m) -> Attribute-stripAttr (IAttr a) = a--stripChild :: (Monad m, Functor m) => HSX.Child (IdentityT m) -> XML-stripChild (IChild c) = c--instance (Monad m, Functor m) => SetAttr (IdentityT m) XML where- setAll xml hats = do- attrs <- hats- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs--insert :: Attribute -> Attributes -> Attributes-insert = (:)--evalIdentityT :: (Functor m, Monad m) => XMLGenT (IdentityT m) XML -> m XML-evalIdentityT = runIdentityT . HSX.unXMLGenT--type IdentT m = XMLGenT (IdentityT m) XML
− src/HSP/ServerPartT.hs
@@ -1,102 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module HSP.ServerPartT where--import HSP-import Control.Monad (liftM)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified HSX.XMLGenerator as HSX-import Happstack.Server (ServerPartT)--instance (Monad m) => HSX.XMLGen (ServerPartT m) where- type HSX.XML (ServerPartT m) = XML- newtype HSX.Child (ServerPartT m) = SChild { unSChild :: XML }- newtype HSX.Attribute (ServerPartT m) = SAttr { unSAttr :: Attribute }- genElement n attrs children = - do attribs <- map unSAttr `liftM` asAttr attrs- childer <- (flattenCDATA . map unSChild) `liftM`asChild children- HSX.XMLGenT $ return (Element- (toName n)- attribs- childer- )- xmlToChild = SChild- pcdataToChild = HSX.xmlToChild . pcdata--flattenCDATA :: [XML] -> [XML]-flattenCDATA cxml = - case flP cxml [] of- [] -> []- [CDATA _ ""] -> []- xs -> xs - where- flP :: [XML] -> [XML] -> [XML]- flP [] bs = reverse bs- flP [x] bs = reverse (x:bs)- flP (x:y:xs) bs = case (x,y) of- (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs- _ -> flP (y:xs) (x:bs)---instance (Monad m, Functor m) => IsAttrValue (ServerPartT m) T.Text where- toAttrValue = toAttrValue . T.unpack--instance (Monad m, Functor m) => IsAttrValue (ServerPartT m) TL.Text where- toAttrValue = toAttrValue . TL.unpack--instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) Attribute where- asAttr = return . (:[]) . SAttr --instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String Char) where- asAttr (n := c) = asAttr (n := [c])--instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String String) where- asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)--instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String Bool) where- asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true")- asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")--instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String Int) where- asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))--instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (ServerPartT m) (Attr n TL.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)--instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (ServerPartT m) (Attr n T.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)--instance (Monad m) => EmbedAsChild (ServerPartT m) Char where- asChild = XMLGenT . return . (:[]) . SChild . pcdata . (:[])--instance (Monad m) => EmbedAsChild (ServerPartT m) String where- asChild = XMLGenT . return . (:[]) . SChild . pcdata--instance (Monad m) => EmbedAsChild (ServerPartT m) XML where- asChild = XMLGenT . return . (:[]) . SChild--instance Monad m => EmbedAsChild (ServerPartT m) () where- asChild () = return []--instance (Monad m, Functor m) => (EmbedAsChild (ServerPartT m) TL.Text) where- asChild = asChild . TL.unpack--instance (Monad m, Functor m) => (EmbedAsChild (ServerPartT m) T.Text) where- asChild = asChild . T.unpack--instance (Monad m) => AppendChild (ServerPartT m) XML where- appAll xml children = do- chs <- children- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n as (cs ++ (map unSChild chs))--instance (Monad m) => SetAttr (ServerPartT m) XML where- setAll xml hats = do- attrs <- hats- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n (foldr (:) as (map unSAttr attrs)) cs--instance (Monad m) => XMLGenerator (ServerPartT m)
− src/HSP/WebT.hs
@@ -1,102 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module HSP.WebT where--import HSP-import Control.Monad (liftM)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified HSX.XMLGenerator as HSX-import Happstack.Server (WebT)--instance (Monad m) => HSX.XMLGen (WebT m) where- type HSX.XML (WebT m) = XML- newtype HSX.Child (WebT m) = WChild { unWChild :: XML }- newtype HSX.Attribute (WebT m) = WAttr { unWAttr :: Attribute }- genElement n attrs children = - do attribs <- map unWAttr `liftM` asAttr attrs- childer <- (flattenCDATA . map unWChild) `liftM` asChild children- HSX.XMLGenT $ return (Element- (toName n)- attribs- childer- )- xmlToChild = WChild- pcdataToChild = HSX.xmlToChild . pcdata--flattenCDATA :: [XML] -> [XML]-flattenCDATA cxml = - case flP cxml [] of- [] -> []- [CDATA _ ""] -> []- xs -> xs - where- flP :: [XML] -> [XML] -> [XML]- flP [] bs = reverse bs- flP [x] bs = reverse (x:bs)- flP (x:y:xs) bs = case (x,y) of- (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs- _ -> flP (y:xs) (x:bs)---instance (Monad m, Functor m) => IsAttrValue (WebT m) T.Text where- toAttrValue = toAttrValue . T.unpack--instance (Monad m, Functor m) => IsAttrValue (WebT m) TL.Text where- toAttrValue = toAttrValue . TL.unpack--instance (Monad m) => HSX.EmbedAsAttr (WebT m) Attribute where- asAttr = return . (:[]) . WAttr --instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String Char) where- asAttr (n := c) = asAttr (n := [c])--instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String String) where- asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)--instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String Bool) where- asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true")- asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")--instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String Int) where- asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))--instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (WebT m) (Attr n TL.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)--instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (WebT m) (Attr n T.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)--instance (Monad m) => EmbedAsChild (WebT m) Char where- asChild = XMLGenT . return . (:[]) . WChild . pcdata . (:[])--instance (Monad m) => EmbedAsChild (WebT m) String where- asChild = XMLGenT . return . (:[]) . WChild . pcdata--instance (Monad m, Functor m) => (EmbedAsChild (WebT m) TL.Text) where- asChild = asChild . TL.unpack--instance (Monad m, Functor m) => (EmbedAsChild (WebT m) T.Text) where- asChild = asChild . T.unpack--instance (Monad m) => EmbedAsChild (WebT m) XML where- asChild = XMLGenT . return . (:[]) . WChild--instance Monad m => EmbedAsChild (WebT m) () where- asChild () = return []--instance (Monad m) => AppendChild (WebT m) XML where- appAll xml children = do- chs <- children- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n as (cs ++ (map unWChild chs))--instance (Monad m) => SetAttr (WebT m) XML where- setAll xml hats = do- attrs <- hats- case xml of- CDATA _ _ -> return xml- Element n as cs -> return $ Element n (foldr (:) as (map unWAttr attrs)) cs--instance (Monad m) => XMLGenerator (WebT m)
− src/Happstack/Server/HSP/HTML.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Happstack.Server.HSP.HTML- ( webHSP- , webHSP'- ) where--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()- )-import HSP- ( HSP()- , XML()- , XMLMetaData(XMLMetaData, contentType)- , evalHSP- , html4Strict- , renderAsHTML- )--instance ToMessage XML where- toContentType _ = P.pack "text/html;charset=utf-8"- toMessage xml = toMessage (html4Strict, xml)--instance ToMessage (Maybe XMLMetaData, XML) where- toContentType (Just md,_) = P.pack (contentType md)- toContentType _ = P.pack "text/html;charset=utf-8"- toMessage (Just (XMLMetaData (showDt, dt) _ pr), xml) = - L.fromString ((if showDt then (dt ++) else id) (pr xml))- 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 = webHSP' Nothing---- | webHSP with XMLMetaData-webHSP' :: (MonadIO m) => Maybe XMLMetaData -> HSP XML -> m Response-webHSP' metadata hsp = toResponse `liftM` liftIO (evalHSP metadata hsp)
− src/Happstack/Server/HSX.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Happstack.Server.HSX where--import Happstack.Server.SimpleHTTP (ServerMonad(..), FilterMonad(..), WebMonad(..))-import HSX.XMLGenerator (XMLGenT(..))--instance (ServerMonad m) => ServerMonad (XMLGenT m) where- askRq = XMLGenT askRq- localRq f (XMLGenT m) = XMLGenT (localRq f m)--instance (FilterMonad a m) => FilterMonad a (XMLGenT m) where- setFilter = XMLGenT . setFilter- composeFilter f = XMLGenT (composeFilter f)- getFilter (XMLGenT m) = XMLGenT (getFilter m)--instance (WebMonad a m) => WebMonad a (XMLGenT m) where- finishWith r = XMLGenT $ finishWith r
− src/Happstack/Server/HStringTemplate.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Happstack.Server.HStringTemplate (webST) where--import Happstack.Server- ( ToMessage(toMessage, toContentType, toResponse)- , Response- )-import Control.Monad.Trans (MonadIO, liftIO)-import Text.StringTemplate- ( STGroup- , StringTemplate- , directoryGroupLazy- , getStringTemplate- , render- , setManyAttrib- )-import qualified Data.ByteString.Char8 as B (pack)-import qualified Data.ByteString.Lazy.Char8 as L (pack)-import System.Log.Logger (Priority(..), logM)-log' :: Priority -> String -> IO ()-log' = logM "Happstack.Server.HStringTemplate"---- FIXME: Caveat, assumes text/html, can this be handled at the filter level?-instance ToMessage (StringTemplate String) where- toContentType _ = B.pack "text/html;charset=utf-8"- toMessage = L.pack . render---- | @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"- case getStringTemplate name grp of- Just tmp -> do- -- FIXME: I would rather use show, but StringTemplate String has no Show instance- liftIO $ log' INFO ("webST executing: " ++ name)- return . toResponse $ setManyAttrib attrs tmp- Nothing -> fail $ "Template does not exist: " ++ name-
− src/Happstack/State/ClockTime.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable,- FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,- UndecidableInstances, StandaloneDeriving, TypeSynonymInstances- #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |instances of Typeable, Data, Serialize, Version, and Default for ClockTime-module Happstack.State.ClockTime (ClockTime(..)) where--import Data.Generics (Data, Typeable)-import Happstack.Data (deriveNewData)-import Happstack.State (Version, deriveSerialize)-import System.Time (ClockTime(..))--deriving instance Typeable ClockTime-deriving instance Data ClockTime-instance Version ClockTime-$(deriveSerialize ''ClockTime)-$(deriveNewData [''ClockTime])
− templates/project/Setup.hs
@@ -1,13 +0,0 @@-#!/usr/bin/env runghc--module Main where--import Distribution.Simple-import Distribution.Simple.Program--trhsxProgram = simpleProgram "trhsx"--main :: IO ()-main = defaultMainWithHooks simpleUserHooks {- hookedPrograms = [trhsxProgram]- }
− templates/project/bin/build.bat
@@ -1,1 +0,0 @@-ghc -isrc src\Main.hs --make -o app
− templates/project/bin/build.sh
@@ -1,2 +0,0 @@-#!/bin/sh-ghc -isrc src/Main.hs --make -o app
− templates/project/bin/run-interactive.bat
@@ -1,1 +0,0 @@-ghci -isrc -isrc-interactive-only src\Main.hs
− templates/project/bin/run-interactive.sh
@@ -1,2 +0,0 @@-#!/bin/sh-ghci -isrc -isrc-interactive-only src/Main.hs
− templates/project/bin/run.bat
@@ -1,1 +0,0 @@-runghc -isrc src\Main.hs
− templates/project/bin/run.sh
@@ -1,2 +0,0 @@-#!/bin/sh-runghc -isrc src/Main.hs
− templates/project/guestbook.cabal
@@ -1,41 +0,0 @@-Name: guestbook-Version: 1.0-Author: Jeremy Shaw <jeremy@seereason.com>, Matthew Elder <matt@mattelder.org>-Copyright: 2009 Jeremy Shaw-Stability: Experimental-Category: Web-Synopsis: An example guestbook application which uses happstack and HSP-Description:- This small example guestbook makes an excellent starting point for- your own happstack applications.-Cabal-version: >= 1.4.0.0-Build-type: Custom-Data-files: - public/theme/style.css- public/theme/images/date.gif- public/theme/images/ql_rss.gif- public/theme/images/header_loop.gif- public/theme/images/blockquote.gif- public/theme/images/menu_hili.gif- public/theme/images/grunge.gif- public/theme/images/entrymeta.gif- public/theme/images/logo.gif- public/theme/images/peel.gif- public/theme/images/menu_hover.gif- public/theme/readme.txt--Flag base4- Description: Choose the even newer, even smaller, split-up base package.--Executable guestbook-server- Main-Is: Main.hs- 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, extensible-exceptions, happstack-util- if !os(windows)- -- Cabal has a bug on windows and cannot find trhsx- Build-Tools: trhsx-- if flag(base4)- Build-Depends: base >= 4 && < 5, syb
− templates/project/public/theme/images/blockquote.gif
binary file changed (103 → absent bytes)
− templates/project/public/theme/images/date.gif
binary file changed (941 → absent bytes)
− templates/project/public/theme/images/entrymeta.gif
binary file changed (182 → absent bytes)
− templates/project/public/theme/images/grunge.gif
binary file changed (3669 → absent bytes)
− templates/project/public/theme/images/header_loop.gif
binary file changed (207 → absent bytes)
− templates/project/public/theme/images/logo.gif
binary file changed (3102 → absent bytes)
binary file changed (313 → absent bytes)
binary file changed (205 → absent bytes)
− templates/project/public/theme/images/peel.gif
binary file changed (4961 → absent bytes)
− templates/project/public/theme/images/ql_rss.gif
binary file changed (296 → absent bytes)
− templates/project/public/theme/readme.txt
@@ -1,1 +0,0 @@-Theme by Dezinerfolio.com
− templates/project/public/theme/style.css
@@ -1,349 +0,0 @@- -/* -Theme Name: Dezinerfolio (s)impress -Theme URI: dezinerfolio.com -Description: Simple and Clean theme -Version: 2.0 -Author: Navdeep Raj -*/ - -*{ - margin:0; - padding:0; -} - -body{ - font-family: arial, helvetica; - font-size:14px; - background: #fff; -} - -#header{ - height:98px; - clear:both; - background:#FFF url(images/header_loop.gif) repeat-x 0 0; -} - -.mainlogo{ - float:left; - padding:0px 50px; -} - -.mainlogo a{ - background:url(images/logo.gif) no-repeat 0 0; - width:144px; - height:98px; - display:block; - overflow:hidden; - text-indent:-9999px; -} - -.topnavi li{ - float:left; - list-style:none; - overflow:hidden; -} - -.topnavi .page_item{ - background:url(images/header_loop.gif) repeat-x left top; - border-left:1px solid #e4e4e4; - border-right:1px solid #e4e4e4; - display:block; -} - -.topnavi li a{ - padding:60px 20px 0 20px; - height:27px; - display:block; - float:left; - text-decoration:none; - font-size:12px; - color:#585858; -} - -.topnavi li a:hover{ - background:url(images/menu_hover.gif) repeat-x 0 0; -} - -.topnavi .current_page_item{ - background:url(images/menu_hili.gif) repeat-x left top; - border:1px solid #3e8709; - overflow:hidden; - display:block; -} - -.topnavi .current_page_item a:hover{ - background:url(images/menu_hili.gif) repeat-x left top; -} - -.topnavi .current_page_item a{ - color:#FFF; - font-weight:bold; -} - -.grunge{ - background:url(images/grunge.gif); - width:105px; - height:98px; - display:block; - float:left; -} - -.side1{ - float:left; - width:200px; - padding:12px -} - -.side2{ - float:left; - width:200px; - padding:12px; -} - -.sbar_section{ - padding:10px 0; -} - -.side1 li, .side2 li{ - list-style:none; -} - -.side1 li a, .side2 li a{ - padding:8px 5px; - display:block; - border-bottom:1px solid #CDCDCD; - text-decoration:none; - color:#555; -} - -.side1 li a:hover, .side2 li a:hover{ - border-bottom:1px solid #888; - color:#222; - background:#f1f1f1; -} - -.side1{ - border-right:1px solid #ddd; -} - -.side1 h2, .side2 h2{ - color:#333; - font-size:16px; - padding:5px 0; -} - -.sbar_section #s{ - padding:4px; - border:1px solid #CDCDCD; - text-align:center; - font-family:Georgia, "Times New Roman", Times, serif; - color:#555; - width:185px; - background:#f1f1f1; -} - -.sbar_section #s:hover, .sbar_section #s:focus{ - border:1px solid #888; - background:#FFF; -} - -.peel{ - background:url(images/peel.gif); - width:102px; - height:129px; - overflow:hidden; - display:block; - position:absolute; - z-index:9999px; - right:0; - top:0; -} - -.wrap{ - padding-left:265px; - color:#333; - padding-right:25px; -} - -.wrap h1 a, .wrap h1{ - color:#59ba12; - font-size:20px; - font-family:Arial, Helvetica, sans-serif; - font-weight:bold; - text-decoration:none; -} - - -.wrap p{ - padding:15px 0px; - line-height:19px; -} - -.wrap img{ - padding:10px; -} - -.wrap ul{ - padding-left:20px; -} -.wrap li{ - padding:5px; -} - -.wrap ul p{ - padding:0; -} - -blockquote { - background:transparent url(images/blockquote.gif) no-repeat scroll left top; - line-height:18px; -} - - - - -.wrap h2 a, .wrap h2{ - color:#333333; - font-size:18px; - font-family:Arial, Helvetica, sans-serif; - font-weight:normal; -} - -.entry-meta{ - background:red; - display:block; - font-size:11px; - background:url(images/entrymeta.gif) repeat-x left bottom; - padding:12px; - border:1px solid #cfcfcf; - line-height:18px; -} - -.entry-meta a{ - text-decoration:none; - color:#4a9d0d; -} - -.entry-meta a:hover{ - color:#0066FF; -} - - - -.date{ - float:left; - background:red; - background:url(images/date.gif) no-repeat; - width:45px; - height:48px; - margin-top:-8px; - padding-top:2px; - font-size:16px; - color:#FFFFFF; - font-weight:bold; - padding-left:11px; - z-index:9999999999999px; -} - -.date div{ - color:#999999; - font-size:11px; - padding-top:8px; -} - -.posttop{ - border-bottom:2px solid #52af10; - padding-bottom:25px; - margin-bottom:8px; -} - -.posttop .feedback a{ - color:#666; - text-decoration:none; - float:right; - padding-top:5px; -} - -.footer{ - padding:15px; - background:#222; - clear:both; - text-align:center; - color:#999; - margin-top:25px; -} - -.footer a{ - color:#59ba12; - text-decoration:none; -} - -.commentlist li{ - list-style:none; -} - -#commentform p{ - padding:5px; -} - -#comment, #author, #email, #url{ - width:250px; - padding:3px; - font-family:Arial, Helvetica, sans-serif; - font-size:12px; - color:#333; - border:1px solid #AAA; -} - - -#comment:hover, #author:hover, #email:hover, #url:hover, #comment:focus, #author:focus, #email:focus, #url:focus{ - border:1px solid #333; -} - -#commentform label{ - color:#666666; -} - -#commentform #submit{ - padding:5px 15px; - border:none; - width:260px; - text-align:center; - background:#FFF url(images/entrymeta.gif) repeat-x left bottom; - color:#666; - border:1px solid #999; - cursor:pointer; -} - -.wrap ul.commentlist{ - padding:20px 0px; -} - -.commentlist li{ - padding:10px; - border-bottom:1px solid #AAA; -} - -.commentmetadata -{ - color:#999; - } - -.commentlist .commentmetadata a{ - color:#999; -} - -.commentlist li.alt{ - background:#F4F4F4; -} - -.storycontent a, #commentform a, .commentlist li a{ - color:#009900; - text-decoration:none; -} - -.accesskey -{ - text-decoration: underline; - }
− templates/project/src/App/Control.hs
@@ -1,21 +0,0 @@-{-# 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
@@ -1,66 +0,0 @@-module App.Logger (- LoggerHandle- , setupLogger- , teardownLogger- , withLogger-) where--import Control.Exception.Extensible (bracket)--import System.Log.Logger- ( Priority(..)- , rootLoggerName- , setLevel- , setHandlers- , updateGlobalLogger- )-import System.Log.Handler (close)-import System.Log.Handler.Simple (GenericHandler, fileHandler, streamHandler)-import System.IO (stdout, Handle)---- | Opaque type covering all information needed to teardown the logger.-data LoggerHandle = LoggerHandle { - rootLogHandler :: GenericHandler Handle- , accessLogHandler :: GenericHandler Handle- , serverLogHandler :: GenericHandler Handle- }---- | Install the loggers required by the application. -setupLogger :: IO LoggerHandle-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])- -- return opaque AppLogger handle- return $ LoggerHandle appLog accessLog stdoutLog---- | Tear down the application logger; i.e. close all associated log handlers.-teardownLogger :: LoggerHandle -> IO ()-teardownLogger handle = do- close $ serverLogHandler handle- close $ accessLogHandler handle- close $ rootLogHandler handle---- | Bracket an IO action which denotes the whole scope where the loggers of--- the application are needed to installed. Sets them up before running the action--- and tears them down afterwards. Even in case of an exception. -withLogger :: IO a -> IO a-withLogger = bracket setupLogger teardownLogger . const-- -
− templates/project/src/App/State.hs
@@ -1,27 +0,0 @@-{-# 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
@@ -1,102 +0,0 @@-{-# 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><label for="email"><span class="accesskey">E</span>mail</label><br /><input type="text" name="email" id="email" tabindex="3" accesskey="E" />- </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/GuestBook.hs
@@ -1,10 +0,0 @@-module GuestBook - ( module GuestBook.Control- , module GuestBook.State2- , module GuestBook.View- )- where--import GuestBook.Control-import GuestBook.State2-import GuestBook.View
− templates/project/src/GuestBook/Control.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}-{-# 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.State2 (GuestBookEntry(..),AddGuestBookEntry(..),ReadGuestBook(..))-import GuestBook.View-import Happstack.Server-import Happstack.Data(defaultValue)-import Happstack.State(query,update)-import HSP-import System.Time(getClockTime)-import Control.Monad--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- mbEntry <- getData -- get the data- case mbEntry of - Nothing -> error $ "error: postEntry" - Just entry -> do- 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" `mplus` (error "GuestBookEntry, need author")- message <- look "message" `mplus` (error "GuesBookEntry, need message")- email <- look "email" `mplus` (error "GuestBookEntry: need email")- return $ GuestBookEntry (if null author then "Anonymous" else author) message defaultValue email
− templates/project/src/GuestBook/State.hs
@@ -1,45 +0,0 @@-{-# 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/State2.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable,- FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,- UndecidableInstances- #-}-module GuestBook.State2 where-import Happstack.Data-import Happstack.State-import Control.Monad.Reader (ask)-import Control.Monad.State (modify)-import Happstack.State.ClockTime-import qualified GuestBook.State as Old--$(deriveAll [''Show, ''Eq, ''Ord, ''Default]- [d|- -- |GuestBookEntry: simple guest book entry- data GuestBookEntry = GuestBookEntry- { author :: String- , message :: String- , date :: ClockTime- , email :: String- }-- -- |GuestBook: a list of GuestBookEntry- newtype GuestBook = GuestBook { guestBookEntries :: [GuestBookEntry] }- |])--$(deriveSerialize ''GuestBookEntry)-instance Version GuestBookEntry--$(deriveSerialize ''GuestBook)---instance Version GuestBook-instance Version GuestBook where- mode = extension 2 (Proxy :: Proxy Old.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---instance Migrate Old.GuestBook GuestBook where- migrate (Old.GuestBook entries) = GuestBook $ map f entries-f (Old.GuestBookEntry author message date) = GuestBookEntry author message date "" -- --- create types for event serialization-$(mkMethods ''GuestBook ['readGuestBook, 'addGuestBookEntry])
− templates/project/src/GuestBook/View.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}-module GuestBook.View where--import GuestBook.State2 (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 email), alt) = - <%- <li class=(if alt then "alt" else "")>- <strong><% author ++ (displayemail email) %></strong> said:<br /><br />- <% map p (lines message) %>- <br />- <small class="commentmetadata"><% dateStr date %></small> - </li>- %>- where p str = <p><% str %></p>- displayemail "" = ""- displayemail x = "<" ++ x ++ ">"--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
@@ -1,193 +0,0 @@-module Main where--import Data.Version (showVersion)--import Control.Concurrent (MVar, forkIO, killThread)-import Control.Exception (bracket)--import System.Environment (getArgs)-import System.Log.Logger (Priority(..), logM)-import System.Exit (exitWith, ExitCode(..), exitFailure)-import System.Console.GetOpt --import Happstack.Util.Cron (cron)-import Happstack.State (waitForTermination)-import Happstack.Server- ( Conf(port)- , simpleHTTP- , nullConf- , validator- , wdgHTMLValidator- )-import Happstack.State- ( Component- , Proxy(..)- , Methods- , TxControl- , Saver(Queue, FileSaver)- , runTxSystem- , shutdownSystem- , createCheckpoint- )--import App.Logger (withLogger)-import App.State (AppState(..))-import App.Control (appHandler)---- NOTE: You need to change this file name such that it reflects the name of--- your project in the .cabal file, because it is auto-generated by cabal.-import Paths_guestbook (version)------------------------------------------------------------------------------------ Main Function---------------------------------------------------------------------------------main = withLogger $ do-- -- convert command line arguments into list of flags- flags <- parseConfig =<< getArgs-- -- display information like help or version, if required- displayInfo flags-- -- run server- runServer flags----- | Display information required by flags. Currently, this is either the help--- message or the version information.-displayInfo :: [Flag] -> IO ()-displayInfo flags- | any isHelp flags = putStr helpMessage >> exitWith ExitSuccess- | any isVersion flags = putStr versionInfo >> exitWith ExitSuccess- | otherwise = return ()------------------------------------------------------------------------------------ Command Line Interface Content----------------------------------------------------------------------------------- | Program name used to identify your application. --- It influences the version and help message, as well as the directory name--- for the state of your application.-progName = "guestbook-server"--fullName = "Happstack Guestbook Example"--copyrightInfo = "Copyright (C) 2009 <your-name-here>"-licenceInfo = "See the accompanying licence for copying conditions."---- | Version information extracted from Paths_guestbook-versionInfo = unlines- [ fullName ++ " (" ++ progName ++ "), version " ++ showVersion version- , copyrightInfo- , licenceInfo- ]---- | A simple usage message listing all flags possible.-helpMessage = usageInfo header opts- where - header = "Usage: "++progName++" [OPTION...]"------------------------------------------------------------------------------------ Server----------------------------------------------------------------------------------- | Configuration information-data AppConf- = AppConf { httpConf :: Conf- , store :: FilePath- , static :: FilePath - }---- | Default configuration--- FIXME: Should incorporate directories queried via Paths_guestbook module-defaultConf :: String -> AppConf-defaultConf progName- = AppConf { httpConf = nullConf- , store = "_local/" ++ progName ++ "_state"- , static = "public"- }---- | Run the server with the given configuration.-runServer :: [Flag] -> IO ()-runServer flags = do- -- combine all server config flags- let appConf = foldr ($) (defaultConf progName) [f | ServerConfig f <- flags] -- -- start the state system- withSystemState' (store appConf) stateProxy $ \control -> do- - -- start the http server- withThread (simpleHTTP (httpConf appConf) appHandler) $ do-- -- checkpoint the state once a day- withThread (cron (60*60*24) (createCheckpoint control)) $ do- - -- wait for termination signal- logM "Happstack.Server" NOTICE "System running, press 'e <ENTER>' or Ctrl-C to stop server" - waitForTermination-- where- startSystemState' :: (Component st, Methods st) => String -> Proxy st -> IO (MVar TxControl)- startSystemState' = runTxSystem . Queue . FileSaver-- withSystemState' :: (Component st, Methods st) => String -> Proxy st -> (MVar TxControl -> IO a) -> IO a- withSystemState' name proxy action = - bracket (startSystemState' name proxy) createCheckpointAndShutdown action-- withThread init action = bracket (forkIO $ init) (killThread) (\_ -> action)-- createCheckpointAndShutdown control = do- logM "Happstack.Server" NOTICE "Creating system checkpoint" - createCheckpoint control- logM "Happstack.Server" NOTICE "System shutdown" - shutdownSystem control-- -- simon.meier@inf.ethz.ch: I currently don't know what this is used for!- -- FIXME: Add sensible comment.- stateProxy :: Proxy AppState- stateProxy = Proxy------------------------------------------------------------------------------------ Command Line Parsing----------------------------------------------------------------------------------- | Flags-data Flag = - ServerConfig (AppConf -> AppConf)- | Help- | Version---- Flag selectors-isHelp flag = case flag of Help -> True; _ -> False-isVersion flag = case flag of Version -> True; _ -> False---- | Command line options.-opts :: [OptDescr Flag]-opts = [ Option [] ["http-port"] (ReqArg setPort "port") "Port to bind http server"- , Option [] ["no-validate"] (NoArg $ setValidator Nothing) "Turn off HTML validation"- , Option [] ["validate"] (NoArg $ setValidator (Just wdgHTMLValidator)) "Turn on HTML validation"- , Option [] ["store"] (ReqArg setMacidDir "PATH") "The directory used for database storage."- , Option [] ["static"] (ReqArg setStaticDir "PATH") "The directory searched for static files" - , Option [] ["version"] (NoArg Version) "Display version information" - , Option [] ["help"] (NoArg Help) "Display this help message" - ]- where- setPort p = ServerConfig $ \c -> c { httpConf = (httpConf c) {port = read p} }- setValidator v = ServerConfig $ \c -> c { httpConf = (httpConf c) {validator = v } }- setMacidDir p = ServerConfig $ \c -> c { store = p }- setStaticDir p = ServerConfig $ \c -> c { static = p }---- | Parse the command line arguments into a list of flags. Exits with usage--- message, in case of failure.-parseConfig :: [String] -> IO [Flag]-parseConfig args = case getOpt Permute opts args of- (flags,_,[]) -> return flags- (_,_,errs) -> do- logM progName ERROR ("Failure while parsing command line:\n"++unlines errs)- putStr helpMessage- exitFailure
− templates/project/templates/readme.st
@@ -1,6 +0,0 @@-This is a dynamic README file which uses HStringTemplate.--The time is $time$.--Thanks for reading!-