hsp 0.2 → 0.4
raw patch · 28 files changed
+834/−1786 lines, 28 filesdep +HJScriptdep +hsxdep −containersdep −haskell-src-extsdep −networknew-uploader
Dependencies added: HJScript, hsx
Dependencies removed: containers, haskell-src-exts, network, old-time
Files
- CGI/CGIEnv.hs +0/−86
- HSP.hs +28/−24
- HSP/Application.hs +0/−48
- HSP/Data.hs +0/−537
- HSP/Data/Application.hs +0/−48
- HSP/Data/CSS.hs +0/−58
- HSP/Data/PCDATA.hs +0/−22
- HSP/Data/RequestEnv.hs +0/−152
- HSP/Data/Response.hs +0/−37
- HSP/Data/Session.hs +0/−197
- HSP/Data/XML.hs +0/−117
- HSP/Env.hs +29/−0
- HSP/Env/NumberGen.hs +3/−0
- HSP/Env/Request.hs +56/−0
- HSP/Exception.hs +14/−10
- HSP/HJScript.hs +110/−0
- HSP/Monad.hs +95/−0
- HSP/Request.hs +0/−62
- HSP/Response.hs +0/−25
- HSP/Session.hs +0/−43
- HSP/XML.hs +128/−0
- HSP/XML/PCDATA.hs +52/−0
- HSP/XMLGenerator.hs +310/−0
- HTTP/Common.hs +0/−45
- HTTP/Request.hs +0/−152
- HTTP/Response.hs +0/−61
- HTTP/Util.hs +0/−31
- hsp.cabal +9/−31
− CGI/CGIEnv.hs
@@ -1,86 +0,0 @@-module CGI.CGIEnv (- CGIEnv,- CGIVariable,- getCGIVars- ) where--import System.Environment (getEnv)-import System.IO.Error (isDoesNotExistError)-import Control.Exception (Exception(..), catch, throw)-import Prelude hiding (catch)--type CGIEnv = ([CGIVariable],RequestBody)-type CGIVariable = (VariableName, Value)-type VariableName = String-type Value = String-type RequestBody = String--getCGIVars :: IO CGIEnv-getCGIVars = do f <- mapM getCGIVar cgiVars- s <- getContents- return (f,s)--getCGIVar :: VariableName -> IO CGIVariable-getCGIVar name- = do vv <- catch (getEnv name) handleException- return $ (name, vv)- where- handleException :: Exception -> IO Value- handleException (IOException e)- | isDoesNotExistError e = return ""- handleException e = throw e--cgiVars :: [VariableName]-cgiVars- = [ - -- environment variables as specified by CGI/1.1- "SERVER_SOFTWARE"- , "SERVER_NAME"- , "GATEWAY_INTERFACE"- , "SERVER_PROTOCOL"- , "SERVER_PORT"- , "REQUEST_METHOD"- , "PATH_INFO"- , "PATH_TRANSLATED"- , "SCRIPT_NAME"- , "QUERY_STRING"- , "REMOTE_HOST"- , "REMOTE_ADDR"- , "AUTH_TYPE"- , "REMOTE_USER"- , "REMOTE_IDENT"- , "CONTENT_TYPE"- , "CONTENT_LENGTH"- -- environment variables for general HTTP headers, rfc2616- , "HTTP_CACHE_CONTROL"- , "HTTP_CONNECTION"- , "HTTP_DATE"- , "HTTP_PRAGMA"- , "HTTP_TRAILER"- , "HTTP_TRANSFER_ENCODING"- , "HTTP_UPGRADE"- , "HTTP_VIA"- , "HTTP_WARNING"- -- environment variables for request HTTP headers, rfc2616- , "HTTP_ACCEPT"- , "HTTP_ACCEPT_CHARSET"- , "HTTP_ACCEPT_ENCODING"- , "HTTP_ACCECPT_LANGUAGE"- , "HTTP_AUTHORIZATION"- , "HTTP_EXPECT"- , "HTTP_FROM"- , "HTTP_HOST"- , "HTTP_IF_MATCH"- , "HTTP_IF_MODIFIED_SINCE"- , "HTTP_IF_NONE_MATCH"- , "HTTP_IF_RANGE"- , "HTTP_IF_UNMODIFIED_SINCE"- , "HTTP_MAX_FORWARDS"- , "HTTP_PROXY_AUTHORIZATION"- , "HTTP_RANGE"- , "HTTP_REFERER"- , "HTTP_TE"- , "HTTP_USER_AGENT"- -- environment variable for request HTTP header "Cookie", rfc 2109- , "HTTP_COOKIE"- ]
HSP.hs view
@@ -1,24 +1,28 @@-{-# OPTIONS -fallow-overlapping-instances #-}--------------------------------------------------------------------------------- |--- Module : HSP.Data--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Imports and re-exports all HSP functionality available to the end user. -------------------------------------------------------------------------------module HSP (- module HSP.Data,- module HSP.Request,- module HSP.Response,- module HSP.Session- ) where--import HSP.Data-import HSP.Request-import HSP.Response-import HSP.Session+module HSP ( + -- module HSP.Monad + HSP, runHSP, evalHSP, + getParam, getIncNumber, doIO, catch, + + -- module HSP.Env + module HSP.Env, + + -- module HSP.XML[.PCDATA] + module HSP.XML, + module HSP.XML.PCDATA, + + -- module HSP.XMLGenerator + module HSP.XMLGenerator, + + -- module HSP.HJScript + module HSP.HJScript + + ) where + +import Prelude hiding (catch) + +import HSP.Monad +import HSP.Env hiding (mkSimpleEnv) +import HSP.XML hiding (Name) +import HSP.XML.PCDATA +import HSP.XMLGenerator +import HSP.HJScript
− HSP/Application.hs
@@ -1,48 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.Application--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)------ Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Defines the Application object available to HSP pages.-------------------------------------------------------------------------------module HSP.Application (- Application -- ^ The 'Application' datatype is abstract- , toApplication -- ^ :: Typeable a => a -> Application- , fromApplication -- ^ :: Typeable a => Application -> Maybe a- , defaultApplication -- ^ :: Application- ) where--import Data.Dynamic--{- |- The 'Application' datatype is a wrapper around a 'Dynamic' value.- The reason we need a 'Dynamic' is that a user may want just about- anything in the 'Application'.--}-data Application = MkApp { unwrap :: Dynamic }---- | Lifting a user-defined application-scope datatype into an 'Application' object.--- Note that the 'Typeable' constraint limits the choices of datatypes to--- monomorphic ones.-toApplication :: Typeable a- => a -- ^ The value to put in the 'Application' object- -> Application -- ^ returns: The value wrapped up as an 'Application' object-toApplication = MkApp . toDyn---- | Extracting the user-defined application-scope datatype from its 'Application'--- wrapper.-fromApplication :: Typeable a- => Application -- ^ The 'Application' object to unwrap- -> Maybe a -- ^ returns: Just the value if the expected type coincides with- -- the one put in, 'Nothing' otherwise-fromApplication = fromDynamic . unwrap----- | An empty Application object to use when no user-defined Application.hs exists.-defaultApplication :: Application-defaultApplication = toApplication ()
− HSP/Data.hs
@@ -1,537 +0,0 @@-{-# OPTIONS -fallow-overlapping-instances -fallow-undecidable-instances -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : HSP.Data--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Datatypes and type classes comprising the basic model behind--- the scenes of Haskell Server Pages tags.--------------------------------------------------------------------------------module HSP.Data (- -- * The 'XML' datatype- XML(..), - Domain, - Name, - Attributes, - Attribute,- AttrValue(..),- Children,- isTag, isCdata,- -- * The 'HSP' Monad- HSP,- HSPEnv,- runHSP,- unsafeRunHSP, -- dangerous!!- doIO, - -- * Type classes- IsXML(..), - IsXMLs(..), - IsAttrValue(..),- IsStyleValue(..),- IsStyle(..),- -- * Functions- renderXML,- mkTag,- genTag,- mkETag,- genETag,- pcdata,- cdata,- extract,-- -- * Accessing the environment- getApplication,- getRequest,- getSession,- getResponse,-- -- * Attribute manipulation- set,- Attr(..),- IsAttribute(..),- IsName,-- -- * 'CSS' combinators- (<:>),- (<+>),- cssId,- cssClass,- cssElem,- pc,- css,-- -- * Exceptions- throwHSP,- catch- ) where--import Prelude hiding (catch)--import HSP.Exception-import Control.Exception (catchDyn, throwDyn)-import Control.Monad.Reader (ReaderT(..), ask, lift, runReaderT)-import Control.Monad.Trans (MonadIO(..))--import Data.Typeable-import Data.List (intersperse)--import HSP.Data.XML-import HSP.Data.PCDATA-import HSP.Data.CSS-import qualified HSP.Data.RequestEnv as Rq-import qualified HSP.Data.Response as Rp-import qualified HSP.Data.Application as A-import qualified HSP.Data.Session as S------------------------------------------------------------------- The HSP Monad---- | The HSP monad is simply a reader wrapper around--- the IO monad.-data HSP a = MkHSP {baseC :: ReaderT HSPEnv IO a}---- | -type HSPEnv = (A.Application, S.Session, Rq.RequestEnv, Rp.Response)---- do NOT export this in the final version-dummyEnv :: HSPEnv-dummyEnv = undefined--instance Monad HSP where- return = MkHSP . return- c1 >>= k = MkHSP $ do- a <- baseC c1- baseC $ k a--instance MonadIO HSP where- liftIO c = doIO c--runHSP :: HSP a -> HSPEnv -> IO a-runHSP = runReaderT . baseC--unsafeRunHSP :: HSP a -> IO a-unsafeRunHSP hspf = runHSP hspf dummyEnv--doIO :: IO a -> HSP a-doIO = MkHSP . lift--getEnv :: HSP HSPEnv-getEnv = MkHSP ask----------------------------------------------------------------------- Type classes------------------ IsXML---- | Instantiate this class to enable values of the given type--- to appear as XML elements.-class IsXML a where- toXML :: a -> HSP XML---- | XML can naturally be represented as XML.-instance IsXML XML where- toXML = return---- | Strings should be represented as PCDATA.-instance IsXML String where- toXML = return . pcdata---- | Anything that can be shown can always fall back on--- that as a default behavior.-instance (Show a) => IsXML a where- toXML = toXML . show ---- | An IO computation returning something that can be represented--- as XML can be lifted into an analogous HSP computation.-instance (IsXML a) => IsXML (IO a) where- toXML ioa = toXML $ doIO ioa---- | An HSP computation returning something that can be represented--- as XML simply needs to turn the produced value into XML.-instance (IsXML a) => IsXML (HSP a) where- toXML hspa = hspa >>= toXML---- | CSS can appear as PCDATA of a style tag.-instance IsXML CSS where- toXML (CSS entries) = <style type="text/css">- <% unlines (map show entries) %>- </style>------------------ IsXMLs---- | Instantiate this class to enable values of the given type--- to be represented as a list of XML elements. Note that for--- any given type, only one of the two classes IsXML and IsXMLs--- should ever be instantiated. Values of types that instantiate --- IsXML can automatically be represented as a (singleton) list --- of XML children.-class IsXMLs a where- toXMLs :: a -> HSP [XML]---- | Anything that can be represented as a single XML element--- can of course be represented as a (singleton) list of XML--- elements.-instance (IsXML a) => IsXMLs a where- toXMLs a = do xml <- toXML a- return [xml]---- | We must specify an extra rule for Strings even though the previous--- rule would apply, because the rule for [a] would also apply and--- would be more specific.-instance IsXMLs String where- toXMLs s = do xml <- toXML s- return [xml]---- | If something can be represented as a list of XML, then a list of --- that something can also be represented as a list of XML.-instance (IsXMLs a) => IsXMLs [a] where- toXMLs as = do xmlss <- mapM toXMLs as- return $ concat xmlss---- | An IO computation returning something that can be represented--- as a list of XML can be lifted into an analogous HSP computation.-instance (IsXMLs a) => IsXMLs (IO a) where- toXMLs = toXMLs . doIO---- | An HSP computation returning something that can be represented--- as a list of XML simply needs to turn the produced value into --- a list of XML.-instance (IsXMLs a) => IsXMLs (HSP a) where- toXMLs hspa = hspa >>= toXMLs---- | Of the base types, () stands out as a type that can only be--- represented as a (empty) list of XML.-instance IsXMLs () where- toXMLs _ = return []---- | Maybe types are handy for cases where you might or might not want--- to generate XML, such as null values from databases-instance (IsXMLs a) => IsXMLs (Maybe a) where- toXMLs Nothing = return []- toXMLs (Just a) = toXMLs a-------------------- IsAttrValue---- | Instantiate this class to enable values of the given type--- to appear as XML attribute values.-class IsAttrValue a where- toAttrValue :: a -> HSP AttrValue--- fromAttrValue :: AttrValue -> a---- | An AttrValue is trivial.-instance IsAttrValue AttrValue where- toAttrValue = return---- | Strings can be directly represented as values.-instance IsAttrValue String where- toAttrValue = return . Value . toPCDATA---- | Anything that can be shown and read can always fall back on--- that as a default behavior.-instance (Show a, Read a) => IsAttrValue a where- toAttrValue = toAttrValue . show---- | An IO computation returning something that can be represented--- as an attribute value can be lifted into an analogous HSP computation.-instance (IsAttrValue a) => IsAttrValue (IO a) where- toAttrValue = toAttrValue . doIO ---- | An HSP computation returning something that can be represented--- as a list of XML simply needs to turn the produced value into --- a list of XML.-instance (IsAttrValue a) => IsAttrValue (HSP a) where- toAttrValue hspa = hspa >>= toAttrValue---- | The common way to present list data in attributes is as--- a comma separated, unbracketed sequence-instance (IsAttrValue a) => IsAttrValue [a] where- toAttrValue as = do [/ (Value vs)* /] <- mapM toAttrValue as- return . Value $ concat $ intersperse "," vs-------------------- GetAttrValue---- | Instantiate this class to enable values of the given type--- to be retrieved through attribute patterns.-class GetAttrValue a where- fromAttrValue :: AttrValue -> a---- | An AttrValue is trivial.-instance GetAttrValue AttrValue where- fromAttrValue = id---- | Strings can be directly taken from values.-instance GetAttrValue String where- fromAttrValue (Value s) = s- --- | Anything that can be read can always fall back on--- that as a default behavior.-instance (Read a) => GetAttrValue a where- fromAttrValue = read . fromAttrValue---- | An IO computation returning something that can be represented--- as an attribute value can be lifted into an analogous HSP computation.-instance (GetAttrValue a, Monad m) => GetAttrValue (m a) where- fromAttrValue = return . fromAttrValue---- | The common way to present list data in attributes is as--- a comma separated, unbracketed sequence-instance (GetAttrValue a) => GetAttrValue [a] where- fromAttrValue v@(Value str) = case str of- [/ v1+, (/ ',', vs@:_+ /)+ /] -> - map (fromAttrValue . Value) (v1:vs)- _ -> [fromAttrValue v]---- All that for these two functions-extract :: (GetAttrValue a) => Name -> Attributes -> (Maybe a, Attributes)-extract _ [] = (Nothing, [])-extract name (p@(n, v):as) - | name == n = (Just $ fromAttrValue v, as)- | otherwise = let (val, attrs) = extract name as- in (val, p:attrs)-------------------- IsStyleValue---- | Instantiate this class to enable values of the given type--- to appear as CSS attribute values.--- Instances mirroring the relevant ones of IsAttrValue are supplied-class IsStyleValue a where- toStyleValue :: a -> HSP StyleValue---- | A StyleValue is trivial.-instance IsStyleValue StyleValue where- toStyleValue = return---- | Strings can be directly represented as values.-instance IsStyleValue String where- toStyleValue = return . StyleValue---- | Anything that can be shown and read can always fall back on--- that as a default behavior.-instance (Show a, Read a) => IsStyleValue a where- toStyleValue = toStyleValue . show---- | An IO computation returning something that can be represented--- as a style value can be lifted into an analogous HSP computation.-instance (IsStyleValue a) => IsStyleValue (IO a) where- toStyleValue = toStyleValue . doIO---- | An HSP computation returning something that can be represented--- as a style value simply needs to turn the produced value into --- a style value.-instance (IsStyleValue a) => IsStyleValue (HSP a) where- toStyleValue hspa = hspa >>= toStyleValue---- | An Int is chosen to represent a value in pixels.-instance IsStyleValue Int where- toStyleValue x = toStyleValue $ show x ++ "px"---- | A Float is chosen to represent a value in percent.--- E.g. 0.33 yields 33%.-instance IsStyleValue Float where- toStyleValue x = toStyleValue $ show (round (x*100)) ++ "%"------------------ IsStyle---- | Instantiate this class to enable values of the given type--- to appear as styles and be combined with other styles.-class IsStyle s where- toStyle :: s -> HSP Style---- | A Style is trivial-instance IsStyle Style where- toStyle = return---- | An IO computation returning something that can be represented--- as a style can be lifted into an analogous HSP computation.-instance (IsStyle a) => IsStyle (IO a) where- toStyle = toStyle . doIO---- | An HSP computation returning something that can be represented--- as a style simply needs to turn the produced value into --- a style.-instance (IsStyle a) => IsStyle (HSP a) where- toStyle hspa = hspa >>= toStyle----------------------------------------------------------------------------- Manipulating attributes--data Attr = forall n a . (IsName n, IsAttrValue a) => n := a--class IsName n where- toName :: n -> Name--instance IsName Name where- toName = id--instance IsName String where- toName s = (Nothing, s)--instance IsName (String, String) where- toName (ns, s) = (Just ns, s)--class IsAttribute a where- toAttribute :: a -> HSP Attribute- -instance IsAttribute Attribute where- toAttribute = return--instance IsAttribute Attr where- toAttribute (n := a) = do av <- toAttrValue a- return (toName n, av)--instance (IsAttribute a) => IsAttribute (HSP a) where- toAttribute hspa = hspa >>= toAttribute--instance (IsAttribute a) => IsAttribute (IO a) where- toAttribute ioa = doIO ioa >>= toAttribute--instance IsAttribute Style where- toAttribute s = toAttribute $ "style" := show s--set :: (IsXML a, IsAttribute at) => a -> at -> HSP XML-set x a = setAll x [a]--setAll :: (IsXML a, IsAttribute at) => a -> [at] -> HSP XML-setAll isxml ats = do- xml <- toXML isxml- attrs <- mapM toAttribute ats- case xml of- CDATA _ -> return xml- Tag n ats cs -> return $ Tag n (foldr insert ats attrs) cs-------------------------------------------------------------------------- CSS combinators--(<:>) :: IsStyleValue sv => String -> sv -> HSP Style-name <:> svc = do sv <- toStyleValue svc- return $ Style [(name, sv)]--(<+>) :: (IsStyle a, IsStyle b) => a -> b -> HSP Style-sc1 <+> sc2 = do Style set1 <- toStyle sc1- Style set2 <- toStyle sc2- return $ Style (set1 ++ set2)--cssId = CSSId-cssClass = CSSClass-cssElem = CSSElem-pc = CSSPseudoClass--css :: [HSP CSSEntry] -> HSP CSS-css ecs = do es <- sequence ecs- return $ CSS es -------------------------------------------------------------------------- Generation---- | Generate a Tag from its components. -mkTag :: (IsName n, IsXMLs xmls, IsAttribute at) => n -> [at] -> xmls -> HSP XML-mkTag n attrs xmls = do- cxml <- toXMLs xmls- attribs <- mapM toAttribute attrs- return $ Tag (toName n) - (foldr insert eAttrs attribs)- (flattenCDATA cxml)- - where flattenCDATA :: [XML] -> [XML]- flattenCDATA xmls = - case flP xmls [] of- [] -> []- [CDATA ""] -> []- xs -> xs - flP :: [XML] -> [XML] -> [XML]- flP [] bs = reverse bs- flP [x] bs = reverse (x:bs)- flP (x:y:xs) bs = case (x,y) of- (CDATA s1, CDATA s2) -> flP (CDATA (s1++s2) : xs) bs- _ -> flP (y:xs) (x:bs)--genTag :: Name -> [HSP Attribute] -> [HSP [XML]] -> HSP XML-genTag = mkTag----- | Generate a Tag with no children from its components-mkETag :: (IsName n, IsAttribute at) => n -> [at] -> HSP XML-mkETag n attrs = mkTag n attrs ([] :: [XML])--genETag :: Name -> [HSP Attribute] -> HSP XML-genETag = mkETag---eAttrs :: Attributes-eAttrs = []--insert :: Attribute -> Attributes -> Attributes-insert = (:)----------------------------------------------------------------------------- Exception handling---- | Catch a user-caused exception-catch :: HSP a -> (Exception -> HSP a) -> HSP a-catch (MkHSP (ReaderT f)) handler = MkHSP $ ReaderT $ \e ->- f e `catchDyn` (\ex -> (let (MkHSP (ReaderT g)) = handler ex- in g e))---- Will not be exported to the user-throwHSP :: Exception -> a-throwHSP = throwDyn---------------------------------------------------------------------------- The Application object---- Will not be exported-getApp :: HSP A.Application-getApp = do (app, _s, _rq, _rp) <- getEnv- return app---- | Fetch the user-defined data held within the Application object--- in the HSP environment.-getApplication :: Typeable a => HSP a-getApplication = do app <- getApp- case A.fromApplication app of- Nothing -> throwHSP WrongApplicationType- Just a -> return a---------------------------------------------------------------------------- The Session object---- Will not be exported-getSession :: HSP S.Session-getSession = do (_a, sess, _rq, _rp) <- getEnv- return sess----------------------------------------------------------------------------- The Request object---- Will not be exported-getRequest :: HSP Rq.RequestEnv-getRequest = do (_a, _s, req, _rp) <- getEnv- return req----------------------------------------------------------------------------- The Response object---- Will not be exported-getResponse :: HSP Rp.Response-getResponse = do (_a, _s, _rq, resp) <- getEnv- return resp-
− HSP/Data/Application.hs
@@ -1,48 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.Data.Application--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)------ Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Defines the Application object available to HSP pages.-------------------------------------------------------------------------------module HSP.Data.Application (- Application -- ^ The 'Application' datatype is abstract- , toApplication -- ^ :: Typeable a => a -> Application- , fromApplication -- ^ :: Typeable a => Application -> Maybe a- , defaultApplication -- ^ :: Application- ) where--import Data.Dynamic--{- |- The 'Application' datatype is a wrapper around a 'Dynamic' value.- The reason we need a 'Dynamic' is that a user may want just about- anything in the 'Application'.--}-data Application = MkApp { unwrap :: Dynamic }---- | Lifting a user-defined application-scope datatype into an 'Application' object.--- Note that the 'Typeable' constraint limits the choices of datatypes to--- monomorphic ones.-toApplication :: Typeable a- => a -- ^ The value to put in the 'Application' object- -> Application -- ^ returns: The value wrapped up as an 'Application' object-toApplication = MkApp . toDyn---- | Extracting the user-defined application-scope datatype from its 'Application'--- wrapper.-fromApplication :: Typeable a- => Application -- ^ The 'Application' object to unwrap- -> Maybe a -- ^ returns: Just the value if the expected type coincides with- -- the one put in, 'Nothing' otherwise-fromApplication = fromDynamic . unwrap----- | An empty Application object to use when no user-defined Application.hs exists.-defaultApplication :: Application-defaultApplication = toApplication ()
− HSP/Data/CSS.hs
@@ -1,58 +0,0 @@-{-# OPTIONS -fallow-overlapping-instances -fallow-undecidable-instances - -fglasgow-exts #-}--------------------------------------------------------------------------- | --- Module : HSP.Data.CSS--- Copyright : --- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : --- Stability : experimental--- Portability : -------------------------------------------------------------------------module HSP.Data.CSS (- -- * The CSS datatype- CSS(..),- CSSEntry(..),- CSSType(..),- -- * The Style datatype- Style(..),- StyleValue(..),- ) where----------------------------------------------------------------------------- Data types--newtype Style = Style [(String, StyleValue)]-newtype StyleValue = StyleValue String--data CSSEntry = CSSEntry [CSSType] Style--data CSSType = CSSId String- | CSSClass String- | CSSElem String- | CSSPseudoClass CSSType String--newtype CSS = CSS [CSSEntry]----------------------------------------------------------------------------- Rendering--instance Show Style where- show (Style stl) = - concatMap (\(name, (StyleValue sv)) -> name ++ ": " ++ sv ++ ";") stl--instance Show StyleValue where- show (StyleValue str) = str--instance Show CSSType where- show typ = case typ of- (CSSId str) -> "#" ++ str ++ " "- (CSSClass str) -> "." ++ str ++ " "- (CSSElem str) -> str ++ " "- (CSSPseudoClass typ str) -> show typ ++ ":" ++ str ++ " "--instance Show CSSEntry where- show (CSSEntry typ sty) = concatMap show typ ++ "\t{ " ++ show sty ++ " }"
− HSP/Data/PCDATA.hs
@@ -1,22 +0,0 @@-module HSP.Data.PCDATA (- toPCDATA- ) where---toPCDATA :: String -> String-toPCDATA [] = ""-toPCDATA (c:cs) = pChar c ++ toPCDATA cs--pChar :: Char -> String-pChar c = case lookup c escapes of- Nothing -> [c]- Just s -> '&' : s ++ ";"--escapes :: [(Char, String)]-escapes = [- ('&', "amp" ),- ('\"', "quot" ),- ('\'', "apos" ),- ('<', "lt" ),- ('>', "gt" )- ]
− HSP/Data/RequestEnv.hs
@@ -1,152 +0,0 @@-{-# LANGUAGE PatternGuards #-}--------------------------------------------------------------------------------- |--- Module : HSP.Data.RequestEnv--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)------ Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Defines the RequestEnv object available to HSP pages,--- either in the form of a complete Request structure,--- or as a set of CGI environment variables.-------------------------------------------------------------------------------module HSP.Data.RequestEnv (- RequestEnv -- ^ The Request type is abstract- , newRequest -- ^ :: HTTP.Request.Request -> RequestEnv- , newCGIReq -- ^ :: CGI.CGIEnv -> RequestEnv- , getVarValue -- ^ :: RequestEnv -> String -> Maybe String- , getMethod -- ^ :: RequestEnv -> Method- , getCookie -- ^ :: RequestEnv -> String -> Maybe String- , Method(..) -- ^ An HTTP Method- , RequestURI(..)- , HTTPVersion(..)- ) where--import HTTP.Request--import CGI.CGIEnv-import Network.URI--import qualified Data.Map as M--{- |- The Request datatype is a repository of request scope variables,- together with extra information on the incomming HTTP request such- as headers, method etc.--}-data RequestEnv = RequestEnv {- dataRep :: M.Map String [String],- cookies :: M.Map String String,- rawData :: Either Request CGIEnv- }---- | Build a HSP Request object given a parsed HTTP request.-newRequest :: Request -> RequestEnv-newRequest req =- let headers = reqHeaders req- mch = lookupHeader headers "Cookie"- ckies = case mch of- Nothing -> []- Just str -> csToVars str- in case reqMethod req of- GET -> let vars = readURIVars (reqURI req)- in RequestEnv {- dataRep = M.fromListWith (++) vars,- cookies = M.fromList ckies,- rawData = Left req }- _ -> RequestEnv {- dataRep = M.empty,- cookies = M.fromList ckies,- rawData = Left req }- where readURIVars :: RequestURI -> [(String, [String])]- readURIVars uri = case uri of- AbsURI uri -> qsToVars (uriQuery uri)- AbsPath p -> case dropWhile (/='?') p of- "" -> []- (_:qs) -> qsToVars qs- _ -> []--lookupHeader :: [Header] -> String -> Maybe String-lookupHeader [] _ = Nothing-lookupHeader ((Header (fn, fv)):hs) str =- if fn == str then Just fv else lookupHeader hs str---newCGIReq :: CGIEnv -> RequestEnv-newCGIReq cgienv@(rvars,rbody) =- let vars = case lookup "REQUEST_METHOD" rvars of- Just "POST" -> newCGIPostReq cgienv- _ -> newCGIGetReq rvars- ckies = case lookup "HTTP_COOKIE" rvars of- Just cs -> M.fromList $ csToVars cs- Nothing -> M.empty- in RequestEnv {- dataRep = vars,- cookies = ckies,- rawData = Right cgienv }--newCGIGetReq :: [CGIVariable] -> M.Map String [String]-newCGIGetReq cgienv =- case lookup "QUERY_STRING" cgienv of- Just qs -> M.fromListWith (++) $ qsToVars qs- Nothing -> M.empty--newCGIPostReq :: CGIEnv -> M.Map String [String]-newCGIPostReq (cgienv,rbody) =- case lookup "CONTENT_LENGTH" cgienv of- -- if content length is not a valid int an exception is thrown- Just l -> M.fromListWith (++) $ qsToVars $ take (read l) rbody- Nothing -> M.empty---qsToVars :: String -> [(String, [String])]-qsToVars [/ ks@_+, '=', vs@_*, (/ '&', kss@:_+, '=', vss@:_* /)* /]- = zip (ks:kss) $ map (\s -> [unEscape s]) (vs:vss)-qsToVars "" = [] -- TODO: What if there's an error?--csToVars :: String -> [(String, String)]-csToVars [/ ' '*!, ks@_+, ' '*!, '=', ' '*!, vs@_+, ' '*!,- (/ ';', ' '*!, kss@:_+, ' '*!, '=', ' '*!, vss@:_+, ' '*! /)* /]- = zip (ks:kss) (vs:vss)-csToVars "" = []--unEscape s = unEscapeString $ map (\ch -> if ch == '+' then ' ' else ch) s---- | Return the value of a request scope variable, if available.-getVarValue :: RequestEnv -> String -> Maybe [String]-getVarValue req key = M.lookup key (dataRep req)---- | Return the HTTP method for this request.-getMethod :: RequestEnv -> Method-getMethod = either reqMethod (maybe GET read . lookup "REQUEST_METHOD" . fst) . rawData -- TODO: what to do on error?---- | Return the value of a Cookie-getCookie :: RequestEnv -> String -> Maybe String-getCookie req co = M.lookup co (cookies req)--{---- | Return the URI for this request.-getURI :: RequestEnv -> RequestURI-getURI re = case rawData re of- Left req -> reqURI req- Right -> ???---- | Return the HTTP version used in this request.-getVersion :: RequestEnv -> HTTPVersion-getVersion re = either reqVersion- (maybe http1_1 read . lookup "SERVER_PROTOCOL") -- ?? shouldn't that be client?---- | Return the value associated with a given header, if--- the header was set in the incomming request.-getHeader :: RequestEnv -> String -> Maybe String-getHeader req hd =- let headers = reqHeaders $ rawRequest req- in lookupHeader hd headers- where lookupHeader hd [] = Nothing- lookupHeader hd (Header (hn, hv):hds)- | hd == hn = Just hv- | otherwise = lookupHeader hd hds--}
− HSP/Data/Response.hs
@@ -1,37 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.Data.Response--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Defines the Response object available to HSP pages.-------------------------------------------------------------------------------module HSP.Data.Response (- Response -- ^ The Response type is abstract- , initResponse -- ^ :: IO Response- , setOutgoingHeader -- ^ :: Response -> String -> String -> IO ()- , getHeaders -- ^ :: Response -> IO [(String, String)]- ) where--import Data.IORef--data Response = Response {- outHeaders :: IORef [(String, String)]- }---- | Set a header in the outgoing response.-setOutgoingHeader :: Response -> String -> String -> IO ()-setOutgoingHeader resp hdn hdv =- modifyIORef (outHeaders resp) ((hdn,hdv):)- --- | Initialise a blank response.-initResponse = do ref <- newIORef []- return $ Response { outHeaders = ref }---- | Get all set headers.-getHeaders :: Response -> IO [(String, String)]-getHeaders = readIORef . outHeaders
− HSP/Data/Session.hs
@@ -1,197 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.Data.Session--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Defines the Session object available to HSP pages.-------------------------------------------------------------------------------module HSP.Data.Session (- Session -- ^ Abstract- -- * Functions used in HSP- , getVarValue -- ^ :: Session -> Key -> IO (Maybe Value)- , setVarValue -- ^ :: Session -> Key -> Value -> IO ()- , deleteVar -- ^ :: Session -> Key -> IO ()- , abandon -- ^ :: Session -> IO ()- , setExpires -- ^ :: Session -> CalendarTime -> IO ()- -- * Functions used by the RTS- , isSession -- ^ :: Session -> IO Bool- , getSessionId -- ^ :: Session -> IO (Maybe SessionId)- , getExpires -- ^ :: Session -> IO Expires- , initSession -- ^ :: [(Key, Value)] -> IO Session- , noSession -- ^ :: IO Session- , getNewVars -- ^ :: Session -> IO [(Key, (Value, Expires))]- , getUpdatedVars -- ^ :: Session -> IO [(Key, (Value, Expires))]- , getDeletedVars -- ^ :: Session -> IO [Key]- ) where--import qualified Data.HashTable as HT-import Control.Concurrent.MVar--import System.Time------------------------------------------ Help types--type Expires = Maybe CalendarTime-type Key = String-type Value = String-type SessionId = Int--neverExpire :: Expires-neverExpire = Nothing--expire :: CalendarTime -> Expires-expire = Just--data Status = New | Orig | Updated | Deleted- deriving (Eq)--updateStatus :: Status -> Status-updateStatus s = case s of- New -> New- _ -> Updated--------------------------------------------- The main datatypes---- | The 'Session' datatype is basically a data repository.--- To keep tracks of updates, we use an extra repository.-newtype Session = MkSession (MVar (Maybe SessionData))--data SessionData = MkSessionData {- sessionId :: MVar (Maybe SessionId), - expires :: MVar Expires,- dataRep :: HT.HashTable Key (Value,Expires,Status)- }---- | Create a new 'Session' object with initial data.-initSession :: SessionId -> Expires -> [(Key, (Value, Expires))] -> IO Session-initSession sid exps initData = do- let dat = map (\(k,(v,e)) -> (k,(v,e,Orig))) initData - rep <- HT.fromList HT.hashString dat- exp <- newMVar exps- si <- newMVar $ Just sid- let sd = MkSessionData { - dataRep = rep,- expires = exp, - sessionId = si }- mvSess <- newMVar $ Just sd- return $ MkSession mvSess--noSession :: IO Session-noSession = do- mvs <- newMVar Nothing- return $ MkSession mvs-------------------------------------------- Operate on sessions- --- | Retrieve the value of a variable in the repository.-getVarValue :: Session -> Key -> IO (Maybe Value)-getVarValue (MkSession mvSess) k = do- msess <- takeMVar mvSess- res <- case msess of- Just sd -> do mv <- HT.lookup (dataRep sd) k- case mv of- Nothing -> return Nothing- Just (v,_,st) | st /= Deleted - -> return $ Just v- _ -> return $ Nothing- putMVar mvSess msess - return res--setVarValue :: Session -> Key -> Value -> IO ()-setVarValue (MkSession mvSess) k v = do- msess <- takeMVar mvSess- case msess of- Nothing -> do - dr <- HT.fromList HT.hashString [(k, (v, neverExpire, New))]- exp <- newMVar neverExpire- si <- newMVar Nothing- putMVar mvSess $ Just $ MkSessionData si exp dr- Just sd -> do- mv <- HT.lookup (dataRep sd) k- case mv of- Nothing -> HT.insert (dataRep sd) k (v, neverExpire, New)- Just (_,e,st) -> HT.insert (dataRep sd) k (v, e, updateStatus st)- putMVar mvSess msess- -deleteVar :: Session -> Key -> IO ()-deleteVar (MkSession mvSess) k = do- msess <- takeMVar mvSess- case msess of- Nothing -> return ()- Just sd -> HT.delete (dataRep sd) k- putMVar mvSess msess--abandon :: Session -> IO ()-abandon (MkSession mvs) = modifyMVar_ mvs (\_ -> return Nothing)--setExpires :: Session -> CalendarTime -> IO ()-setExpires (MkSession mvs) ct = do- msess <- takeMVar mvs- case msess of- Nothing -> do - dr <- HT.new (==) HT.hashString- si <- newMVar Nothing- exp <- newMVar $ expire ct- putMVar mvs (Just $ MkSessionData si exp dr)- Just sd -> do - modifyMVar_ (expires sd) (\_ -> return $ expire ct)- putMVar mvs msess---------------------------------------------- Used by HSPR--isSession :: Session -> IO Bool-isSession s = withSession s $ \ms ->- case ms of- Nothing -> return False- Just _ -> return True---getSessionId :: Session -> IO (Maybe SessionId)-getSessionId s = withSession s $ \ms ->- case ms of- Nothing -> return Nothing- Just s -> readMVar (sessionId s)--getExpires :: Session -> IO Expires-getExpires s = withSession s $ \ms ->- case ms of- Nothing -> return Nothing- Just s -> readMVar (expires s)-----getVars :: Status -> Session -> IO [(Key, (Value, Expires))]-getVars status s = withSession s $ \msess ->- case msess of- Nothing -> return []- Just sd -> do- vals <- HT.toList (dataRep sd)- let newVals = filter (\(_,(_,_,st)) -> st == status) vals- return $ map (\(k,(v,e,_)) -> (k,(v,e))) newVals--getNewVars, getUpdatedVars :: Session -> IO [(Key, (Value, Expires))]-getNewVars = getVars New-getUpdatedVars = getVars Updated--getDeletedVars :: Session -> IO [Key]-getDeletedVars s = do - vals <- getVars Deleted s- return $ map fst vals---withSession :: Session -> (Maybe SessionData -> IO a) -> IO a-withSession (MkSession mvs) f = do- ms <- takeMVar mvs- r <- f ms- putMVar mvs ms- return r
− HSP/Data/XML.hs
@@ -1,117 +0,0 @@-{-# OPTIONS -fallow-overlapping-instances -fallow-undecidable-instances -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : HSP.Data.XML--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Datatypes and type classes comprising the basic model behind--- the scenes of Haskell Server Pages tags.-------------------------------------------------------------------------------module HSP.Data.XML (- -- * The 'XML' datatype- XML(..), - Domain, - Name, - Attributes, - Children,- pcdata,- cdata,- -- * The Attribute type- Attribute,- AttrValue(..),- -- * Functions- renderXML,- isTag, isCdata- ) where--import Data.List (intersperse)--import HSP.Data.PCDATA (toPCDATA)------------------------------------------------------------------- Data types--type Domain = Maybe String-type Name = (Domain, String)-type Attributes = [Attribute]-type Children = [XML]--data XML = Tag Name Attributes Children- | CDATA String--instance Show XML where- show = renderXML--isTag, isCdata :: XML -> Bool-isTag (Tag {}) = True-isTag _ = False-isCdata = not . isTag--pcdata :: String -> XML-pcdata = CDATA . toPCDATA--cdata :: String -> XML-cdata = CDATA-------------------------------------------------------------------- Attributes--type Attribute = (Name, AttrValue)--newtype AttrValue = Value String--instance Show AttrValue where- show (Value str) = str----------------------------------------------------------------------- Rendering--renderXML :: XML -> String-renderXML xml = renderXML' 0 xml ""--data TagType = Open | Close | Single--renderXML' :: Int -> XML -> ShowS-renderXML' _ (CDATA cdata) = showString cdata-renderXML' n (Tag name attrs []) = renderTag Single n name attrs-renderXML' n (Tag name attrs children) =- let open = renderTag Open n name attrs - cs = renderChildren n children - close = renderTag Close n name []- in open . cs . close-- where renderChildren :: Int -> Children -> ShowS- renderChildren n cs = foldl (.) id $ map (renderXML' (n+2)) cs-- -renderTag :: TagType -> Int -> Name -> Attributes -> ShowS -renderTag typ n name attrs = - let (start,end) = case typ of- Open -> (showChar '<', showChar '>')- Close -> (showString "</", showChar '>')- Single -> (showChar '<', showString "/>")- nam = showName name- as = renderAttrs attrs- in start . nam . as . end-- where renderAttrs :: Attributes -> ShowS- renderAttrs [] = nl- renderAttrs attrs = showChar ' ' . ats . nl- where ats = foldl (.) id $ intersperse (showChar ' ') $ fmap renderAttr attrs--- renderAttr :: Attribute -> ShowS- renderAttr (n, (Value val)) = showName n . showChar '=' . renderAttrVal val-- renderAttrVal :: String -> ShowS- renderAttrVal s = showChar '\"' . showString s . showChar '\"'-- showName (Nothing, s) = showString s- showName (Just d, s) = showString d . showChar ':' . showString s-- nl = showChar '\n' . showString (replicate n ' ')-
+ HSP/Env.hs view
@@ -0,0 +1,29 @@+module HSP.Env ( + module HSP.Env.Request, + module HSP.Env.NumberGen, + + HSPEnv(..), + + mkSimpleEnv + ) where + +import HSP.Env.Request +import HSP.Env.NumberGen + +import Data.IORef + +-- | The runtime environment for HSP pages. +data HSPEnv = HSPEnv { + getReq :: Request -- In CGI mode we only support Request +-- , getResp :: Rp.Response + , getNG :: NumberGen + } + + + +mkSimpleEnv :: IO HSPEnv +mkSimpleEnv = do + x <- newIORef 0 + let req = Request (const []) [] + num = NumberGen (atomicModifyIORef x (\a -> (a+1,a))) + return $ HSPEnv req num
+ HSP/Env/NumberGen.hs view
@@ -0,0 +1,3 @@+module HSP.Env.NumberGen where + +data NumberGen = NumberGen { incNumber :: IO Int }
+ HSP/Env/Request.hs view
@@ -0,0 +1,56 @@+----------------------------------------------------------------------------- +-- | +-- Module : HSP.Env.Request +-- Copyright : (c) Niklas Broberg 2006, +-- License : BSD-style (see the file LICENSE.txt) +-- +-- Maintainer : Niklas Broberg, nibro@cs.chalmers.se +-- Stability : experimental +-- Portability : Haskell 98 +-- +-- An interface to a request object as held in the HSP environment. +----------------------------------------------------------------------------- + +module HSP.Env.Request ( + Request(..), + getParameter, + getParameter_, + readParameter, + readParameterL, + readParameter_ + ) where + +import HSP.Exception (throwHSP, Exception(..)) + +-- | A record representing an interface to an HTTP request. This allows us to use +-- many different underlying types for these requests, all we need is to supply +-- conversions to this interface. This is useful for when we run as CGI, or when +-- we run inside a server app. +data Request = Request { + getParameterL :: String -> [String] + , getHeaders :: [(String, String)] + } + +-- | Get a parameter from the request query string (GET) or body (POST). +-- | Returns @Nothing@ if the parameter is not set. +getParameter :: Request -> String -> Maybe String +getParameter r k = case getParameterL r k of + (v:_) -> Just v + _ -> Nothing + +-- | Unsafe version of getParameter, essentially fromJust.(getParameter r) but throws +-- a ParameterLookupFailed exception if the parameter is not set. +getParameter_ :: Request -> String -> String +getParameter_ r s = maybe (throwHSP $ ParameterLookupFailed s) id $ getParameter r s + +-- | Return a value instead of a string. +readParameter :: Read a => Request -> String -> Maybe a +readParameter r s = fmap read $ getParameter r s + +-- | Return a list of values read from their string representations. +readParameterL :: Read a => Request -> String -> [a] +readParameterL r s = map read $ getParameterL r s + +-- | Unsafe version of readParameter +readParameter_ :: Read a => Request -> String -> a +readParameter_ r s = read $ getParameter_ r s
HSP/Exception.hs view
@@ -2,27 +2,31 @@ ----------------------------------------------------------------------------- -- | -- Module : HSP.Exception--- Copyright : (c) Niklas Broberg 2004,+-- Copyright : (c) Niklas Broberg 2008 -- License : BSD-style (see the file LICENSE.txt) -- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se+-- Maintainer : Niklas Broberg, nibro@cs.chalmers.se -- Stability : experimental--- Portability : requires undecidable and overlapping instances+-- Portability : needs dynamic exceptions and deriving Typeable -- -- Defines a datatype for runtime exceptions that may arise during -- the evaluation of a HSP page. ------------------------------------------------------------------------------module HSP.Exception where+module HSP.Exception (+ Exception(..),+ throwHSP + ) where import Data.Typeable+import Control.Exception (throwDyn) data Exception- = WrongApplicationType -- ^ User tries to infer the wrong type- -- for the data stored in the 'Application' object.- | NoApplication -- ^ User tries to access application data in cgi mode.- | NoOutHeaders -- ^ User tries to add outgoing headers in cgi mode.- | ParameterLookupFailed String -- ^ User tried to do an irrefutable parameter lookup+ = ParameterLookupFailed String -- ^ User tried to do an irrefutable parameter lookup -- that failed.-+ -- | ... I'm sure there should be more exceptions, we'll add them when we get to them. deriving (Eq, Show, Typeable)++-- Internal funcion that throws a dynamic exception particular to HSP.+throwHSP :: Exception -> a+throwHSP = throwDyn
+ HSP/HJScript.hs view
@@ -0,0 +1,110 @@+module HSP.HJScript where + +import HSP +import HJScript + +import qualified HSX.XMLGenerator as HSX + +instance IsXMLs (Block ()) where + toXMLs b = toXMLs $ + <script language="JavaScript"> + <% cdata (show b) %> + </script> + +instance IsXMLs (HJScript ()) where + toXMLs script = toXMLs . snd $ evalHJScript script 0 + +instance IsAttrValue (HJScript ()) where + toAttrValue script = do + let block = snd $ evalHJScript script 0 + return . Value $ "javascript:" ++ show block + +newGlobalVar :: HSP (Var t, Block ()) +newGlobalVar = do + varName <- newGlobVarName + let block = toBlock $ VarDecl varName + return (JVar varName, block) + +newGlobalVarWith :: Exp t -> HSP (Var t, Block ()) +newGlobalVarWith e = do + varName <- newGlobVarName + let block = toBlock $ VarDeclAssign varName e + return (JVar varName, block) + +newGlobVarName :: HSP String +newGlobVarName = do + r <- getIncNumber + return $ "global_" ++ (show r) + + +type ElemRef = String +{- +-- This should be done Soon (TM), but we +-- need to look over things like getElementById, +-- so it'll have to wait until the next version. + +newtype ElemRef = ElemRef String + +instance IsAttrValue ElemRef where + toAttrValue (ElemRef s) = toAttrValue s + +instance ToAttrNodeValue ElemRef where + toAttrNodeValue (ElemRef s) = toAttrValue s +-} + +genId :: HSP ElemRef +genId = do + r <- getIncNumber + return $ "elemId_" ++ (show r) + +ref :: HSP XML -> HSP (ElemRef, XML) +ref xml = do + i <- genId + xml' <- xml `setId` i + return (i, xml') + + +------------------------------------------------- +-- Settting properties +------------------------------------------------- + +setId :: (HSX.SetAttr m xml, HSX.EmbedAsAttr (Attr String v) (HSX.XMLGenT m (HSX.Attribute m))) + => xml -> v -> HSX.XMLGenT m (HSX.XML m) +setId x v = x `set` ("id" := v) + + + +-- Generel method for adding 'onEvent' attributes to XML elements. +--onEvent :: SetAttr xml (Attr String (HJScript ())) => Event -> xml -> HJScript () -> SetResult xml +onEvent :: (HSX.SetAttr m xml, HSX.EmbedAsAttr (Attr String (HJScript ())) (HSX.XMLGenT m (HSX.Attribute m))) + => Event -> xml -> HJScript () -> HSX.XMLGenT m (HSX.XML m) +onEvent event xml script = xml `set` (showEvent event := script) + +onAbort, onBlur, onChange, onClick, onDblClick, onError, + onFocus, onKeyDown, onKeyPress, onKeyUp, onLoad, onMouseDown, + onMouseMove, onMouseOut, onMouseOver, onMouseUp, onReset, + onResize, onSelect, onSubmit, onUnload :: + (HSX.SetAttr m xml, HSX.EmbedAsAttr (Attr String (HJScript ())) (HSX.XMLGenT m (HSX.Attribute m))) + => xml -> HJScript () -> HSX.XMLGenT m (HSX.XML m) + +onAbort = onEvent OnAbort +onBlur = onEvent OnBlur +onChange = onEvent OnChange +onClick = onEvent OnClick +onDblClick = onEvent OnDblclick +onError = onEvent OnError +onFocus = onEvent OnFocus +onKeyDown = onEvent OnKeyDown +onKeyPress = onEvent OnKeyPress +onKeyUp = onEvent OnKeyUp +onLoad = onEvent OnLoad +onMouseDown = onEvent OnMouseDown +onMouseMove = onEvent OnMouseMove +onMouseOut = onEvent OnMouseOut +onMouseOver = onEvent OnMouseOver +onMouseUp = onEvent OnMouseUp +onReset = onEvent OnReset +onResize = onEvent OnResize +onSelect = onEvent OnSelect +onSubmit = onEvent OnSubmit +onUnload = onEvent OnUnload
+ HSP/Monad.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS_GHC -fallow-overlapping-instances #-}+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+{-# OPTIONS_GHC -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : HSP.Data+-- Copyright : (c) Niklas Broberg 2008+-- License : BSD-style (see the file LICENSE.txt)+-- +-- Maintainer : Niklas Broberg, nibro@cs.chalmers.se+-- Stability : experimental+-- Portability : requires undecidable and overlapping instances, and forall in datatypes+--+-- Datatypes and type classes comprising the basic model behind+-- the scenes of Haskell Server Pages tags.+-----------------------------------------------------------------------------++module HSP.Monad (+ -- * The 'HSP' Monad+ HSP, HSP',+ runHSP, evalHSP,+ unsafeRunHSP, -- dangerous!!+ -- * Functions+ getParam, getIncNumber, doIO, catch+ ) where++-- Monad imports+import Control.Monad.Reader (ReaderT(..), ask, lift)+import Control.Monad.Trans (MonadIO(..))++import Prelude hiding (catch)++-- Exceptions+import Control.Exception (catchDyn)+import HSP.Exception++import HSP.Env++import HSX.XMLGenerator (XMLGenT(..), unXMLGenT)++--------------------------------------------------------------+-- The HSP Monad++-- | The HSP monad is a reader wrapper around+-- the IO monad, but extended with an XMLGenerator wrapper.+type HSP' = ReaderT HSPEnv IO+type HSP = XMLGenT HSP'++-- do NOT export this in the final version+dummyEnv :: HSPEnv+dummyEnv = undefined++-- | Runs a HSP computation in a particular environment. Since HSP wraps the IO monad,+-- the result of running it will be an IO computation.+runHSP :: HSP a -> HSPEnv -> IO a+runHSP = runReaderT . unXMLGenT++evalHSP :: HSP a -> IO a+evalHSP hsp = mkSimpleEnv >>= runHSP hsp ++-- | Runs a HSP computation without an environment. Will work if the page in question does+-- not touch the environment. Not sure about the usefulness at this stage though...+unsafeRunHSP :: HSP a -> IO a+unsafeRunHSP hspf = runHSP hspf dummyEnv++-- | Execute an IO computation within the HSP monad.+doIO :: IO a -> HSP a+doIO = liftIO++----------------------------------------------------------------+-- Environment stuff++-- | Supplíes the HSP environment.+getEnv :: HSP HSPEnv+getEnv = lift ask++getRequest :: HSP Request+getRequest = fmap getReq getEnv++getParam :: String -> HSP (Maybe String)+getParam s = getRequest >>= \req -> return $ getParameter req s++getIncNumber :: HSP Int+getIncNumber = getEnv >>= doIO . incNumber . getNG++++-----------------------------------------------------------------------+-- Exception handling++-- | Catch a user-caused exception.+catch :: HSP a -> (Exception -> HSP a) -> HSP a+catch (XMLGenT (ReaderT f)) handler = XMLGenT $ ReaderT $ \e ->+ f e `catchDyn` (\ex -> (let (XMLGenT (ReaderT g)) = handler ex+ in g e))
− HSP/Request.hs
@@ -1,62 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.Request--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Defines the RequestEnv object available to HSP pages,--- either in the form of a complete Request structure,--- or as a set of CGI environment variables.-------------------------------------------------------------------------------module HSP.Request (- getParameter -- ^ :: String -> HSP (Maybe String)- , getParameter_ -- ^ :: String -> HSP String- , getParameterL -- ^ :: String -> HSP [String]- , readParameter -- ^ :: String -> HSP (Maybe a)- , readParameter_ -- ^ :: String -> HSP a- , readParameterL -- ^ :: String -> HSP [a]- , getHTTPMethod -- ^ :: HSP Method- ) where --import HSP.Data-import HSP.Exception--import HSP.Data.RequestEnv as Rq--getParameter :: String -> HSP (Maybe String)-getParameter p = - do rq <- getRequest- case Rq.getVarValue rq p of- Just [v] -> return (Just v)- _ -> return Nothing--getParameter_ :: String -> HSP String-getParameter_ p = - do rq <- getRequest- case Rq.getVarValue rq p of- Just [v] -> return v- _ -> throwHSP $ ParameterLookupFailed p--getParameterL :: String -> HSP [String]-getParameterL p =- do rq <- getRequest- case Rq.getVarValue rq p of- Just v -> return v- _ -> return []--readParameter :: Read a => String -> HSP (Maybe a)-readParameter p = getParameter p >>= return . (fmap read)--readParameter_ :: Read a => String -> HSP a-readParameter_ p = getParameter_ p >>= return . read--readParameterL :: Read a => String -> HSP [a]-readParameterL p = getParameterL p >>= return . (fmap read)---- | Get the HTTP method for the Request.-getHTTPMethod :: HSP Rq.Method-getHTTPMethod = getRequest >>= return . Rq.getMethod
− HSP/Response.hs
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.Response--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Defines the Response object available to HSP pages.-------------------------------------------------------------------------------module HSP.Response (- setOutgoingHeader -- ^ :: Response -> String -> String -> IO ()- ) where--import qualified HSP.Data.Response as Rp-import HSP.Data---- | Add a header to the outgoing response generated for--- this page.-setOutgoingHeader :: String -> String -> HSP ()-setOutgoingHeader hdn hdv = do- resp <- getResponse- doIO $ Rp.setOutgoingHeader resp hdn hdv
− HSP/Session.hs
@@ -1,43 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.Session--- Copyright : (c) Niklas Broberg 2004,--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : requires undecidable and overlapping instances------ Defines the Session object available to HSP pages.-------------------------------------------------------------------------------module HSP.Session (- getSessionVar- , setSessionVar- , delSessionVar- , abandon- ) where--import qualified HSP.Data.Session as S-import HSP.Data----- | Retrieve the value of a session scope variable, if available.-getSessionVar :: String -> HSP (Maybe String)-getSessionVar key = do - sess <- getSession- doIO $ S.getVarValue sess key---- | Insert or update the value of a session scope variable.-setSessionVar :: String -> String -> HSP ()-setSessionVar k v = do - sess <- getSession- doIO $ S.setVarValue sess k v---- | Delete a session scope variable.-delSessionVar :: String -> HSP ()-delSessionVar k = do- sess <- getSession- doIO $ S.deleteVar sess k--abandon :: HSP ()-abandon = getSession >>= doIO . S.abandon
+ HSP/XML.hs view
@@ -0,0 +1,128 @@+-----------------------------------------------------------------------------+-- |+-- Module : HSP.XML+-- Copyright : (c) Niklas Broberg 2008+-- License : BSD-style (see the file LICENSE.txt)+-- +-- Maintainer : Niklas Broberg, nibro@cs.chalmers.se+-- Stability : experimental+-- Portability : Haskell 98+--+-- Datatypes and type classes comprising the basic model behind+-- the scenes of Haskell Server Pages tags.+-----------------------------------------------------------------------------+module HSP.XML (+ -- * The 'XML' datatype+ XML(..), + Domain, + Name, + Attributes, + Children,+ pcdata,+ cdata,+ -- * The Attribute type+ Attribute,+ AttrValue(..),+ attrVal, pAttrVal,+ -- * Functions+ renderXML,+ isElement, isCDATA+ ) where++import Data.List (intersperse)++import HSP.XML.PCDATA (escape)+---------------------------------------------------------------+-- Data types++type Domain = Maybe String+type Name = (Domain, String)+type Attributes = [Attribute]+type Children = [XML]++-- | The XML datatype representation. Is either an Element or CDATA.+data XML = Element Name Attributes Children+ | CDATA String+ deriving Show++{- instance Show XML where+ show = renderXML -}++-- | Test whether an XML value is an Element or CDATA+isElement, isCDATA :: XML -> Bool+isElement (Element {}) = True+isElement _ = False+isCDATA = not . isElement++-- | Embeds a string as a CDATA XML value.+cdata , pcdata :: String -> XML+cdata = CDATA+pcdata = cdata . escape++---------------------------------------------------------------+-- Attributes++type Attribute = (Name, AttrValue)++-- | Represents an attribue value.+newtype AttrValue = Value String++-- | Create an attribue value from a string.+attrVal, pAttrVal :: String -> AttrValue+attrVal = Value+pAttrVal = attrVal . escape++instance Show AttrValue where+ show (Value str) = str++------------------------------------------------------------------+-- Rendering++-- TODO: indents are incorrectly calculated++-- | Pretty-prints XML values.+renderXML :: XML -> String+renderXML xml = renderXML' 0 xml ""++data TagType = Open | Close | Single++renderXML' :: Int -> XML -> ShowS+renderXML' _ (CDATA cd) = showString cd+renderXML' n (Element name attrs []) = renderTag Single n name attrs+renderXML' n (Element name attrs children) =+ let open = renderTag Open n name attrs + cs = renderChildren n children + close = renderTag Close n name []+ in open . cs . close++ where renderChildren :: Int -> Children -> ShowS+ renderChildren n' cs = foldl (.) id $ map (renderXML' (n'+2)) cs++ +renderTag :: TagType -> Int -> Name -> Attributes -> ShowS +renderTag typ n name attrs = + let (start,end) = case typ of+ Open -> (showChar '<', showChar '>')+ Close -> (showString "</", showChar '>')+ Single -> (showChar '<', showString "/>")+ nam = showName name+ as = renderAttrs attrs+ in start . nam . as . end++ where renderAttrs :: Attributes -> ShowS+ renderAttrs [] = nl+ renderAttrs attrs' = showChar ' ' . ats . nl+ where ats = foldl (.) id $ intersperse (showChar ' ') $ fmap renderAttr attrs'+++ renderAttr :: Attribute -> ShowS+ renderAttr (nam, (Value val)) = showName nam . showChar '=' . renderAttrVal val++ renderAttrVal :: String -> ShowS+ renderAttrVal s = showChar '\"' . showString s . showChar '\"'++ showName (Nothing, s) = showString s+ showName (Just d, s) = showString d . showChar ':' . showString s++ nl = showChar '\n' . showString (replicate n ' ')+
+ HSP/XML/PCDATA.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module : HSP.XML.PCDATA+-- Copyright : (c) Niklas Broberg 2008+-- License : BSD-style (see the file LICENSE.txt)+-- +-- Maintainer : Niklas Broberg, nibro@cs.chalmers.se+-- Stability : experimental+-- Portability : Haskell 98+--+-- Escaping between CDATA <=> PCDATA+-----------------------------------------------------------------------------+module HSP.XML.PCDATA (+ escape -- :: String -> String+ , unescape -- :: String -> String+ ) where+++-- | Take a normal string and transform it to PCDATA by escaping special characters.+escape :: String -> String+escape [] = ""+escape (c:cs) = pChar c ++ escape cs++pChar :: Char -> String+pChar c = case lookup c escapeChars of+ Nothing -> [c]+ Just s -> '&' : s ++ ";"++-- This list should be extended.+escapeChars :: [(Char, String)]+escapeChars = [+ ('&', "amp" ),+ ('\"', "quot" ),+ ('\'', "apos" ),+ ('<', "lt" ),+ ('>', "gt" )+ ]++-- | Take a PCDATA string and translate all escaped characters in it to the normal+-- characters they represent.+-- Does no error checking of input string, will fail if input is not valid PCDATA.+unescape :: String -> String+unescape = reverse . unE ""+ where unE acc "" = acc+ unE acc (c:cs) = + case c of+ '&' -> let (esc, ';':rest) = break (==';') cs+ Just ec = revLookup esc escapeChars+ in unE (ec:acc) rest+ _ -> unE (c:acc) cs+ + revLookup e = lookup e . map (\(a,b) -> (b,a))
+ HSP/XMLGenerator.hs view
@@ -0,0 +1,310 @@+module HSP.XMLGenerator ( + -- * Type classes + IsXML(..), + IsXMLs(..), + IsAttrValue(..), + IsAttribute(..), + + extract, + + module HSX.XMLGenerator, HSX.genElement, HSX.genEElement + + ) where + +import HSP.Monad +import HSP.XML hiding (Name) + +import HSX.XMLGenerator hiding (XMLGenerator(..)) +import qualified HSX.XMLGenerator as HSX (XMLGenerator(..)) + + +--------------------------------------------- +-- Instantiating XMLGenerator for the HSP monad. + + +-- | We can use literal XML syntax to generate values of type XML in the HSP monad. +instance HSX.XMLGenerator HSP' where + type HSX.XML HSP' = XML + type HSX.Attribute HSP' = Attribute + type HSX.Child HSP' = XML + genElement = element + genEElement = eElement + +instance (IsXMLs a) => EmbedAsChild a (HSP [XML]) where + asChild = toXMLs + + +------------------------------------------------------------------- +-- Type classes + +------------- +-- IsXML + +-- | Instantiate this class to enable values of the given type +-- to appear as XML elements. +class IsXML a where + toXML :: a -> HSP XML + +-- | XML can naturally be represented as XML. +instance IsXML XML where + toXML = return + +-- | Strings should be represented as PCDATA. +instance IsXML String where + toXML = return . pcdata + +-- | Anything that can be shown can always fall back on +-- that as a default behavior. +instance (Show a) => IsXML a where + toXML = toXML . show + +-- | An IO computation returning something that can be represented +-- as XML can be lifted into an analogous HSP computation. +instance (IsXML a) => IsXML (IO a) where + toXML = toXML . doIO + +-- | An HSP computation returning something that can be represented +-- as XML simply needs to turn the produced value into XML. +instance (IsXML a) => IsXML (HSP a) where + toXML hspa = hspa >>= toXML + + +------------- +-- IsXMLs + +-- | Instantiate this class to enable values of the given type +-- to be represented as a list of XML elements. Note that for +-- any given type, only one of the two classes IsXML and IsXMLs +-- should ever be instantiated. Values of types that instantiate +-- IsXML can automatically be represented as a (singleton) list +-- of XML children. +class IsXMLs a where + toXMLs :: a -> HSP [XML] + +-- | Anything that can be represented as a single XML element +-- can of course be represented as a (singleton) list of XML +-- elements. +--instance (IsXML a) => IsXMLs a where +-- toXMLs a = do xml <- toXML a +-- return [xml] + +-- | XML can naturally be represented as XML. +instance IsXMLs XML where + toXMLs = return . return + + +-- | We must specify an extra rule for Strings even though the previous +-- rule would apply, because the rule for [a] would also apply and +-- would be more specific. +instance IsXMLs String where + toXMLs s = do xml <- toXML s + return [xml] + +-- | If something can be represented as a list of XML, then a list of +-- that something can also be represented as a list of XML. +instance (IsXMLs a) => IsXMLs [a] where + toXMLs as = do xmlss <- mapM toXMLs as + return $ concat xmlss + +-- | An IO computation returning something that can be represented +-- as a list of XML can be lifted into an analogous HSP computation. +instance (IsXMLs a) => IsXMLs (IO a) where + toXMLs ioa = doIO ioa >>= toXMLs + +-- | Any child elements that arise through the use of literal syntax should be of the same +-- type as the parent element, unless explicitly given a different type. We use TypeCast +-- to accomplish this. This also captures the case when the embedded value is an HSP computation. +instance (IsXMLs x, TypeCast (m x) (HSP' x)) => IsXMLs (XMLGenT m x) where + toXMLs (XMLGenT x) = (XMLGenT $ typeCast x) >>= toXMLs + +-- | Of the base types, () stands out as a type that can only be +-- represented as a (empty) list of XML. +instance IsXMLs () where + toXMLs _ = return [] + +-- | Maybe types are handy for cases where you might or might not want +-- to generate XML, such as null values from databases +instance (IsXMLs a) => IsXMLs (Maybe a) where + toXMLs Nothing = return [] + toXMLs (Just a) = toXMLs a + +--------------- +-- IsAttrValue + +-- | Instantiate this class to enable values of the given type +-- to appear as XML attribute values. +class IsAttrValue a where + toAttrValue :: a -> HSP AttrValue +-- fromAttrValue :: AttrValue -> a + +-- | An AttrValue is trivial. +instance IsAttrValue AttrValue where + toAttrValue = return + +-- | Strings can be directly represented as values. +instance IsAttrValue String where + toAttrValue = return . pAttrVal + +-- | Anything that can be shown can always fall back on +-- that as a default behavior. +instance Show a => IsAttrValue a where + toAttrValue = toAttrValue . show + +-- | An IO computation returning something that can be represented +-- as an attribute value can be lifted into an analogous HSP computation. +instance (IsAttrValue a) => IsAttrValue (IO a) where + toAttrValue = toAttrValue . doIO + +-- | An HSP computation returning something that can be represented +-- as a list of XML simply needs to turn the produced value into +-- a list of XML. +instance (IsAttrValue a) => IsAttrValue (HSP a) where + toAttrValue hspa = hspa >>= toAttrValue + +-- | The common way to present list data in attributes is as +-- a comma separated, unbracketed sequence +--instance (IsAttrValue a) => IsAttrValue [a] where +-- toAttrValue as = do [/ (Value vs)* /] <- mapM toAttrValue as +-- return . Value $ concat $ intersperse "," vs + + +----------------------------------------------------------------------- +-- Manipulating attributes + +-- | Just like with XML children, we want to conveniently allow values of various +-- types to appear as attributes. +class IsAttribute a where + toAttribute :: a -> HSP Attribute + +-- | Attributes can represent attributes. +instance IsAttribute Attribute where + toAttribute = return + +-- | Values of the Attr type, constructed with :=, can represent attributes. +instance (IsName n, IsAttrValue a) => IsAttribute (Attr n a) where + toAttribute (n := a) = do av <- toAttrValue a + return (toName n, av) + +-- | Attributes can be the result of an HSP computation. +instance (IsAttribute a) => IsAttribute (HSP a) where + toAttribute hspa = hspa >>= toAttribute + +-- | ... or of an IO computation. +instance (IsAttribute a) => IsAttribute (IO a) where + toAttribute ioa = doIO ioa >>= toAttribute + +-- | Anything that can represent an attribute can also be embedded as attributes +-- using the literal XML syntax. +instance (IsAttribute a) => EmbedAsAttr a (HSP Attribute) where + asAttr = toAttribute + +-- | Set an attribute to something in an XML element. +--set :: (IsXML a, IsAttribute at) => a -> at -> HSP XML +--set x a = setAll x [a] + +----------------------------------------- +-- SetAttr and AppendChild + +-- | Set attributes. +instance SetAttr HSP' XML where + setAll xml hats = do + attrs <- hats + case xml of + CDATA _ -> return xml + Element n as cs -> return $ Element n (foldr insert as attrs) cs + + +instance TypeCast (m x) (HSP' XML) + => SetAttr HSP' (XMLGenT m x) where + setAll (XMLGenT hxml) ats = (XMLGenT $ typeCast hxml) >>= \xml -> setAll xml ats + +-- | Append children. +instance AppendChild HSP' XML where + appAll xml children = do + chs <- children + case xml of + CDATA _ -> return xml + Element n as cs -> return $ Element n as (cs ++ chs) + +instance TypeCast (m x) (HSP' XML) + => AppendChild HSP' (XMLGenT m x) where + appAll (XMLGenT hxml) chs = (XMLGenT $ typeCast hxml) >>= (flip appAll) chs + +--------------- +-- GetAttrValue + +-- | Instantiate this class to enable values of the given type +-- to be retrieved through attribute patterns. +class GetAttrValue a where + fromAttrValue :: AttrValue -> a + +-- | An AttrValue is trivial. +instance GetAttrValue AttrValue where + fromAttrValue = id + +-- | Strings can be directly taken from values. +instance GetAttrValue String where + fromAttrValue (Value s) = s + +-- | Anything that can be read can always fall back on +-- that as a default behavior. +instance (Read a) => GetAttrValue a where + fromAttrValue = read . fromAttrValue + +-- | An IO computation returning something that can be represented +-- as an attribute value can be lifted into an analogous HSP computation. +--instance (GetAttrValue a, Monad m) => GetAttrValue (m a) where +-- fromAttrValue = return . fromAttrValue + +-- | The common way to present list data in attributes is as +-- a comma separated, unbracketed sequence +instance (GetAttrValue a) => GetAttrValue [a] where + fromAttrValue v@(Value str) = case str of + [/ v1+, (/ ',', vs@:_+ /)+ /] -> + map (fromAttrValue . Value) (v1:vs) + _ -> [fromAttrValue v] + +-- All that for these two functions +extract :: (GetAttrValue a) => Name -> Attributes -> (Maybe a, Attributes) +extract _ [] = (Nothing, []) +extract name (p@(n, v):as) + | name == n = (Just $ fromAttrValue v, as) + | otherwise = let (val, attrs) = extract name as + in (val, p:attrs) + + +-------------------------------------------------------------------- +-- The base XML generation, corresponding to the use of the literal +-- XML syntax. + +-- | Generate an XML element from its components. +element :: (IsName n, IsXMLs xmls, IsAttribute at) => n -> [at] -> xmls -> HSP XML +element n attrs xmls = do + cxml <- toXMLs xmls + attribs <- mapM toAttribute attrs + return $ Element (toName n) + (foldr insert eAttrs attribs) + (flattenCDATA cxml) + + where flattenCDATA :: [XML] -> [XML] + flattenCDATA cxml = + case flP cxml [] of + [] -> [] + [CDATA ""] -> [] + xs -> xs + flP :: [XML] -> [XML] -> [XML] + flP [] bs = reverse bs + flP [x] bs = reverse (x:bs) + flP (x:y:xs) bs = case (x,y) of + (CDATA s1, CDATA s2) -> flP (CDATA (s1++s2) : xs) bs + _ -> flP (y:xs) (x:bs) + +eAttrs :: Attributes +eAttrs = [] +insert :: Attribute -> Attributes -> Attributes +insert = (:) + +-- | Generate an empty XML element. +eElement :: (IsName n, IsAttribute at) => n -> [at] -> HSP XML +eElement n attrs = element n attrs ([] :: [XML]) +
− HTTP/Common.hs
@@ -1,45 +0,0 @@-module HTTP.Common where--import HTTP.Util- -newtype HTTPVersion = HTTPVersion (Int, Int)--instance Show HTTPVersion where- showsPrec _ (HTTPVersion (maj, min))- = showString "HTTP/" .- shows maj .- showString "." .- shows min- -newtype Header = Header (FieldName, FieldValue)--instance Show Header where- showsPrec _ (Header (fn, fv)) - = showString fn .- showString ": " .- showString fv .- showsCRLF- showList [] = showString ""- showList (hdr:hdrs)- = shows hdr .- showList hdrs--type FieldName = String-type FieldValue = String--data MessageBody = EmptyBody | MessageBody String--instance Show MessageBody where- show EmptyBody = ""- show (MessageBody str) = str--infixr 9 .|.--(.|.) :: (b -> c, b1 -> c1) -> (a -> b,a1 -> b1) -> (a, a1) -> (c, c1)-((f1, f2) .|. (g1, g2)) (x1,x2) = (f1 . g1 $ x1, f2 . g2 $ x2)--app :: (a -> b, a1 -> b1) -> (a, a1) -> (b, b1)-app (f, g) (x, y) = (f x, g y)--dup :: a -> (a,a)-dup a = (a,a)
− HTTP/Request.hs
@@ -1,152 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------------- |--- Module : HTTP.Request--- Copyright : (c) Andreas Farre, Niklas Broberg, 2004--- License : BSD-style (see the file LICENSE.txt)------ Maintainer : Andreas Farre, d00farre@dtek.chalmers.se,--- Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : portable------ Datatypes representing the concept of an HTTP request.-------------------------------------------------------------------------------module HTTP.Request (- -- * Datatypes- Request(..)- , Method(..)- , RequestURI(..)- , HTTPVersion(..)- , Header(..)- , MessageBody(..)-- -- * Parsing- , parseRequest -- :: String -> Maybe Request- ) where--import Data.Char ( isDigit )--import Data.List ( isPrefixOf )-import Network.URI--import HTTP.Common-import HTTP.Util------------------------------------------------------------ Datatypes---- | An HTTP request-data Request- = Request {- reqMethod :: Method,- reqURI :: RequestURI,- reqVersion :: HTTPVersion,- reqHeaders :: [Header],- reqMessageBody :: MessageBody- }--instance Show Request where- showsPrec n req = -- parensIf (n > 0) $- shows (reqMethod req) .- showsSpace .- shows (reqURI req) .- showsSpace .- shows (reqVersion req) .- showsCRLF .- shows (reqHeaders req) .- shows (reqMessageBody req)-{-- where parensIf b s =- if b then showChar '(' . s . showChar ')'- else s--}--data Method- = OPTIONS- | GET- | HEAD- | POST- | PUT- | DELETE- | TRACE- | CONNECT- | ExtensionMethod String- deriving (Eq, Show, Read)--data RequestURI- = NoURI- | AbsURI URI- | AbsPath FilePath--instance Show RequestURI where- show NoURI = "*"- show (AbsURI uri) = show uri- show (AbsPath path) = path------------------------------------------------------------- Parsing requests in string format--parseRequest :: String -> Maybe Request-parseRequest str =- case crlines $ killLWS str of- (rqline:hdrstrs) ->- case words rqline of- [m, u, v] ->- let muri = parseRURI u- mver = parseVersion v- mhds = parseHeaders hdrstrs- in case (muri, mver, mhds) of- (Just uri, Just ver, Just hds) ->- Just $ Request- (parseMethod m)- uri- ver- hds- EmptyBody -- TODO: this is wrong, and dangerous- _ -> Nothing- _ -> Nothing- _ -> Nothing-- where parseMethod :: String -> Method- parseMethod m- = case m of- "GET" -> GET- "POST" -> POST- "OPTIONS" -> OPTIONS- "HEAD" -> HEAD- "PUT" -> PUT- "DELETE" -> DELETE- "TRACE" -> TRACE- "CONNECT" -> CONNECT- str -> ExtensionMethod str-- parseRURI :: String -> Maybe RequestURI- parseRURI ruri =- case ruri of- "*" -> Just NoURI- ('/':_) -> Just $ AbsPath ruri- (x:_) | Just uri <- parseURI ruri- -> Just $ AbsURI uri- "" -> Just $ AbsPath "/"- _ -> Nothing-- -- Is this one really correct?- -- It will do the right thing on a correct version spec, but- -- isn't it possible to fool it?- parseVersion :: String -> Maybe HTTPVersion- parseVersion v- | "HTTP" `isPrefixOf` v- = let (maj, rest) = span isDigit $ dropWhile (not . isDigit) v- min = takeWhile isDigit $ dropWhile (not . isDigit) rest- in Just $ HTTPVersion (read maj, read min)- | otherwise = Just $ HTTPVersion (9, 9) -- huh?- | otherwise = Nothing-- parseHeaders :: [String] -> Maybe [Header]- parseHeaders [] = Just []- parseHeaders (str:strs) =- case str of- [/ fn*, ':', fv* /] -> fmap ((Header (fn, fv)):) $ parseHeaders strs- _ -> Nothing
− HTTP/Response.hs
@@ -1,61 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HTTP.Response--- Copyright : (c) Andreas Farre, Niklas Broberg, 2004--- License : BSD-style (see the file LICENSE.txt)--- --- Maintainer : Andreas Farre, d00farre@dtek.chalmers.se,--- Niklas Broberg, d00nibro@dtek.chalmers.se--- Stability : experimental--- Portability : portable------ Datatypes representing the concept of an HTTP response.-------------------------------------------------------------------------------module HTTP.Response (- -- * Datatypes- Response(..)- , HTTPVersion(..)- , StatusCode(..)- , Reason -- (..) will be a datatype soon, no?- , Header(..)- , MessageBody(..)- ) where--import HTTP.Common-import HTTP.Util--import Data.Char ( intToDigit )--data Response - = Response {- respVersion :: HTTPVersion,- respStatus :: StatusCode,- respReason :: Reason,- respHeaders :: [Header],- respBody :: MessageBody- } --instance Show Response where- showsPrec _ resp- = shows (respVersion resp) .- showsSpace .- shows (respStatus resp) .- showsSpace .- showString (respReason resp) .- showsCRLF .- shows (respHeaders resp) .- showsCRLF .- shows (respBody resp) .- showsCRLF .- showsCRLF---newtype StatusCode - = StatusCode (Int, Int, Int)--instance Show StatusCode where- show (StatusCode (a,b,c))- = map intToDigit [a,b,c]--type Reason = String-
− HTTP/Util.hs
@@ -1,31 +0,0 @@-module HTTP.Util where--import Data.Char(isSpace)---emptyline :: String -> Bool-emptyline "\r" = True-emptyline _ = False---killLWS :: String -> String-killLWS "" = ""-killLWS ('\r':c:xs)- | isSpace c = killLWS (c:xs)-killLWS (c0:c1:xs)- | isSpace c0 && isSpace c1 = killLWS (' ':xs)-killLWS (x:xs) = x : killLWS xs---crlines :: String -> [String]-crlines "" = []-crlines str = l : (crlines $ dropWhile (=='\r') ls)- where- (l, ls) = break (=='\r') str--showsSpace :: ShowS-showsSpace = showString " "- -showsCRLF :: ShowS-showsCRLF = showString "\r\n"-
hsp.cabal view
@@ -1,14 +1,12 @@ Name: hsp-Version: 0.2+Version: 0.4 License: BSD3 License-File: LICENSE-Author: Niklas Broberg-Maintainer: nibro@cs.chalmers.se-Author: Niklas Broberg+Author: Niklas Broberg, Joel Björnson Maintainer: Niklas Broberg <nibro@cs.chalmers.se> Stability: Experimental-Category: Language+Category: Web, Language Synopsis: Haskell Server Pages is a library for writing dynamic server-side web pages. Description: Haskell Server Pages (HSP) is an extension of vanilla Haskell, targetted at the task of writing dynamic server-side web pages. Features include:@@ -17,42 +15,22 @@ . * A (low-to-mid-level) programming model for writing dynamic web pages .- * A runtime system, in the guise of a server utility, with support for:- .- o session (through cookies) and application (through the server) state- .- o interfacing to the HTTP request-response model- .- o on-request compilation of pages (using hs-plugins)- .- * A cgi-handler utility for use where the server can't be used- (i.e. if you have no control over the resident web server).- Supports everything the server does except application state and- setting outgoing headers (plus it is atm considerably slower to respond).- .- You will also want 'hspr', the runtime utilities package. Consists of (the source for)- a server utility hspr and a cgi-handler hspr-cgi.+ * A cgi-handler utility (as a separate package, hsp-cgi) . For details on usage, please see the website, and the author's thesis.-Homepage: http://www.cs.chalmers.se/~d00nibro/hsp/+Homepage: http://code.google.com/p/hsp -Build-Depends: base>3, mtl, network, harp, haskell-src-exts, old-time, containers--- , trhsx+Build-Depends: base>3, mtl, harp, hsx, HJScript Build-Type: Simple Tested-With: GHC==6.8.3 -Exposed-Modules: HSP, HSP.Application, HSP.Request, HSP.Response,- HSP.Session, HSP.Exception,- HSP.Data, HSP.Data.Application, HSP.Data.Session,- HSP.Data.RequestEnv, HSP.Data.Response,- HSP.Data.XML, HSP.Data.PCDATA, HSP.Data.CSS,- CGI.CGIEnv,- HTTP.Common, HTTP.Request, HTTP.Response,- HTTP.Util+Exposed-Modules: HSP.XML, HSP.XML.PCDATA, HSP.Env, HSP.Env.Request, HSP.Env.NumberGen, HSP.HJScript, HSP+Other-Modules: HSP.Exception, HSP.Monad, HSP.XMLGenerator GHC-Options: -F -pgmFtrhsx -Wall Extensions: MultiParamTypeClasses, FunctionalDependencies,+ TypeFamilies, RankNTypes, PolymorphicComponents, ExistentialQuantification,