hsp (empty) → 0.2
raw patch · 22 files changed
+1869/−0 lines, 22 filesdep +basedep +containersdep +harpsetup-changed
Dependencies added: base, containers, harp, haskell-src-exts, mtl, network, old-time
Files
- CGI/CGIEnv.hs +86/−0
- HSP.hs +24/−0
- HSP/Application.hs +48/−0
- HSP/Data.hs +537/−0
- HSP/Data/Application.hs +48/−0
- HSP/Data/CSS.hs +58/−0
- HSP/Data/PCDATA.hs +22/−0
- HSP/Data/RequestEnv.hs +152/−0
- HSP/Data/Response.hs +37/−0
- HSP/Data/Session.hs +197/−0
- HSP/Data/XML.hs +117/−0
- HSP/Exception.hs +28/−0
- HSP/Request.hs +62/−0
- HSP/Response.hs +25/−0
- HSP/Session.hs +43/−0
- HTTP/Common.hs +45/−0
- HTTP/Request.hs +152/−0
- HTTP/Response.hs +61/−0
- HTTP/Util.hs +31/−0
- LICENSE +28/−0
- Setup.hs +2/−0
- hsp.cabal +66/−0
+ CGI/CGIEnv.hs view
@@ -0,0 +1,86 @@+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
@@ -0,0 +1,24 @@+{-# 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
+ HSP/Application.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,537 @@+{-# 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 view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,58 @@+{-# 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 view
@@ -0,0 +1,22 @@+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 view
@@ -0,0 +1,152 @@+{-# 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 view
@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,117 @@+{-# 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/Exception.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : HSP.Exception+-- 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 a datatype for runtime exceptions that may arise during+-- the evaluation of a HSP page.+-----------------------------------------------------------------------------+module HSP.Exception where++import Data.Typeable++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+ -- that failed.++ deriving (Eq, Show, Typeable)+
+ HSP/Request.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ HTTP/Common.hs view
@@ -0,0 +1,45 @@+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 view
@@ -0,0 +1,152 @@+{-# 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 view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,31 @@+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"+
+ LICENSE view
@@ -0,0 +1,28 @@+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hsp.cabal view
@@ -0,0 +1,66 @@+Name: hsp+Version: 0.2+License: BSD3+License-File: LICENSE+Author: Niklas Broberg+Maintainer: nibro@cs.chalmers.se+Author: Niklas Broberg+Maintainer: Niklas Broberg <nibro@cs.chalmers.se>++Stability: Experimental+Category: 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:+ .+ * Embedded XML syntax+ .+ * 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.+ .+ For details on usage, please see the website, and the author's thesis.+Homepage: http://www.cs.chalmers.se/~d00nibro/hsp/++Build-Depends: base>3, mtl, network, harp, haskell-src-exts, old-time, containers+-- , trhsx+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++GHC-Options: -F -pgmFtrhsx -Wall+Extensions: MultiParamTypeClasses,+ FunctionalDependencies,+ RankNTypes,+ PolymorphicComponents,+ ExistentialQuantification,+ FlexibleContexts,+ FlexibleInstances,+ EmptyDataDecls,+ CPP,+ TypeSynonymInstances,+ OverlappingInstances,+ UndecidableInstances,+ PatternGuards