packages feed

happstack-hsp (empty) → 6.0.0

raw patch · 10 files changed

+637/−0 lines, 10 filesdep +basedep +bytestringdep +happstack-serversetup-changed

Dependencies added: base, bytestring, happstack-server, harp, hsp, hsx, mtl, syb, text, utf8-string

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Jeremy Shaw++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Jeremy Shaw nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ happstack-hsp.cabal view
@@ -0,0 +1,39 @@+Name:                happstack-hsp+Version:             6.0.0+Synopsis:            Support for using HSP templates in Happstack+Description:         Happstack is a web application framework. HSP is an XML templating solution. This package makes it easy to use HSP templates with Happstack.+Homepage:            http://www.happstack.com/+License:             BSD3+License-file:        LICENSE+Author:              Jeremy Shaw+Maintainer:          Happstack team <happs@googlegroups.com>+-- Copyright:           +Category:            Web+Build-type:          Simple+Cabal-version:       >=1.6++source-repository head+    type:     darcs+    subdir:   happstack-hsp+    location: http://patch-tag.com/r/mae/happstack++Library+  Hs-source-dirs:      src+  Exposed-modules:     Happstack.Server.HSP.HTML+                       Happstack.Server.HSX+                       HSP.Identity+                       HSP.IdentityT+                       HSP.ServerPartT+                       HSP.WebT+                       HSP.Google.Analytics+  Build-depends:       base >= 3.0 && < 5.0,+                       bytestring,+                       happstack-server >= 6.0 && < 6.1,+                       harp             >= 0.4 && < 0.5,+                       hsx >= 0.7 && < 0.10,+                       hsp >= 0.5.2 && < 0.7,+                       mtl >= 1.1 && < 2.1,+                       utf8-string,+                       syb,+                       text >= 0.10 && < 0.12+
+ src/HSP/Google/Analytics.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}+{-# OPTIONS_GHC -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.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)
+ 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.Monad (liftM)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified HSX.XMLGenerator as HSX+import Happstack.Server.Internal.Monads (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)
+ src/Happstack/Server/HSP/HTML.hs view
@@ -0,0 +1,46 @@+{-# 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)
+ src/Happstack/Server/HSX.hs view
@@ -0,0 +1,28 @@+-- | This module contains orphan 'XMLGenT' instances for 'ServerMonad', 'FilterMonad', 'WebMonad', 'HasRqData', and 'Happstack'. It does not export any functions.+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Happstack.Server.HSX where++import Control.Monad               (MonadPlus(..))+import Control.Monad.Trans         (MonadIO(..))+import Happstack.Server.SimpleHTTP (ServerMonad(..), FilterMonad(..), WebMonad(..), HasRqData(..), Happstack(..), Response)+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++instance (HasRqData m) => (HasRqData (XMLGenT m)) where+    askRqEnv = XMLGenT askRqEnv+    localRqEnv f (XMLGenT m) = XMLGenT (localRqEnv f m)+    rqDataError = XMLGenT . rqDataError++instance (MonadPlus m, Functor m, MonadIO m, ServerMonad m, FilterMonad a m, WebMonad a m, HasRqData m, a ~ Response) => Happstack (XMLGenT m)