diff --git a/commands/happstack.hs b/commands/happstack.hs --- a/commands/happstack.hs +++ b/commands/happstack.hs @@ -45,25 +45,30 @@ newProject :: FilePath -> IO () newProject destDir' = do dataDir <- liftM ( "templates" "project") getDataDir - destDir <- canonicalizePath destDir' +-- destDir <- canonicalizePath destDir' -- this won't work because the directory does not exist yet + let destDir = 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 + + return () where createDir = createDirectoryIfMissing True -- only source dirs getSourceDirs :: FilePath -> IO [FilePath] -getSourceDirs dataDir = filterM doesDirectoryExist =<< getSourceData dataDir +getSourceDirs dataDir = filterM doesDirectoryExist =<< getSourceData dataDir -- only source files getSourceFiles :: FilePath -> IO [FilePath] 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: 6.0.0 Synopsis: The haskell application server stack + code generation Description: The haskell application server stack License: BSD3 @@ -22,17 +22,19 @@ 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/src/Pages/PostEntry.hs + templates/project/src/Pages/AppTemplate.hs + templates/project/src/Pages/Readme.hs + templates/project/src/Pages/Common.hs + templates/project/src/Pages/GuestBookEntries.hs + templates/project/src/State/GuestBook.hs + templates/project/src/Types/GuestBook.hs + templates/project/src/State.hs + templates/project/src/Main.hs + templates/project/src/Routes.hs + templates/project/src/Pages.hs + templates/project/src/Logger.hs templates/project/public/theme/images/menu_hover.gif templates/project/public/theme/images/grunge.gif templates/project/public/theme/images/entrymeta.gif @@ -49,7 +51,7 @@ source-repository head type: darcs subdir: happstack - location: http://patch-tag.com/r/mae/happstack/pullrepo + location: http://patch-tag.com/r/mae/happstack Flag base4 Description: Choose the even newer, even smaller, split-up base package. @@ -59,35 +61,19 @@ 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 + exposed-modules: Happstack.State.ClockTime 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 + happstack-data >= 6.0 && < 6.1, + happstack-ixset >= 6.0 && < 6.1, + happstack-server >= 6.0 && < 6.1, + happstack-state >= 6.0 && < 6.1, + happstack-util >= 6.0 && < 6.1, + old-time + if flag(base4) Build-Depends: base >= 4 && < 5, syb @@ -99,7 +85,10 @@ if flag(tests) hs-source-dirs: tests - ghc-options: -Wall + if impl(ghc >= 6.12) + ghc-options: -Wall -fno-warn-unused-do-bind + else + ghc-options: -Wall Executable happstack ghc-options: -threaded 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/templates/project/guestbook.cabal b/templates/project/guestbook.cabal --- a/templates/project/guestbook.cabal +++ b/templates/project/guestbook.cabal @@ -32,7 +32,24 @@ 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 + Build-depends: extensible-exceptions, + happstack, + happstack-data, + happstack-hsp, + happstack-hstringtemplate, + happstack-server, + happstack-state, + happstack-util, + hsp, + hsx, + hslogger, + mtl, + old-time, + old-locale, + utf8-string + + + if !os(windows) -- Cabal has a bug on windows and cannot find trhsx Build-Tools: trhsx 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/Logger.hs b/templates/project/src/Logger.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/Logger.hs @@ -0,0 +1,66 @@ +module 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/Main.hs b/templates/project/src/Main.hs --- a/templates/project/src/Main.hs +++ b/templates/project/src/Main.hs @@ -30,9 +30,9 @@ , createCheckpoint ) -import App.Logger (withLogger) -import App.State (AppState(..)) -import App.Control (appHandler) +import Logger (withLogger) +import Routes (routes) +import State (AppState) -- 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. @@ -121,7 +121,7 @@ withSystemState' (store appConf) stateProxy $ \control -> do -- start the http server - withThread (simpleHTTP (httpConf appConf) appHandler) $ do + withThread (simpleHTTP (httpConf appConf) routes) $ do -- checkpoint the state once a day withThread (cron (60*60*24) (createCheckpoint control)) $ do diff --git a/templates/project/src/Pages.hs b/templates/project/src/Pages.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/Pages.hs @@ -0,0 +1,9 @@ +module Pages + ( guestBookEntriesPage + , postEntryPage + , readmePage + ) where + +import Pages.Readme +import Pages.GuestBookEntries +import Pages.PostEntry diff --git a/templates/project/src/Pages/AppTemplate.hs b/templates/project/src/Pages/AppTemplate.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/Pages/AppTemplate.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Pages.AppTemplate where + +import Control.Applicative ((<$>)) +import HSP +import Happstack.Server (ServerPart, ServerPartT, Response, toResponse) +import HSP.ServerPartT () -- instance XMLGenerator (ServerPartT m) +import Happstack.Server.HSP.HTML () + +appTemplate :: + ( EmbedAsChild (ServerPartT IO) headers + , EmbedAsChild (ServerPartT IO) body + ) => + String -> headers -> body -> ServerPart Response +appTemplate title headers body = toResponse <$> (unXMLGenT (appTemplate' title headers body)) + +appTemplate' :: + ( EmbedAsChild (ServerPartT IO) headers + , EmbedAsChild (ServerPartT IO) body + ) => + String -> headers -> body -> XMLGenT (ServerPartT IO) XML +appTemplate' title headers body = + + + <% title %> + + + <% headers %> + + + + +
    +
    +

    Links

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

    Happstack Guestbook

    +
    +

    + Hey congrats! You're using + Happstack. + 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
    +
    + + + + + diff --git a/templates/project/src/Pages/Common.hs b/templates/project/src/Pages/Common.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/Pages/Common.hs @@ -0,0 +1,11 @@ +module Pages.Common (dateStr) where + +import System.Locale (defaultTimeLocale) +import System.Time (ClockTime(..), formatCalendarTime, toUTCTime) + +dateStr :: ClockTime -> String +dateStr ct = + formatCalendarTime + defaultTimeLocale + "%a, %B %d, %Y at %H:%M:%S (UTC)" + (toUTCTime ct) diff --git a/templates/project/src/Pages/GuestBookEntries.hs b/templates/project/src/Pages/GuestBookEntries.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/Pages/GuestBookEntries.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Pages.GuestBookEntries + ( guestBookEntriesPage + ) where + +import HSP +import Happstack.Server (Method(GET), Response, ServerPart, ServerPartT, methodM) +import Happstack.State (query) +import Pages.AppTemplate (appTemplate) +import Pages.Common (dateStr) +import State.GuestBook (ReadGuestBook(..)) +import Types.GuestBook (GuestBook(..), GuestBookEntry(..)) + +guestBookEntriesPage :: ServerPart Response +guestBookEntriesPage = + do methodM GET + gb <- query ReadGuestBook + appTemplate "Guestbook Entries" () (guestBookXML gb) + +guestBookXML :: GuestBook -> XMLGenT (ServerPartT IO) XML +guestBookXML (GuestBook entries) = +
    +

    Words of Wisdom

    +
    +
      + <% mapM guestBookEntryXML $ zip entries (cycle [False,True]) %> +
    +
    + +guestBookEntryXML :: (GuestBookEntry, Bool) -> XMLGenT (ServerPartT IO) XML +guestBookEntryXML ((GuestBookEntry author message date email), alt) = +
  • + <% author ++ (displayemail email) %> said:

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

    <% str %>

    + displayemail "" = "" + displayemail x = "<" ++ x ++ ">" + + diff --git a/templates/project/src/Pages/PostEntry.hs b/templates/project/src/Pages/PostEntry.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/Pages/PostEntry.hs @@ -0,0 +1,23 @@ +module Pages.PostEntry (postEntryPage) where + +import Control.Monad.Trans (liftIO) +import Happstack.Server (Method(POST), ServerPart, Response, look, methodM, seeOther, toResponse) +import Happstack.State (update) +import State.GuestBook (AddGuestBookEntry(..)) +import System.Time (getClockTime) +import Types.GuestBook (GuestBookEntry(..)) + +postEntryPage :: ServerPart Response +postEntryPage = + do methodM POST -- only accept a post method + author <- look "author" -- `mplus` (error "GuestBookEntry, need author") + message <- look "message" -- `mplus` (error "GuesBookEntry, need message") + email <- look "email" -- `mplus` (error "GuestBookEntry: need email") + now <- liftIO getClockTime + let entry = GuestBookEntry { author = (if null author then "Anonymous" else author) + , message = message + , date = now + , email = email + } + update $ AddGuestBookEntry entry + seeOther "/guestbook" (toResponse "/guestbook") diff --git a/templates/project/src/Pages/Readme.hs b/templates/project/src/Pages/Readme.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/Pages/Readme.hs @@ -0,0 +1,14 @@ +-- | demonstration of using HStringTemplate to render a page +module Pages.Readme (readmePage) where + +import Control.Monad.Trans (liftIO) +import Happstack.Server (Method(GET), Response, ServerPart, methodM) +import Happstack.Server.HStringTemplate (webST) +import Pages.Common (dateStr) +import System.Time (getClockTime) + +readmePage :: ServerPart Response +readmePage = + do methodM GET + now <- liftIO getClockTime + webST "readme" [("time", dateStr now)] diff --git a/templates/project/src/Routes.hs b/templates/project/src/Routes.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/Routes.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +module Routes (routes) where + +import Control.Monad (msum) +import Happstack.Server ( Browsing(EnableBrowsing), Method(GET), Response, ServerPart + , decodeBody, defaultBodyPolicy, dir, methodM, serveDirectory + , seeOther, toResponse) +import Pages (guestBookEntriesPage, postEntryPage, readmePage) + +routes :: ServerPart Response +routes = + do decodeBody (defaultBodyPolicy "/tmp/" 4096 4096 4096) -- decode the request body if present. + msum [ methodM GET >> seeOther "/guestbook" (toResponse ()) -- redirect / to /guestbook + , dir "guestbook" $ guestBookRoutes -- HSP pages + , dir "README" $ readmePage -- HStringTemplate example + , serveDirectory EnableBrowsing ["index.html"] "public" -- static file serving + ] + +guestBookRoutes :: ServerPart Response +guestBookRoutes = + msum [ guestBookEntriesPage + , postEntryPage + ] diff --git a/templates/project/src/State.hs b/templates/project/src/State.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/State.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable, + FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, + UndecidableInstances, TypeOperators + #-} +module State where + +import Happstack.Data (Default, Version(..), deriveSerialize, defaultValue, deriveAll) +import Happstack.State ((:+:), Component(..), Dependencies, End, mkMethods) +import State.GuestBook (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/State/GuestBook.hs b/templates/project/src/State/GuestBook.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/State/GuestBook.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable, + FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, + UndecidableInstances + #-} +module State.GuestBook + ( GuestBook(..) + , ReadGuestBook(..) + , AddGuestBookEntry(..) + ) where + +import Happstack.State (Component(..), Dependencies, End, Query, Update, mkMethods) +import Control.Monad.Reader (ask) +import Control.Monad.State (modify) +import Types.GuestBook (GuestBook(..), GuestBookEntry(..)) + +-- | 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 = GuestBook [] + +-- create types for event serialization +$(mkMethods ''GuestBook ['readGuestBook, 'addGuestBookEntry]) diff --git a/templates/project/src/Types/GuestBook.hs b/templates/project/src/Types/GuestBook.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/Types/GuestBook.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-} +module Types.GuestBook where + +import Happstack.Data (Default, Version, deriveAll, deriveSerialize) +import System.Time (ClockTime) +import Happstack.State.ClockTime () -- instance Data ClockTime + +$(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 +