packages feed

happstack 0.4.1 → 0.5.0

raw patch · 14 files changed

+771/−84 lines, 14 filesdep +harpdep +textdep ~happstack-datadep ~happstack-ixsetdep ~happstack-server

Dependencies added: harp, text

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

Files

happstack.cabal view
@@ -1,5 +1,5 @@ Name:                happstack-Version:             0.4.1+Version:             0.5.0 Synopsis:            The haskell application server stack + code generation Description:         The haskell application server stack License:             BSD3@@ -31,6 +31,7 @@                      templates/project/src/GuestBook/Control.hs                      templates/project/src/GuestBook/View.hs                      templates/project/src/GuestBook/State.hs+                     templates/project/src/GuestBook/State2.hs                      templates/project/guestbook.cabal                      templates/project/public/theme/images/menu_hover.gif                      templates/project/public/theme/images/grunge.gif@@ -62,30 +63,37 @@                        Happstack.Server.HSX                        Happstack.Server.HStringTemplate                        Happstack.State.ClockTime+                       HSP.Identity+                       HSP.IdentityT+                       HSP.ServerPartT+                       HSP.WebT+                       HSP.Google.Analytics   if flag(tests)     Exposed-modules:   Happstack.Tests   other-modules:       Paths_happstack    build-depends:       base >= 3,                        bytestring,-                       happstack-data >= 0.4.1 && < 0.5,-                       happstack-ixset >= 0.4.1 && < 0.5,-                       happstack-server >= 0.4.1 && < 0.5,-                       happstack-state >= 0.4.1 && < 0.5,-                       happstack-util >= 0.4.1 && < 0.5,+                       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,-                       hsp >= 0.4.5 && < 0.5,+                       hsx >= 0.7 && < 0.8,+                       hsp >= 0.5.2 && < 0.6,                        HStringTemplate >= 0.4.3 && < 0.7,                        mtl,                        old-time,-                       utf8-string+                       utf8-string,+                       text                           if flag(base4)-    Build-Depends:     base >= 4 && < 5, syb,-                       hsx >= 0.5.5 && < 0.6+    Build-Depends:     base >= 4 && < 5, syb   else     build-depends:     haskell-src-exts == 0.3.9,-                       hsx == 0.4.5, HStringTemplate < 0.6+                       HStringTemplate < 0.6    hs-source-dirs:      src   if flag(tests)
+ src/HSP/Google/Analytics.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS_GHC -fglasgow-exts -F -pgmFtrhsx #-}+module HSP.Google.Analytics +    ( UACCT(..)+    , analytics+    , addAnalytics+    ) where++import Data.Generics (Data, Typeable)+import HSP+import Prelude hiding (head)++newtype UACCT = UACCT String -- ^ The UACCT provided to you by Google+    deriving (Read, Show, Eq, Ord, Typeable, Data)++-- |create the google analytics script tags+-- NOTE: you must put the <% analytics yourUACCT %> immediately before the </body> tag+-- See also: addAnalytics+analytics :: (XMLGenerator m) => UACCT -> GenXMLList m+analytics (UACCT uacct) =+    do a <- <script type="text/javascript">+              var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");+              document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));+            </script>+       b <- <script type="text/javascript">+              var pageTracker = _gat._getTracker("<% uacct %>");+              pageTracker._initData();+              pageTracker._trackPageview();+            </script>+       return [a,b]++-- |automatically add the google analytics scipt tags immediately before the </body> element+-- NOTE: this function is not idepotent+addAnalytics :: ( AppendChild m XML+                , EmbedAsChild m XML+                , EmbedAsAttr m Attribute+                , XMLGenerator m) +             => UACCT +             -> XMLGenT m XML +             -> GenXML m+addAnalytics uacct pg =+    do page <- pg+       a <- analytics uacct+       case page of+         <html hattrs><[ head, body ]></html> ->+             <html hattrs>+                <% head %>+                <% body <: a %>+             </html>+         o -> error ("Failed to add analytics." ++ show o)++{- Example Analytics Code from Google:++<script type="text/javascript">+var gaJsHost = (("https:" == document.location.protocol) ? "https://ssl." : "http://www.");+document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E"));+</script>+<script type="text/javascript">+var pageTracker = _gat._getTracker("UA-4353757-1");+pageTracker._initData();+pageTracker._trackPageview();+</script>+-}
+ src/HSP/Identity.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module HSP.Identity +    ( Ident+    , evalIdentity+    ) where++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import HSP+import Control.Monad.Identity (Identity(Identity, runIdentity))+import qualified HSX.XMLGenerator as HSX++instance HSX.XMLGenerator Identity++instance HSX.XMLGen Identity where+    type HSX.XML Identity = XML+    newtype HSX.Child Identity = IChild { unIChild :: XML }+    newtype HSX.Attribute Identity = IAttr { unIAttr :: Attribute }+    genElement n attrs children = HSX.XMLGenT $ Identity (Element+                                                          (toName n)+                                                          (map unIAttr $ concatMap runIdentity $ map HSX.unXMLGenT attrs)+                                                          (map unIChild $ concatMap runIdentity $ map HSX.unXMLGenT children)+                                                         )+    xmlToChild = IChild+    pcdataToChild = HSX.xmlToChild . pcdata++instance IsAttrValue Identity T.Text where+    toAttrValue = toAttrValue . T.unpack++instance IsAttrValue Identity TL.Text where+    toAttrValue = toAttrValue . TL.unpack++instance EmbedAsAttr Identity Attribute where+    asAttr = return . (:[]) . IAttr ++instance EmbedAsAttr Identity (Attr String Char) where+    asAttr (n := c)  = asAttr (n := [c])++instance EmbedAsAttr Identity (Attr String String) where+    asAttr (n := str)  = asAttr $ MkAttr (toName n, pAttrVal str)++instance EmbedAsAttr Identity (Attr String Bool) where+    asAttr (n := True)  = asAttr $ MkAttr (toName n, pAttrVal "true")+    asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")++instance EmbedAsAttr Identity (Attr String Int) where+    asAttr (n := i)  = asAttr $ MkAttr (toName n, pAttrVal (show i))++instance (IsName n) => (EmbedAsAttr Identity (Attr n TL.Text)) where+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)++instance (IsName n) => (EmbedAsAttr Identity (Attr n T.Text)) where+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)++instance EmbedAsChild Identity Char where+    asChild = XMLGenT . Identity . (:[]) . IChild . pcdata . (:[])++instance EmbedAsChild Identity String where+    asChild = XMLGenT . Identity . (:[]) . IChild . pcdata++instance (EmbedAsChild Identity TL.Text) where+    asChild = asChild . TL.unpack++instance (EmbedAsChild Identity T.Text) where+    asChild = asChild . T.unpack++instance EmbedAsChild Identity XML where+    asChild = XMLGenT . Identity . (:[]) . IChild++instance EmbedAsChild Identity () where+  asChild () = return []++instance AppendChild Identity XML where+ appAll xml children = do+        chs <- children+        case xml of+         CDATA _ _       -> return xml+         Element n as cs -> return $ Element n as (cs ++ (map stripChild chs))++stripAttr :: HSX.Attribute Identity -> Attribute+stripAttr  (IAttr a) = a++stripChild :: HSX.Child Identity -> XML+stripChild (IChild c) = c++instance SetAttr Identity XML where+ setAll xml hats = do+        attrs <- hats+        case xml of+         CDATA _ _       -> return xml+         Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs++insert :: Attribute -> Attributes -> Attributes+insert = (:)++evalIdentity :: XMLGenT Identity XML -> XML+evalIdentity = runIdentity . HSX.unXMLGenT++type Ident = XMLGenT Identity
+ src/HSP/IdentityT.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-}+module HSP.IdentityT +    ( evalIdentityT+    , IdentT+    , IdentityT(..)+    ) where++import Control.Applicative  (Applicative((<*>), pure))+import Control.Monad        (MonadPlus)+import Control.Monad.Writer (MonadWriter)+import Control.Monad.Reader (MonadReader)+import Control.Monad.State  (MonadState)+import Control.Monad.RWS    (MonadRWS)+import Control.Monad.Trans  (MonadTrans(lift), MonadIO(liftIO))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import HSP+import qualified HSX.XMLGenerator as HSX++-- * IdentityT Monad Transformer++newtype IdentityT m a = IdentityT { runIdentityT :: m a }+    deriving (Functor, Monad, MonadWriter w, MonadReader r, MonadState s, MonadRWS r w s, MonadIO, MonadPlus)++instance (Applicative f) => Applicative (IdentityT f) where+    pure  = IdentityT . pure     +    (IdentityT f) <*> (IdentityT a) = IdentityT (f <*> a)++instance MonadTrans IdentityT where+    lift = IdentityT++-- * HSX.XMLGenerator for IdentityT++instance (Monad m, Functor m) => HSX.XMLGenerator (IdentityT m)++instance (Functor m, Monad m) => HSX.XMLGen (IdentityT m) where+    type HSX.XML (IdentityT m) = XML+    newtype HSX.Child (IdentityT m) = IChild { unIChild :: XML }+    newtype HSX.Attribute (IdentityT m) = IAttr { unIAttr :: Attribute }+    genElement n attrs children = HSX.XMLGenT $ +                                  do attrs'    <- HSX.unXMLGenT (fmap (map unIAttr . concat) (sequence attrs))+                                     children' <- HSX.unXMLGenT (fmap (map unIChild . concat) (sequence children))+                                     return (Element (toName n) attrs' children')+    xmlToChild = IChild+    pcdataToChild = HSX.xmlToChild . pcdata++instance (Monad m, Functor m) => IsAttrValue (IdentityT m) T.Text where+    toAttrValue = toAttrValue . T.unpack++instance (Monad m, Functor m) => IsAttrValue (IdentityT m) TL.Text where+    toAttrValue = toAttrValue . TL.unpack++instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) Attribute where+    asAttr = return . (:[]) . IAttr ++instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Char) where+    asAttr (n := c)  = asAttr (n := [c])++instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String String) where+    asAttr (n := str)  = asAttr $ MkAttr (toName n, pAttrVal str)++instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Bool) where+    asAttr (n := True)  = asAttr $ MkAttr (toName n, pAttrVal "true")+    asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")++instance (Monad m, Functor m) => HSX.EmbedAsAttr (IdentityT m) (Attr String Int) where+    asAttr (n := i)  = asAttr $ MkAttr (toName n, pAttrVal (show i))++instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (IdentityT m) (Attr n TL.Text)) where+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)++instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (IdentityT m) (Attr n T.Text)) where+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)++instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) Char where+    asChild = XMLGenT . return . (:[]) . IChild . pcdata . (:[])++instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) String where+    asChild = XMLGenT . return . (:[]) . IChild . pcdata++instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) (IdentityT m String) where+    asChild c = +        do c' <- lift c+           lift . return . (:[]) . IChild . pcdata $ c'++instance (Monad m, Functor m) => (EmbedAsChild (IdentityT m) TL.Text) where+    asChild = asChild . TL.unpack++instance (Monad m, Functor m) => (EmbedAsChild (IdentityT m) T.Text) where+    asChild = asChild . T.unpack++instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) XML where+    asChild = XMLGenT . return . (:[]) . IChild++instance (Monad m, Functor m) => EmbedAsChild (IdentityT m) () where+  asChild () = return []++instance (Monad m, Functor m) => AppendChild (IdentityT m) XML where+ appAll xml children = do+        chs <- children+        case xml of+         CDATA _ _       -> return xml+         Element n as cs -> return $ Element n as (cs ++ (map stripChild chs))++stripAttr :: (Monad m, Functor m) => HSX.Attribute (IdentityT m) -> Attribute+stripAttr  (IAttr a) = a++stripChild :: (Monad m, Functor m) => HSX.Child (IdentityT m) -> XML+stripChild (IChild c) = c++instance (Monad m, Functor m) => SetAttr (IdentityT m) XML where+ setAll xml hats = do+        attrs <- hats+        case xml of+         CDATA _ _       -> return xml+         Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs++insert :: Attribute -> Attributes -> Attributes+insert = (:)++evalIdentityT :: (Functor m, Monad m) => XMLGenT (IdentityT m) XML -> m XML+evalIdentityT = runIdentityT . HSX.unXMLGenT++type IdentT m = XMLGenT (IdentityT m) XML
+ src/HSP/ServerPartT.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module HSP.ServerPartT where++import HSP+import Control.Applicative ((<$>))+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 <$> asAttr attrs+           childer <- flattenCDATA . map unSChild <$> asChild children+           HSX.XMLGenT $ return (Element+                              (toName n)+                              attribs+                              childer+                             )+    xmlToChild = SChild+    pcdataToChild = HSX.xmlToChild . pcdata++flattenCDATA :: [XML] -> [XML]+flattenCDATA cxml = +                case flP cxml [] of+                 [] -> []+                 [CDATA _ ""] -> []+                 xs -> xs                       +    where+        flP :: [XML] -> [XML] -> [XML]+        flP [] bs = reverse bs+        flP [x] bs = reverse (x:bs)+        flP (x:y:xs) bs = case (x,y) of+                           (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs+                           _ -> flP (y:xs) (x:bs)+++instance (Monad m, Functor m) => IsAttrValue (ServerPartT m) T.Text where+    toAttrValue = toAttrValue . T.unpack++instance (Monad m, Functor m) => IsAttrValue (ServerPartT m) TL.Text where+    toAttrValue = toAttrValue . TL.unpack++instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) Attribute where+    asAttr = return . (:[]) . SAttr ++instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String Char) where+    asAttr (n := c)  = asAttr (n := [c])++instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String String) where+    asAttr (n := str)  = asAttr $ MkAttr (toName n, pAttrVal str)++instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String Bool) where+    asAttr (n := True)  = asAttr $ MkAttr (toName n, pAttrVal "true")+    asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")++instance (Monad m) => HSX.EmbedAsAttr (ServerPartT m) (Attr String Int) where+    asAttr (n := i)  = asAttr $ MkAttr (toName n, pAttrVal (show i))++instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (ServerPartT m) (Attr n TL.Text)) where+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)++instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (ServerPartT m) (Attr n T.Text)) where+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)++instance (Monad m) => EmbedAsChild (ServerPartT m) Char where+    asChild = XMLGenT . return . (:[]) . SChild . pcdata . (:[])++instance (Monad m) => EmbedAsChild (ServerPartT m) String where+    asChild = XMLGenT . return . (:[]) . SChild . pcdata++instance (Monad m) => EmbedAsChild (ServerPartT m) XML where+    asChild = XMLGenT . return . (:[]) . SChild++instance Monad m => EmbedAsChild (ServerPartT m) () where+  asChild () = return []++instance (Monad m, Functor m) => (EmbedAsChild (ServerPartT m) TL.Text) where+    asChild = asChild . TL.unpack++instance (Monad m, Functor m) => (EmbedAsChild (ServerPartT m) T.Text) where+    asChild = asChild . T.unpack++instance (Monad m) => AppendChild (ServerPartT m) XML where+ appAll xml children = do+        chs <- children+        case xml of+         CDATA _ _       -> return xml+         Element n as cs -> return $ Element n as (cs ++ (map unSChild chs))++instance (Monad m) => SetAttr (ServerPartT m) XML where+ setAll xml hats = do+        attrs <- hats+        case xml of+         CDATA _ _       -> return xml+         Element n as cs -> return $ Element n (foldr (:) as (map unSAttr attrs)) cs++instance (Monad m) => XMLGenerator (ServerPartT m)
+ src/HSP/WebT.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module HSP.WebT where++import HSP+import Control.Applicative ((<$>))+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 <$> asAttr attrs+           childer <- flattenCDATA . map unWChild <$> asChild children+           HSX.XMLGenT $ return (Element+                              (toName n)+                              attribs+                              childer+                             )+    xmlToChild = WChild+    pcdataToChild = HSX.xmlToChild . pcdata++flattenCDATA :: [XML] -> [XML]+flattenCDATA cxml = +                case flP cxml [] of+                 [] -> []+                 [CDATA _ ""] -> []+                 xs -> xs                       +    where+        flP :: [XML] -> [XML] -> [XML]+        flP [] bs = reverse bs+        flP [x] bs = reverse (x:bs)+        flP (x:y:xs) bs = case (x,y) of+                           (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs+                           _ -> flP (y:xs) (x:bs)+++instance (Monad m, Functor m) => IsAttrValue (WebT m) T.Text where+    toAttrValue = toAttrValue . T.unpack++instance (Monad m, Functor m) => IsAttrValue (WebT m) TL.Text where+    toAttrValue = toAttrValue . TL.unpack++instance (Monad m) => HSX.EmbedAsAttr (WebT m) Attribute where+    asAttr = return . (:[]) . WAttr ++instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String Char) where+    asAttr (n := c)  = asAttr (n := [c])++instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String String) where+    asAttr (n := str)  = asAttr $ MkAttr (toName n, pAttrVal str)++instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String Bool) where+    asAttr (n := True)  = asAttr $ MkAttr (toName n, pAttrVal "true")+    asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")++instance (Monad m) => HSX.EmbedAsAttr (WebT m) (Attr String Int) where+    asAttr (n := i)  = asAttr $ MkAttr (toName n, pAttrVal (show i))++instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (WebT m) (Attr n TL.Text)) where+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)++instance (Monad m, Functor m, IsName n) => (EmbedAsAttr (WebT m) (Attr n T.Text)) where+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)++instance (Monad m) => EmbedAsChild (WebT m) Char where+    asChild = XMLGenT . return . (:[]) . WChild . pcdata . (:[])++instance (Monad m) => EmbedAsChild (WebT m) String where+    asChild = XMLGenT . return . (:[]) . WChild . pcdata++instance (Monad m, Functor m) => (EmbedAsChild (WebT m) TL.Text) where+    asChild = asChild . TL.unpack++instance (Monad m, Functor m) => (EmbedAsChild (WebT m) T.Text) where+    asChild = asChild . T.unpack++instance (Monad m) => EmbedAsChild (WebT m) XML where+    asChild = XMLGenT . return . (:[]) . WChild++instance Monad m => EmbedAsChild (WebT m) () where+  asChild () = return []++instance (Monad m) => AppendChild (WebT m) XML where+ appAll xml children = do+        chs <- children+        case xml of+         CDATA _ _       -> return xml+         Element n as cs -> return $ Element n as (cs ++ (map unWChild chs))++instance (Monad m) => SetAttr (WebT m) XML where+ setAll xml hats = do+        attrs <- hats+        case xml of+         CDATA _ _       -> return xml+         Element n as cs -> return $ Element n (foldr (:) as (map unWAttr attrs)) cs++instance (Monad m) => XMLGenerator (WebT m)
src/Happstack/Server/HSP/HTML.hs view
@@ -2,6 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Happstack.Server.HSP.HTML   ( webHSP+  , webHSP'   ) where  import Control.Monad.Trans (MonadIO(), liftIO)@@ -38,5 +39,8 @@ -- 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 hsp = toResponse `liftM` liftIO (evalHSP Nothing hsp)+webHSP = webHSP' Nothing +-- | webHSP with XMLMetaData+webHSP' :: (MonadIO m) => Maybe XMLMetaData -> HSP XML -> m Response+webHSP' metadata hsp = toResponse `liftM` liftIO (evalHSP metadata hsp)
src/Happstack/Server/HSX.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Happstack.Server.HSX where  import Happstack.Server.SimpleHTTP (ServerMonad(..), FilterMonad(..), WebMonad(..))
templates/project/bin/run-interactive.bat view
@@ -1,1 +1,1 @@-ghci -isrc src\Main.hs+ghci -isrc -isrc-interactive-only src\Main.hs
templates/project/bin/run-interactive.sh view
@@ -1,2 +1,2 @@ #!/bin/sh-ghci -isrc src/Main.hs+ghci -isrc -isrc-interactive-only src/Main.hs
templates/project/guestbook.cabal view
@@ -9,8 +9,8 @@  This small example guestbook makes an excellent starting point for  your own happstack applications. Cabal-version: >= 1.4.0.0-build-type: Custom-Data-files:+Build-type: Custom+Data-files:          public/theme/style.css         public/theme/images/date.gif         public/theme/images/ql_rss.gif@@ -27,25 +27,15 @@ Flag base4     Description: Choose the even newer, even smaller, split-up base package. -Library- Exposed-Modules:-  App.Control,-  App.Logger,-  App.State,-  App.View,-  GuestBook.Control,-  GuestBook.State,-  GuestBook.View+Executable guestbook-server+ Main-Is: Main.hs  hs-source-dirs: src   GHC-Options: -threaded -Wall -Wwarn -O2 -fno-warn-name-shadowing -fno-warn-missing-signatures -fwarn-tabs -fno-warn-unused-binds -fno-warn-orphans -fwarn-unused-imports- Build-depends: happstack-state, happstack-server, hslogger, mtl, old-time, old-locale, hsx, hsp, happstack, utf8-string, happstack-data, extensible-exceptions+ Build-depends: happstack-state, happstack-server, hslogger, mtl, old-time, old-locale, hsx, hsp, happstack, utf8-string, happstack-data, extensible-exceptions, happstack-util+ if !os(windows)+   -- Cabal has a bug on windows and cannot find trhsx+   Build-Tools: trhsx+  if flag(base4)     Build-Depends: base >= 4 && < 5, syb--Executable guestbook-server- Main-Is: Main.hs- hs-source-dirs: src- GHC-options: -threaded -Wall -Wwarn -O2 -fno-warn-name-shadowing -fno-warn-missing-signatures -fwarn-tabs -fno-warn-unused-binds -fno-warn-orphans -fwarn-unused-imports- Build-depends: happstack-util- Build-Tools: trhsx
templates/project/src/App/Logger.hs view
@@ -1,5 +1,12 @@-module App.Logger (setupLogger) where+module App.Logger (+      LoggerHandle+    , setupLogger+    , teardownLogger+    , withLogger+) where +import Control.Exception.Extensible (bracket)+ import System.Log.Logger     ( Priority(..)     , rootLoggerName@@ -7,9 +14,19 @@     , setHandlers     , updateGlobalLogger     )-import System.Log.Handler.Simple (fileHandler, streamHandler)-import System.IO (stdout)+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@@ -29,3 +46,21 @@     updateGlobalLogger         "Happstack.Server"         (setLevel NOTICE . setHandlers [stdoutLog])+    -- return opaque AppLogger handle+    return $ LoggerHandle appLog accessLog stdoutLog++-- | Tear down the application logger; i.e. close all associated log handlers.+teardownLogger :: LoggerHandle -> IO ()+teardownLogger handle = do+    close $ serverLogHandler handle+    close $ accessLogHandler handle+    close $ rootLogHandler   handle++-- | Bracket an IO action which denotes the whole scope where the loggers of+-- the application are needed to installed. Sets them up before running the action+-- and tears them down afterwards. Even in case of an exception. +withLogger :: IO a -> IO a+withLogger = bracket setupLogger teardownLogger . const++  +
+ templates/project/src/GuestBook/State2.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable,+    FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,+    UndecidableInstances+    #-}+module GuestBook.State2 where+import Happstack.Data+import Happstack.State+import Control.Monad.Reader (ask)+import Control.Monad.State (modify)+import Happstack.State.ClockTime+import qualified GuestBook.State as Old++$(deriveAll [''Show, ''Eq, ''Ord, ''Default]+  [d|+      -- |GuestBookEntry: simple guest book entry+      data GuestBookEntry = GuestBookEntry+          { author  :: String+          , message :: String+          , date    :: ClockTime+          , email :: String+          }++      -- |GuestBook: a list of GuestBookEntry+      newtype GuestBook = GuestBook { guestBookEntries :: [GuestBookEntry] }+   |])++$(deriveSerialize ''GuestBookEntry)+instance Version GuestBookEntry++$(deriveSerialize ''GuestBook)+--instance Version GuestBook+instance Version GuestBook where+  mode = extension 2 (Proxy :: Proxy Old.GuestBook)++++++-- | get the 'GuestBook'+readGuestBook :: Query GuestBook GuestBook+readGuestBook = ask+  +-- | add a 'GuestBookEntry' to the 'GuestBook'+addGuestBookEntry :: GuestBookEntry -> Update GuestBook ()+addGuestBookEntry e = modify $ \(GuestBook gb) -> (GuestBook (e:gb))++-- |make Guestbook its own Component+instance Component GuestBook where+  type Dependencies GuestBook = End+  initialValue = defaultValue+++instance Migrate Old.GuestBook GuestBook where+    migrate (Old.GuestBook entries) = GuestBook $ map f entries+f (Old.GuestBookEntry author message date) = GuestBookEntry author message date "" ++  +-- create types for event serialization+$(mkMethods ''GuestBook ['readGuestBook, 'addGuestBookEntry])
templates/project/src/Main.hs view
@@ -1,6 +1,15 @@ module Main where +import Data.Version (showVersion)+ import Control.Concurrent (MVar, forkIO, killThread)+import Control.Exception (bracket)++import System.Environment (getArgs)+import System.Log.Logger (Priority(..), logM)+import System.Exit (exitWith, ExitCode(..), exitFailure)+import System.Console.GetOpt + import Happstack.Util.Cron (cron) import Happstack.State (waitForTermination) import Happstack.Server@@ -20,54 +29,81 @@   , shutdownSystem   , createCheckpoint   )-import System.Environment (getArgs)-import System.Log.Logger (Priority(..), logM)-import System.Exit (exitFailure)-import System.Console.GetOpt -import App.Logger (setupLogger)++import App.Logger (withLogger) import App.State (AppState(..)) import App.Control (appHandler) -stateProxy :: Proxy AppState-stateProxy = Proxy+-- NOTE: You need to change this file name such that it reflects the name of+-- your project in the .cabal file, because it is auto-generated by cabal.+import Paths_guestbook (version) -main = do-  -- progname effects where state is stored and what the logfile is named-  let progName = "guestbook"-  -  args <- getArgs-  setupLogger -  appConf <- case parseConfig args of-               (Left e) -> do logM progName ERROR (unlines e)-                              exitFailure-               (Right f) -> return (f $ defaultConf progName)-  -  -- start the state system-  control <- startSystemState' (store appConf) stateProxy-  -  -- start the http server-  httpTid <- forkIO $ simpleHTTP (httpConf appConf) appHandler+------------------------------------------------------------------------------+-- Main Function+------------------------------------------------------------------------------ -  -- checkpoint the state once a day-  cronTid <- forkIO $ cron (60*60*24) (createCheckpoint control)-  -  -- wait for termination signal-  waitForTermination-  -  -- cleanup-  killThread httpTid-  killThread cronTid-  createCheckpoint control-  shutdownSystem control +main = withLogger $ do +  -- convert command line arguments into list of flags+  flags <- parseConfig =<< getArgs +  -- display information like help or version, if required+  displayInfo flags++  -- run server+  runServer flags+++-- | Display information required by flags. Currently, this is either the help+-- message or the version information.+displayInfo :: [Flag] -> IO ()+displayInfo flags+  | any isHelp    flags = putStr helpMessage >> exitWith ExitSuccess+  | any isVersion flags = putStr versionInfo >> exitWith ExitSuccess+  | otherwise           = return ()+++------------------------------------------------------------------------------+-- Command Line Interface Content+------------------------------------------------------------------------------++-- | Program name used to identify your application. +-- It influences the version and help message, as well as the directory name+-- for the state of your application.+progName = "guestbook-server"++fullName = "Happstack Guestbook Example"++copyrightInfo = "Copyright (C) 2009 <your-name-here>"+licenceInfo = "See the accompanying licence for copying conditions."++-- | Version information extracted from Paths_guestbook+versionInfo = unlines+  [ fullName ++ " (" ++ progName ++ "), version " ++ showVersion version+  , copyrightInfo+  , licenceInfo+  ]++-- | A simple usage message listing all flags possible.+helpMessage = usageInfo header opts+  where +  header = "Usage: "++progName++" [OPTION...]"+++------------------------------------------------------------------------------+-- Server+------------------------------------------------------------------------------++-- | Configuration information data AppConf     = AppConf { httpConf :: Conf               , store :: FilePath               , static :: FilePath                } +-- | Default configuration+-- FIXME: Should incorporate directories queried via Paths_guestbook module defaultConf :: String -> AppConf defaultConf progName     = AppConf { httpConf = nullConf@@ -75,20 +111,83 @@               , static   = "public"               } -opts :: [OptDescr (AppConf -> AppConf)]-opts = [ Option [] ["http-port"]   (ReqArg (\h c -> c { httpConf = (httpConf c) {port = read h} }) "port") "port to bind http server"-       , Option [] ["no-validate"] (NoArg (\ c -> c { httpConf = (httpConf c) { validator = Nothing } })) "Turn off HTML validation"-       , Option [] ["validate"]    (NoArg (\ c -> c { httpConf = (httpConf c) { validator = Just wdgHTMLValidator } })) "Turn on HTML validation"-       , Option [] ["store"]       (ReqArg (\h c -> c {store = h}) "PATH") "The directory used for database storage."-       , Option [] ["static"]      (ReqArg (\h c -> c {static = h}) "PATH") "The directory searched for static files" -       ]+-- | Run the server with the given configuration.+runServer :: [Flag] -> IO ()+runServer flags = do+  -- combine all server config flags+  let appConf = foldr ($) (defaultConf progName) [f | ServerConfig f <- flags]  -parseConfig :: [String] -> Either [String] (AppConf -> AppConf)-parseConfig args-    = case getOpt Permute opts args of-        (flags,_,[]) -> Right $ \appConf -> foldr ($) appConf flags-        (_,_,errs)   -> Left errs+  -- start the state system+  withSystemState' (store appConf) stateProxy $ \control -> do+    +     -- start the http server+     withThread (simpleHTTP (httpConf appConf) appHandler) $ do -startSystemState' :: (Component st, Methods st) => String -> Proxy st -> IO (MVar TxControl)-startSystemState' = runTxSystem . Queue . FileSaver+       -- checkpoint the state once a day+       withThread (cron (60*60*24) (createCheckpoint control)) $ do+  +          -- wait for termination signal+          logM "Happstack.Server" NOTICE "System running, press 'e <ENTER>' or Ctrl-C to stop server" +          waitForTermination +  where+  startSystemState' :: (Component st, Methods st) => String -> Proxy st -> IO (MVar TxControl)+  startSystemState' = runTxSystem . Queue . FileSaver++  withSystemState' :: (Component st, Methods st) => String -> Proxy st -> (MVar TxControl -> IO a) -> IO a+  withSystemState' name proxy action = +    bracket (startSystemState' name proxy) createCheckpointAndShutdown action++  withThread init action = bracket (forkIO $ init) (killThread) (\_ -> action)++  createCheckpointAndShutdown control = do+    logM "Happstack.Server" NOTICE "Creating system checkpoint" +    createCheckpoint control+    logM "Happstack.Server" NOTICE "System shutdown" +    shutdownSystem control++  -- simon.meier@inf.ethz.ch: I currently don't know what this is used for!+  -- FIXME: Add sensible comment.+  stateProxy :: Proxy AppState+  stateProxy = Proxy+++------------------------------------------------------------------------------+-- Command Line Parsing+------------------------------------------------------------------------------++-- | Flags+data Flag = +    ServerConfig (AppConf -> AppConf)+  | Help+  | Version++-- Flag selectors+isHelp    flag = case flag of Help    -> True; _ -> False+isVersion flag = case flag of Version -> True; _ -> False++-- | Command line options.+opts :: [OptDescr Flag]+opts = [ Option [] ["http-port"]   (ReqArg setPort "port")                        "Port to bind http server"+       , Option [] ["no-validate"] (NoArg $ setValidator Nothing)                 "Turn off HTML validation"+       , Option [] ["validate"]    (NoArg $ setValidator (Just wdgHTMLValidator)) "Turn on HTML validation"+       , Option [] ["store"]       (ReqArg setMacidDir "PATH")                    "The directory used for database storage."+       , Option [] ["static"]      (ReqArg setStaticDir "PATH")                   "The directory searched for static files" +       , Option [] ["version"]     (NoArg Version)                                "Display version information" +       , Option [] ["help"]        (NoArg Help)                                   "Display this help message" +       ]+     where+     setPort p      = ServerConfig $ \c -> c { httpConf = (httpConf c) {port      = read p} }+     setValidator v = ServerConfig $ \c -> c { httpConf = (httpConf c) {validator = v     } }+     setMacidDir p  = ServerConfig $ \c -> c { store = p }+     setStaticDir p = ServerConfig $ \c -> c { static = p }++-- | Parse the command line arguments into a list of flags. Exits with usage+-- message, in case of failure.+parseConfig :: [String] -> IO [Flag]+parseConfig args = case getOpt Permute opts args of+  (flags,_,[]) -> return flags+  (_,_,errs)   -> do+    logM progName ERROR ("Failure while parsing command line:\n"++unlines errs)+    putStr helpMessage+    exitFailure