diff --git a/CGI/CGIEnv.hs b/CGI/CGIEnv.hs deleted file mode 100644 --- a/CGI/CGIEnv.hs +++ /dev/null @@ -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" - ] diff --git a/HSP.hs b/HSP.hs --- a/HSP.hs +++ b/HSP.hs @@ -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 diff --git a/HSP/Application.hs b/HSP/Application.hs deleted file mode 100644 --- a/HSP/Application.hs +++ /dev/null @@ -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 () diff --git a/HSP/Data.hs b/HSP/Data.hs deleted file mode 100644 --- a/HSP/Data.hs +++ /dev/null @@ -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) = - -------------- --- 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 - diff --git a/HSP/Data/Application.hs b/HSP/Data/Application.hs deleted file mode 100644 --- a/HSP/Data/Application.hs +++ /dev/null @@ -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 () diff --git a/HSP/Data/CSS.hs b/HSP/Data/CSS.hs deleted file mode 100644 --- a/HSP/Data/CSS.hs +++ /dev/null @@ -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 ++ " }" diff --git a/HSP/Data/PCDATA.hs b/HSP/Data/PCDATA.hs deleted file mode 100644 --- a/HSP/Data/PCDATA.hs +++ /dev/null @@ -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" ) - ] diff --git a/HSP/Data/RequestEnv.hs b/HSP/Data/RequestEnv.hs deleted file mode 100644 --- a/HSP/Data/RequestEnv.hs +++ /dev/null @@ -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 --} diff --git a/HSP/Data/Response.hs b/HSP/Data/Response.hs deleted file mode 100644 --- a/HSP/Data/Response.hs +++ /dev/null @@ -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 diff --git a/HSP/Data/Session.hs b/HSP/Data/Session.hs deleted file mode 100644 --- a/HSP/Data/Session.hs +++ /dev/null @@ -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 diff --git a/HSP/Data/XML.hs b/HSP/Data/XML.hs deleted file mode 100644 --- a/HSP/Data/XML.hs +++ /dev/null @@ -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 "') - 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 ' ') - diff --git a/HSP/Env.hs b/HSP/Env.hs new file mode 100644 --- /dev/null +++ b/HSP/Env.hs @@ -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 diff --git a/HSP/Env/NumberGen.hs b/HSP/Env/NumberGen.hs new file mode 100644 --- /dev/null +++ b/HSP/Env/NumberGen.hs @@ -0,0 +1,3 @@ +module HSP.Env.NumberGen where + +data NumberGen = NumberGen { incNumber :: IO Int } diff --git a/HSP/Env/Request.hs b/HSP/Env/Request.hs new file mode 100644 --- /dev/null +++ b/HSP/Env/Request.hs @@ -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 diff --git a/HSP/Exception.hs b/HSP/Exception.hs --- a/HSP/Exception.hs +++ b/HSP/Exception.hs @@ -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 diff --git a/HSP/HJScript.hs b/HSP/HJScript.hs new file mode 100644 --- /dev/null +++ b/HSP/HJScript.hs @@ -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 $ + + +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 diff --git a/HSP/Monad.hs b/HSP/Monad.hs new file mode 100644 --- /dev/null +++ b/HSP/Monad.hs @@ -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)) diff --git a/HSP/Request.hs b/HSP/Request.hs deleted file mode 100644 --- a/HSP/Request.hs +++ /dev/null @@ -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 diff --git a/HSP/Response.hs b/HSP/Response.hs deleted file mode 100644 --- a/HSP/Response.hs +++ /dev/null @@ -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 diff --git a/HSP/Session.hs b/HSP/Session.hs deleted file mode 100644 --- a/HSP/Session.hs +++ /dev/null @@ -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 diff --git a/HSP/XML.hs b/HSP/XML.hs new file mode 100644 --- /dev/null +++ b/HSP/XML.hs @@ -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 "') + 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 ' ') + diff --git a/HSP/XML/PCDATA.hs b/HSP/XML/PCDATA.hs new file mode 100644 --- /dev/null +++ b/HSP/XML/PCDATA.hs @@ -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)) diff --git a/HSP/XMLGenerator.hs b/HSP/XMLGenerator.hs new file mode 100644 --- /dev/null +++ b/HSP/XMLGenerator.hs @@ -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]) + diff --git a/HTTP/Common.hs b/HTTP/Common.hs deleted file mode 100644 --- a/HTTP/Common.hs +++ /dev/null @@ -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) diff --git a/HTTP/Request.hs b/HTTP/Request.hs deleted file mode 100644 --- a/HTTP/Request.hs +++ /dev/null @@ -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 diff --git a/HTTP/Response.hs b/HTTP/Response.hs deleted file mode 100644 --- a/HTTP/Response.hs +++ /dev/null @@ -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 - diff --git a/HTTP/Util.hs b/HTTP/Util.hs deleted file mode 100644 --- a/HTTP/Util.hs +++ /dev/null @@ -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" - diff --git a/hsp.cabal b/hsp.cabal --- a/hsp.cabal +++ b/hsp.cabal @@ -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 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,