diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 --- a/CHANGELOG +++ /dev/null @@ -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) - diff --git a/CREDITS b/CREDITS deleted file mode 100644 --- a/CREDITS +++ /dev/null @@ -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 - -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 - - 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 - diff --git a/RELEASE_NOTES b/RELEASE_NOTES deleted file mode 100644 --- a/RELEASE_NOTES +++ /dev/null @@ -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\\Application Data\cabal\bin - where is your windows username. - - 3. Run this command: - happstack new project - where 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. - diff --git a/commands/happstack.hs b/commands/happstack.hs deleted file mode 100644 --- a/commands/happstack.hs +++ /dev/null @@ -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 " - 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 <- 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 - diff --git a/happstack.cabal b/happstack.cabal --- a/happstack.cabal +++ b/happstack.cabal @@ -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 diff --git a/src/HSP/Google/Analytics.hs b/src/HSP/Google/Analytics.hs deleted file mode 100644 --- a/src/HSP/Google/Analytics.hs +++ /dev/null @@ -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 tag --- See also: addAnalytics -analytics :: (XMLGenerator m) => UACCT -> GenXMLList m -analytics (UACCT uacct) = - do a <- - b <- - return [a,b] - --- | automatically add the google analytics scipt tags immediately before the 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 - <[ head, body ]> -> - - <% head %> - <% body <: a %> - - o -> error ("Failed to add analytics." ++ show o) - -{- Example Analytics Code from Google: - - - --} diff --git a/src/HSP/Identity.hs b/src/HSP/Identity.hs deleted file mode 100644 --- a/src/HSP/Identity.hs +++ /dev/null @@ -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 diff --git a/src/HSP/IdentityT.hs b/src/HSP/IdentityT.hs deleted file mode 100644 --- a/src/HSP/IdentityT.hs +++ /dev/null @@ -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 diff --git a/src/HSP/ServerPartT.hs b/src/HSP/ServerPartT.hs deleted file mode 100644 --- a/src/HSP/ServerPartT.hs +++ /dev/null @@ -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) diff --git a/src/HSP/WebT.hs b/src/HSP/WebT.hs deleted file mode 100644 --- a/src/HSP/WebT.hs +++ /dev/null @@ -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) diff --git a/src/Happstack/Server/HSP/HTML.hs b/src/Happstack/Server/HSP/HTML.hs deleted file mode 100644 --- a/src/Happstack/Server/HSP/HTML.hs +++ /dev/null @@ -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 $ ... --- 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) diff --git a/src/Happstack/Server/HSX.hs b/src/Happstack/Server/HSX.hs deleted file mode 100644 --- a/src/Happstack/Server/HSX.hs +++ /dev/null @@ -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 diff --git a/src/Happstack/Server/HStringTemplate.hs b/src/Happstack/Server/HStringTemplate.hs deleted file mode 100644 --- a/src/Happstack/Server/HStringTemplate.hs +++ /dev/null @@ -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 - diff --git a/src/Happstack/State/ClockTime.hs b/src/Happstack/State/ClockTime.hs deleted file mode 100644 --- a/src/Happstack/State/ClockTime.hs +++ /dev/null @@ -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]) diff --git a/templates/project/Setup.hs b/templates/project/Setup.hs deleted file mode 100644 --- a/templates/project/Setup.hs +++ /dev/null @@ -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] - } diff --git a/templates/project/bin/build.bat b/templates/project/bin/build.bat deleted file mode 100644 --- a/templates/project/bin/build.bat +++ /dev/null @@ -1,1 +0,0 @@ -ghc -isrc src\Main.hs --make -o app diff --git a/templates/project/bin/build.sh b/templates/project/bin/build.sh deleted file mode 100644 --- a/templates/project/bin/build.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -ghc -isrc src/Main.hs --make -o app diff --git a/templates/project/bin/run-interactive.bat b/templates/project/bin/run-interactive.bat deleted file mode 100644 --- a/templates/project/bin/run-interactive.bat +++ /dev/null @@ -1,1 +0,0 @@ -ghci -isrc -isrc-interactive-only src\Main.hs diff --git a/templates/project/bin/run-interactive.sh b/templates/project/bin/run-interactive.sh deleted file mode 100644 --- a/templates/project/bin/run-interactive.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -ghci -isrc -isrc-interactive-only src/Main.hs diff --git a/templates/project/bin/run.bat b/templates/project/bin/run.bat deleted file mode 100644 --- a/templates/project/bin/run.bat +++ /dev/null @@ -1,1 +0,0 @@ -runghc -isrc src\Main.hs diff --git a/templates/project/bin/run.sh b/templates/project/bin/run.sh deleted file mode 100644 --- a/templates/project/bin/run.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -runghc -isrc src/Main.hs diff --git a/templates/project/guestbook.cabal b/templates/project/guestbook.cabal deleted file mode 100644 --- a/templates/project/guestbook.cabal +++ /dev/null @@ -1,41 +0,0 @@ -Name: guestbook -Version: 1.0 -Author: Jeremy Shaw , Matthew Elder -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 diff --git a/templates/project/public/theme/images/blockquote.gif b/templates/project/public/theme/images/blockquote.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/blockquote.gif and /dev/null differ diff --git a/templates/project/public/theme/images/date.gif b/templates/project/public/theme/images/date.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/date.gif and /dev/null differ diff --git a/templates/project/public/theme/images/entrymeta.gif b/templates/project/public/theme/images/entrymeta.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/entrymeta.gif and /dev/null differ diff --git a/templates/project/public/theme/images/grunge.gif b/templates/project/public/theme/images/grunge.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/grunge.gif and /dev/null differ diff --git a/templates/project/public/theme/images/header_loop.gif b/templates/project/public/theme/images/header_loop.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/header_loop.gif and /dev/null differ diff --git a/templates/project/public/theme/images/logo.gif b/templates/project/public/theme/images/logo.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/logo.gif and /dev/null differ diff --git a/templates/project/public/theme/images/menu_hili.gif b/templates/project/public/theme/images/menu_hili.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/menu_hili.gif and /dev/null differ diff --git a/templates/project/public/theme/images/menu_hover.gif b/templates/project/public/theme/images/menu_hover.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/menu_hover.gif and /dev/null differ diff --git a/templates/project/public/theme/images/peel.gif b/templates/project/public/theme/images/peel.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/peel.gif and /dev/null differ diff --git a/templates/project/public/theme/images/ql_rss.gif b/templates/project/public/theme/images/ql_rss.gif deleted file mode 100644 Binary files a/templates/project/public/theme/images/ql_rss.gif and /dev/null differ diff --git a/templates/project/public/theme/readme.txt b/templates/project/public/theme/readme.txt deleted file mode 100644 --- a/templates/project/public/theme/readme.txt +++ /dev/null @@ -1,1 +0,0 @@ -Theme by Dezinerfolio.com diff --git a/templates/project/public/theme/style.css b/templates/project/public/theme/style.css deleted file mode 100644 --- a/templates/project/public/theme/style.css +++ /dev/null @@ -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; - } diff --git a/templates/project/src/App/Control.hs b/templates/project/src/App/Control.hs deleted file mode 100644 --- a/templates/project/src/App/Control.hs +++ /dev/null @@ -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 diff --git a/templates/project/src/App/Logger.hs b/templates/project/src/App/Logger.hs deleted file mode 100644 --- a/templates/project/src/App/Logger.hs +++ /dev/null @@ -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 - - - diff --git a/templates/project/src/App/State.hs b/templates/project/src/App/State.hs deleted file mode 100644 --- a/templates/project/src/App/State.hs +++ /dev/null @@ -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 []) diff --git a/templates/project/src/App/View.hs b/templates/project/src/App/View.hs deleted file mode 100644 --- a/templates/project/src/App/View.hs +++ /dev/null @@ -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 $ - - - <% 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/GuestBook.hs b/templates/project/src/GuestBook.hs deleted file mode 100644 --- a/templates/project/src/GuestBook.hs +++ /dev/null @@ -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 diff --git a/templates/project/src/GuestBook/Control.hs b/templates/project/src/GuestBook/Control.hs deleted file mode 100644 --- a/templates/project/src/GuestBook/Control.hs +++ /dev/null @@ -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 $
<% 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" `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 diff --git a/templates/project/src/GuestBook/State.hs b/templates/project/src/GuestBook/State.hs deleted file mode 100644 --- a/templates/project/src/GuestBook/State.hs +++ /dev/null @@ -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]) diff --git a/templates/project/src/GuestBook/State2.hs b/templates/project/src/GuestBook/State2.hs deleted file mode 100644 --- a/templates/project/src/GuestBook/State2.hs +++ /dev/null @@ -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]) diff --git a/templates/project/src/GuestBook/View.hs b/templates/project/src/GuestBook/View.hs deleted file mode 100644 --- a/templates/project/src/GuestBook/View.hs +++ /dev/null @@ -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) = - <% -
  • - <% author ++ (displayemail email) %> said:

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

    <% str %>

    - displayemail "" = "" - displayemail x = "<" ++ x ++ ">" - -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 deleted file mode 100644 --- a/templates/project/src/Main.hs +++ /dev/null @@ -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 " -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 ' 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 diff --git a/templates/project/templates/readme.st b/templates/project/templates/readme.st deleted file mode 100644 --- a/templates/project/templates/readme.st +++ /dev/null @@ -1,6 +0,0 @@ -This is a dynamic README file which uses HStringTemplate. - -The time is $time$. - -Thanks for reading! -