diff --git a/happstack.cabal b/happstack.cabal --- a/happstack.cabal +++ b/happstack.cabal @@ -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) diff --git a/src/HSP/Google/Analytics.hs b/src/HSP/Google/Analytics.hs new file mode 100644 --- /dev/null +++ b/src/HSP/Google/Analytics.hs @@ -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 tag +-- See also: addAnalytics +analytics :: (XMLGenerator m) => UACCT -> GenXMLList m +analytics (UACCT uacct) = + do a <- + b <- + return [a,b] + +-- |automatically add the google analytics scipt tags immediately before the element +-- NOTE: this function is not idepotent +addAnalytics :: ( AppendChild m XML + , EmbedAsChild m XML + , EmbedAsAttr m Attribute + , XMLGenerator m) + => UACCT + -> XMLGenT m XML + -> GenXML m +addAnalytics uacct pg = + do page <- pg + a <- analytics uacct + case page of + <[ head, body ]> -> + + <% head %> + <% body <: a %> + + o -> error ("Failed to add analytics." ++ show o) + +{- Example Analytics Code from Google: + + + +-} diff --git a/src/HSP/Identity.hs b/src/HSP/Identity.hs new file mode 100644 --- /dev/null +++ b/src/HSP/Identity.hs @@ -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 diff --git a/src/HSP/IdentityT.hs b/src/HSP/IdentityT.hs new file mode 100644 --- /dev/null +++ b/src/HSP/IdentityT.hs @@ -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 diff --git a/src/HSP/ServerPartT.hs b/src/HSP/ServerPartT.hs new file mode 100644 --- /dev/null +++ b/src/HSP/ServerPartT.hs @@ -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) diff --git a/src/HSP/WebT.hs b/src/HSP/WebT.hs new file mode 100644 --- /dev/null +++ b/src/HSP/WebT.hs @@ -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) diff --git a/src/Happstack/Server/HSP/HTML.hs b/src/Happstack/Server/HSP/HTML.hs --- a/src/Happstack/Server/HSP/HTML.hs +++ b/src/Happstack/Server/HSP/HTML.hs @@ -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 $ ... -- 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) diff --git a/src/Happstack/Server/HSX.hs b/src/Happstack/Server/HSX.hs --- a/src/Happstack/Server/HSX.hs +++ b/src/Happstack/Server/HSX.hs @@ -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(..)) diff --git a/templates/project/bin/run-interactive.bat b/templates/project/bin/run-interactive.bat --- a/templates/project/bin/run-interactive.bat +++ b/templates/project/bin/run-interactive.bat @@ -1,1 +1,1 @@ -ghci -isrc src\Main.hs +ghci -isrc -isrc-interactive-only src\Main.hs diff --git a/templates/project/bin/run-interactive.sh b/templates/project/bin/run-interactive.sh --- a/templates/project/bin/run-interactive.sh +++ b/templates/project/bin/run-interactive.sh @@ -1,2 +1,2 @@ #!/bin/sh -ghci -isrc src/Main.hs +ghci -isrc -isrc-interactive-only src/Main.hs diff --git a/templates/project/guestbook.cabal b/templates/project/guestbook.cabal --- a/templates/project/guestbook.cabal +++ b/templates/project/guestbook.cabal @@ -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 diff --git a/templates/project/src/App/Logger.hs b/templates/project/src/App/Logger.hs --- a/templates/project/src/App/Logger.hs +++ b/templates/project/src/App/Logger.hs @@ -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 + + + diff --git a/templates/project/src/GuestBook/State2.hs b/templates/project/src/GuestBook/State2.hs new file mode 100644 --- /dev/null +++ b/templates/project/src/GuestBook/State2.hs @@ -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]) diff --git a/templates/project/src/Main.hs b/templates/project/src/Main.hs --- a/templates/project/src/Main.hs +++ b/templates/project/src/Main.hs @@ -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 " +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 ' 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