happstack 0.5.0.3 → 6.0.0

raw patch · 32 files changed

+423/−1063 lines, 32 filesdep −bytestringdep −harpdep −hsloggerdep ~HStringTemplatedep ~happstack-datadep ~happstack-ixsetPVP ok

version bump matches the API change (PVP)

Dependencies removed: bytestring, harp, hslogger, hsp, hsx, mtl, text, utf8-string

Dependency ranges changed: HStringTemplate, happstack-data, happstack-ixset, happstack-server, happstack-state, happstack-util

API changes (from Hackage documentation)

Files

• commands/happstack.hs +7/−2
• happstack.cabal +26/−37
• src/HSP/Google/Analytics.hs +0/−62
• src/HSP/Identity.hs +0/−100
• src/HSP/IdentityT.hs +0/−125
• src/HSP/ServerPartT.hs +0/−102
• src/HSP/WebT.hs +0/−102
• src/Happstack/Server/HSP/HTML.hs +0/−46
• src/Happstack/Server/HSX.hs +0/−18
• src/Happstack/Server/HStringTemplate.hs +0/−39
• templates/project/guestbook.cabal +18/−1
• templates/project/src/App/Control.hs +0/−21
• templates/project/src/App/Logger.hs +0/−66
• templates/project/src/App/State.hs +0/−27
• templates/project/src/App/View.hs +0/−102
• templates/project/src/GuestBook.hs +0/−10
• templates/project/src/GuestBook/Control.hs +0/−46
• templates/project/src/GuestBook/State.hs +0/−45
• templates/project/src/GuestBook/State2.hs +0/−59
• templates/project/src/GuestBook/View.hs +0/−49
• templates/project/src/Logger.hs +66/−0
• templates/project/src/Main.hs +4/−4
• templates/project/src/Pages.hs +9/−0
• templates/project/src/Pages/AppTemplate.hs +95/−0
• templates/project/src/Pages/Common.hs +11/−0
• templates/project/src/Pages/GuestBookEntries.hs +42/−0
• templates/project/src/Pages/PostEntry.hs +23/−0
• templates/project/src/Pages/Readme.hs +14/−0
• templates/project/src/Routes.hs +23/−0
• templates/project/src/State.hs +28/−0
• templates/project/src/State/GuestBook.hs +30/−0
• templates/project/src/Types/GuestBook.hs +27/−0

@@ -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]

@@ -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

@@ -1,62 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts -F -pgmFtrhsx #-}-module HSP.Google.Analytics -    ( UACCT(..)-    , analytics-    , addAnalytics-    ) where--import Data.Generics (Data, Typeable)-import HSP-import Prelude hiding (head)--newtype UACCT = UACCT String -- ^ The UACCT provided to you by Google-    deriving (Read, Show, Eq, Ord, Typeable, Data)---- | create the google analytics script tags--- NOTE: you must put the <% analytics yourUACCT %> immediately before the </body> tag--- See also: addAnalytics-analytics :: (XMLGenerator m) => UACCT -> GenXMLList m-analytics (UACCT uacct) =-    do a <- <script type="text/javascript">-              var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");-              document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));-            </script>-       b <- <script type="text/javascript">-              var pageTracker = _gat._getTracker("<% uacct %>");-              pageTracker._initData();-              pageTracker._trackPageview();-            </script>-       return [a,b]---- | automatically add the google analytics scipt tags immediately before the </body> element--- NOTE: this function is not idepotent-addAnalytics :: ( AppendChild m XML-                , EmbedAsChild m XML-                , EmbedAsAttr m Attribute-                , XMLGenerator m) -             => UACCT -             -> XMLGenT m XML -             -> GenXML m-addAnalytics uacct pg =-    do page <- pg-       a <- analytics uacct-       case page of-         <html hattrs><[ head, body ]></html> ->-             <html hattrs>-                <% head %>-                <% body <: a %>-             </html>-         o -> error ("Failed to add analytics." ++ show o)--{- Example Analytics Code from Google:--<script type="text/javascript">-var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");-document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));-</script>-<script type="text/javascript">-var pageTracker = _gat._getTracker("UA-4353757-1");-pageTracker._initData();-pageTracker._trackPageview();-</script>--}

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -1,46 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Happstack.Server.HSP.HTML-  ( webHSP-  , webHSP'-  ) where--import Control.Monad.Trans (MonadIO(), liftIO)-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Lazy.UTF8 as L-import Control.Monad (liftM)-import Happstack.Server-  ( ToMessage(toMessage, toContentType, toResponse)-  , Response()-  )-import HSP-  ( HSP()-  , XML()-  , XMLMetaData(XMLMetaData, contentType)-  , evalHSP-  , html4Strict-  , renderAsHTML-  )--instance ToMessage XML where-    toContentType _ = P.pack "text/html;charset=utf-8"-    toMessage xml   = toMessage (html4Strict, xml)--instance ToMessage (Maybe XMLMetaData, XML) where-    toContentType (Just md,_) = P.pack (contentType md)-    toContentType _ = P.pack "text/html;charset=utf-8"-    toMessage (Just (XMLMetaData (showDt, dt) _ pr), xml) = -        L.fromString ((if showDt then (dt ++) else id) (pr xml))-    toMessage (Nothing, xml) =-        L.fromString (renderAsHTML xml)---- | Converts a @HSP XML@ to a Happstack Response.--- Since @HSP XML@ is the type returned by using literal HTML syntax--- with HSP, you can wrap up your HTML as webHSP $ <html>...</html>--- to use it with Happstack.-webHSP :: (MonadIO m) => HSP XML -> m Response-webHSP = webHSP' Nothing---- | webHSP with XMLMetaData-webHSP' :: (MonadIO m) => Maybe XMLMetaData -> HSP XML -> m Response-webHSP' metadata hsp = toResponse `liftM` liftIO (evalHSP metadata hsp)

@@ -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

@@ -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-

@@ -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

@@ -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

@@ -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--  -  

@@ -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 [])

@@ -1,102 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}-module App.View where--import HSP-import System.Locale (defaultTimeLocale)-import System.Time (ClockTime(..), formatCalendarTime, toUTCTime)-import Control.Monad.Trans (MonadIO)-import Happstack.Server (Response)-import Happstack.Server.HStringTemplate (webST)-import Happstack.Server.HSP.HTML (webHSP)---- * Convenience Functions--dateStr :: ClockTime -> String-dateStr ct =-  formatCalendarTime-    defaultTimeLocale-    "%a, %B %d, %Y at %H:%M:%S (UTC)"-    (toUTCTime ct)---- * Main Implementation--renderFromBody :: (MonadIO m, EmbedAsChild (HSPT' IO) xml) => String -> xml -> m Response-renderFromBody title = webHSP . pageFromBody title--pageFromBody :: (EmbedAsChild (HSPT' IO) xml) => String -> xml -> HSP XML-pageFromBody title body =-    withMetaData html4Strict $-    <html>-     <head>-      <title><% title %></title>-      <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />-      <link rel="stylesheet" type="text/css" href="/theme/style.css" media="screen" />-     </head>-     <body>-      <div id="header">-       <div class="grunge"></div>-       <div class="peel"></div>-       <div class="topnavi">-        <ul>-         <li class="current_page_item"><a href="/" title="Guestbook">Guestbook</a></li>-        </ul>-       </div>-      </div>--      <div class="side1">-       <div class="sbar_section">-        <h2>Links</h2>-         <ul>-      	  <li class="cat-item cat-item-1"><a href="http://happstack.com/" title="happstack" accesskey="H"><span class="accesskey">H</span>appstack</a></li>-      	  <li class="cat-item cat-item-2"><a href="http://happstack.com/tutorials.html" title="happstack" accesskey="T"><span class="accesskey">T</span>utorials</a></li>-         </ul>-       </div>-      </div>--      <div class="wrap">-       <div class="innercont_main">--        <div class="post">-         <div class="posttop">-          <div class="date">14<div>Feb</div></div>-          <h1 class="posttitle">Happstack Guestbook</h1>-          <div class="storycontent">-           <p>-              Hey congrats! You're using-              <a href="http://happstack.com">Happstack</a> 0.3.-              This is a guestbook example which you can freely change to your-              whims and fancies.-            </p>-            <p>-              This page is written using Haskell Server Pages (HSP). For an example-              of a page using HStringTemplate, look at the-              <a href="/README">dynamic README</a>.-            </p>-           <p>Leave a message for the next visitor here...</p>-           <form action="/entries" method="post" enctype="multipart/form-data;charset=UTF-8" accept-charset="UTF-8">-            <p><label for="author">A<span class="accesskey">u</span>thor</label><br /><input type="text" name="author" id="author" tabindex="1" accesskey="U" />-            </p>-            <p><label for="message"><span class="accesskey">M</span>essage</label><br /><textarea cols="80" rows="10" name="message" id="message" tabindex="2" accesskey="M"></textarea></p>-            <p><label for="email"><span class="accesskey">E</span>mail</label><br /><input type="text" name="email" id="email" tabindex="3" accesskey="E" />-            </p>-            <p><input type="submit" tabindex="3" accesskey="L" value="Leave GuestBook Entry" /></p>-           </form>-          </div>-         </div>-        </div>--        <% body %>-       </div>-      </div>-           -      <div class="footer">-        <div class="finalfooter">Theme : <a href="http://www.dezinerfolio.com/2007/10/10/just-another-wodpress-theme" title="sIMPRESS v2 theme">sIMPRESS v2</a> by <a href="http://dezinerfolio.com" title="Dezinerfolio">Dezinerfolio</a></div>-      </div>--     </body>-    </html>--renderREADME :: (MonadIO m) => ClockTime -> m Response-renderREADME now = webST "readme" [("time", dateStr now)]-

@@ -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

@@ -1,46 +0,0 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}-module GuestBook.Control where--import Control.Applicative((<$>))-import Control.Monad(msum)-import Control.Monad.Trans(liftIO)-import Data.ByteString.Lazy.UTF8 (toString)-import GuestBook.State2 (GuestBookEntry(..),AddGuestBookEntry(..),ReadGuestBook(..))-import GuestBook.View-import Happstack.Server-import Happstack.Data(defaultValue)-import Happstack.State(query,update)-import HSP-import System.Time(getClockTime)-import Control.Monad--guestBookHandler :: ServerPartT IO (HSP XML)-guestBookHandler =-  dir "entries" $ msum [postEntry, getEntries]        -- RESTful /entries--postEntry :: ServerPartT IO (HSP XML)-postEntry = methodM POST >> do -- only accept a post method-  mbEntry <- getData -- get the data-  case mbEntry of -    Nothing -> error $ "error: postEntry" -    Just entry -> do-      now <- liftIO getClockTime-      update $ AddGuestBookEntry entry{date=now}-      seeOther "/entries" (seeOtherXML "/entries")---- |show all the entries in the guestbook--- argument is a callback function -getEntries :: ServerPartT IO (HSP XML)-getEntries = -    methodM GET >> -                do gb  <- query ReadGuestBook-                   ok $ <div><% gb %></div> -- FIXME: remove <div />---- this tells happstack how to turn post data into a datatype using 'withData'-instance FromData GuestBookEntry where-  fromData = do-    author  <- look "author" `mplus` (error "GuestBookEntry, need author")-    message <- look "message" `mplus` (error "GuesBookEntry, need message")-    email   <- look "email" `mplus` (error "GuestBookEntry: need email")-    return $ GuestBookEntry (if null author then "Anonymous" else author) message defaultValue email

@@ -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])

@@ -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])

@@ -1,49 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}-module GuestBook.View where--import GuestBook.State2 (GuestBook(..),GuestBookEntry(..))-import HSP-import qualified HSX.XMLGenerator as HSX (XML)-import System.Locale (defaultTimeLocale)-import System.Time(ClockTime(..), formatCalendarTime, toUTCTime)---- * Convenience Functions--dateStr :: ClockTime -> String-dateStr ct =-  formatCalendarTime-    defaultTimeLocale-    "%a, %B %d, %Y at %H:%M:%S (UTC)"-    (toUTCTime ct)---- * Main Implementation--instance (XMLGenerator m) => (EmbedAsChild m (GuestBookEntry, Bool)) where-    asChild ((GuestBookEntry author message date email), alt) = -        <%-           <li class=(if alt then "alt" else "")>-            <strong><% author ++ (displayemail email)  %></strong> said:<br /><br />-            <% map p (lines message) %>-            <br />-            <small class="commentmetadata"><% dateStr date %></small> -           </li>-         %>-        where p str = <p><% str %></p>-              displayemail "" = ""-              displayemail x = "<" ++ x ++ ">"--instance (XMLGenerator m) => (EmbedAsChild m GuestBook) where-    asChild (GuestBook entries) = -        <% -         <div>-          <h2 id="comments" class="h2comment">Words of Wisdom</h2>-          <div class="clear" />-          <ul class="commentlist">-           <% zip entries (cycle [False,True]) %>-          </ul>-         </div>-        %>--seeOtherXML :: (XMLGenerator m) => String -> XMLGenT m (HSX.XML m)-seeOtherXML url = <a href=url alt="303 see other"><% url %></a>

@@ -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++  +  

@@ -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

@@ -0,0 +1,9 @@+module Pages +    ( guestBookEntriesPage+    , postEntryPage+    , readmePage +    ) where++import Pages.Readme+import Pages.GuestBookEntries+import Pages.PostEntry

@@ -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 =+    <html>+     <head>+      <title><% title %></title>+      <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />+      <link rel="stylesheet" type="text/css" href="/theme/style.css" media="screen" />+      <% headers %>+     </head>+     <body>+      <div id="header">+       <div class="grunge"></div>+       <div class="peel"></div>+       <div class="topnavi">+        <ul>+         <li class="current_page_item"><a href="/" title="Guestbook">Guestbook</a></li>+        </ul>+       </div>+      </div>++      <div class="side1">+       <div class="sbar_section">+        <h2>Links</h2>+         <ul>+      	  <li class="cat-item cat-item-1"><a href="http://happstack.com/" title="happstack" accesskey="H"><span class="accesskey">H</span>appstack</a></li>+      	  <li class="cat-item cat-item-2"><a href="http://happstack.com/docs" title="happstack" accesskey="T"><span class="accesskey">T</span>utorials</a></li>+         </ul>+       </div>+      </div>++      <div class="wrap">+       <div class="innercont_main">++        <div class="post">+         <div class="posttop">+          <div class="date">14<div>Feb</div></div>+          <h1 class="posttitle">Happstack Guestbook</h1>+          <div class="storycontent">+           <p>+              Hey congrats! You're using+              <a href="http://happstack.com">Happstack</a>.+              This is a guestbook example which you can freely change to your+              whims and fancies.+            </p>+            <p>+              This page is written using Haskell Server Pages (HSP). For an example+              of a page using HStringTemplate, look at the+              <a href="/README">dynamic README</a>.+            </p>+           <p>Leave a message for the next visitor here...</p>+           <form action="/guestbook" method="post" enctype="multipart/form-data;charset=UTF-8" accept-charset="UTF-8">+            <p><label for="author">A<span class="accesskey">u</span>thor</label><br /><input type="text" name="author" id="author" tabindex="1" accesskey="U" />+            </p>+            <p><label for="message"><span class="accesskey">M</span>essage</label><br /><textarea cols="80" rows="10" name="message" id="message" tabindex="2" accesskey="M"></textarea></p>+            <p><label for="email"><span class="accesskey">E</span>mail</label><br /><input type="text" name="email" id="email" tabindex="3" accesskey="E" />+            </p>+            <p><input type="submit" tabindex="3" accesskey="L" value="Leave GuestBook Entry" /></p>+           </form>+          </div>+         </div>+        </div>++        <% body %>+       </div>+      </div>+           +      <div class="footer">+        <div class="finalfooter">Theme : <a href="http://www.dezinerfolio.com/2007/10/10/just-another-wodpress-theme" title="sIMPRESS v2 theme">sIMPRESS v2</a> by <a href="http://dezinerfolio.com" title="Dezinerfolio">Dezinerfolio</a></div>+      </div>++     </body>+    </html>++

@@ -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)

@@ -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) =+    <div>+     <h2 id="comments" class="h2comment">Words of Wisdom</h2>+     <div class="clear" />+     <ul class="commentlist">+      <% mapM guestBookEntryXML $ zip entries (cycle [False,True]) %>+     </ul>+    </div>++guestBookEntryXML :: (GuestBookEntry, Bool) -> XMLGenT (ServerPartT IO) XML+guestBookEntryXML ((GuestBookEntry author message date email), alt) =+           <li class=(if alt then "alt" else "")>+            <strong><% author ++ (displayemail email)  %></strong> said:<br /><br />+            <% map p (lines message) %>+            <br />+            <small class="commentmetadata"><% dateStr date %></small> +           </li>+        where p str = <p><% str %></p>+              displayemail "" = ""+              displayemail x = "<" ++ x ++ ">"++

@@ -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")

@@ -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)]

@@ -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+         ]

@@ -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 [])

@@ -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])

@@ -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+