hpc-tracer 0.3.0 → 0.3.1
raw patch · 5 files changed
+769/−3 lines, 5 files
Files
- Makefile +51/−0
- hpc-tracer.cabal +6/−3
- src/Data/JSON.hs +196/−0
- src/Network/AjaxServer.hs +403/−0
- src/Network/TrivialWebServer.hs +113/−0
+ Makefile view
@@ -0,0 +1,51 @@+HPC_ROOT=.++CABAL=runhaskell Setup.hs++.PHONY: all test build configure inplace-install clean++all:: configure build install++configure::+ $(CABAL) configure $(ARGS)++build:: + $(CABAL) build $(ARGS)++install::+ $(CABAL) install++inplace-install::+ $(CABAL) copy --destdir="inplace"++test:: inplace-install+ make -C tests test++clean::+ rm -Rf ./dist+ rm -f src/CachedFiles.hs++CACHED = fs/root.html \+ fs/footer.html \+ fs/header.html \+ fs/status.html \+ fs/code.html \+ fs/default.js \+ fs/default.css \+ fs/favicon.ico \++boot:: src/CachedFiles.hs++src/CachedFiles.hs: $(CACHED) includefile.pl+ echo "module CachedFiles where" > $@+ perl ./includefile.pl root_html < fs/root.html >> $@+ perl ./includefile.pl footer_html < fs/footer.html >> $@+ perl ./includefile.pl header_html < fs/header.html >> $@+ perl ./includefile.pl code_html < fs/code.html >> $@+ perl ./includefile.pl status_html < fs/status.html >> $@+ perl ./includefile.pl default_js < fs/default.js >> $@+ perl ./includefile.pl default_css < fs/default.css >> $@+ perl ./includefile.pl favicon -bin < fs/favicon.ico >> $@+ perl ./includefile.pl progress -bin < fs/progressbar_green.gif \+ >> $@+
hpc-tracer.cabal view
@@ -1,11 +1,10 @@ name: hpc-tracer-version: 0.3.0+version: 0.3.1 license: BSD3 license-file: LICENSE Build-depends: base, hpc, unix, parsec, haskell98, network, process, containers, pretty, array author: Andy Gill <andygill@ku.edu> maintainer: Andy Gill <andygill@ku.edu>-homepage: http://darcs.unsafePerformIO.com/hpc-tracer category: Trace, Test Synopsis: Tracer with AJAX interface description:@@ -20,6 +19,7 @@ Stability: builds build-type: Simple extra-source-files:+ Makefile includefile.pl fs/code.html fs/default.css@@ -39,5 +39,8 @@ AjaxAPI,Debug,Reactive,TracerActor BreakPoint,Flags,StreamHandle,Utils CodeRenderActor,Main,TixActor- Common,MixActor,TixStreamActor+ Common,MixActor,TixStreamActor,+ Network.AjaxServer, Network.TrivialWebServer,+ Data.JSON+
+ src/Data/JSON.hs view
@@ -0,0 +1,196 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.JSON+-- Copyright : (c) Masahiro Sakai & Jun Mukai 2006+-- License : BSD-style+-- +-- Maintainer : sakai@tom.sfc.keio.ac.jp+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++-- AJG: moved JSON to Data.JSON+-- change Number into Int and Double +-- 1.0 and 1 are not quite the same thing in Javascript,+-- see json-wheel: JSON library for OCaml for more details.++module Data.JSON+ ( Value (..)+ , object+ , parse+ , json+ , stringify+ , stringify'+ , toDoc+ , toDoc'+ , M.toList+ , M.fromList+ , M.lookup+ , M.Map+ ) where++import Control.Monad hiding (join)+import Text.ParserCombinators.Parsec hiding (parse)+import qualified Text.ParserCombinators.Parsec as P+import Text.PrettyPrint.HughesPJ hiding (char)+import Text.Printf (printf)+import Data.Char (ord, chr, isControl)+import Data.List (unfoldr)+import Data.Bits+import qualified Data.Map as M++-- ---------------------------------------------------------------------------+-- The Value data type++data Value+ = String String+ | Double !Double+ | Int !Int+ | Object !(M.Map String Value)+ | Array [Value]+ | Bool !Bool+ | Null+ deriving (Eq,Show)++{-+instance Show Value where+ showsPrec p = showsPrec p . toDoc+-}++-- ---------------------------------------------------------------------------+-- The JSON Parser++parse :: String -> Maybe Value+parse s = case P.parse json "JSON.parse" s of+ Left err -> Nothing+ Right v -> Just v++json :: Parser Value+json = spaces >> tok value++tok :: Parser a -> Parser a+tok p = do{ x <- p; spaces; return x }++value :: Parser Value+value = msum+ [ liftM String str+ , number+ , liftM Object object+ , liftM Array array + , string "true" >> return (Bool True)+ , string "false" >> return (Bool False)+ , string "null" >> return Null+ ]++str :: Parser String+str = liftM decodeSurrogatePairs $+ between (char '"') (char '"') $ many c1+ where c1 = satisfy (\c -> not (c=='"' || c=='\\' || isControl c))+ <|> (char '\\' >> c2)+ c2 = msum+ [ char '"'+ , char '\\'+ , char '/'+ , char 'b' >> return '\b'+ , char 'f' >> return '\f'+ , char 'n' >> return '\n'+ , char 'r' >> return '\r'+ , char 't' >> return '\t'+ , char 'u' >> do xs <- count 4 hexDigit+ return $ read $ "'\\x"++xs++"'"+ ]++number :: Parser Value+number = do { i <- int + ; opt <- option "" frac >>+ option "" exp+ ; if null opt+ then return $ Int (read i)+ else return $ Double (read $ i ++ opt)+ }+ where digits = many1 digit+ int = option "" (string "-") >>+ digits+ frac = char '.' >>: digits+ exp = e >>+ digits+ e = oneOf "eE" >>: option "" (string "+" <|> string "-")+ (>>+) = liftM2 (++)+ (>>:) = liftM2 (:)++object :: Parser (M.Map String Value)+object = liftM M.fromList $+ between (tok (char '{')) (char '}') $+ tok member `sepBy` tok (char ',')+ where member = do k <- tok str+ tok (char ':')+ v <- value+ return (k,v)++array :: Parser [Value]+array = between (tok (char '[')) (char ']') $+ tok value `sepBy` tok (char ',')++decodeSurrogatePairs :: String -> String+decodeSurrogatePairs = unfoldr phi+ where+ phi :: String -> Maybe (Char, String)+ phi (h:l:xs)+ | '\xD800' <= h && h <= '\xDBFF' && '\xDC00' <= l && l <= '\xDFFF'+ = seq c $ Just (c, xs)+ where c = chr $ ((ord h .&. 1023) `shiftL` 10 .|. ord l .&. 1023) + 0x10000+ phi (x:xs) = Just (x, xs)+ phi [] = Nothing++-- ---------------------------------------------------------------------------+-- The JSON Printer++stringify :: Value -> String+stringify = stringify' (const False) ++stringify' :: (Char -> Bool) -> Value -> String+stringify' needEscape = show . toDoc' needEscape++toDoc :: Value -> Doc+toDoc = toDoc' (const False)++toDoc' :: (Char -> Bool) -> Value -> Doc+toDoc' needEscape = go+ where+ go :: Value -> Doc+ go (String s) = strToDoc s+ go (Int x) = int x+ go (Double x)+ | isInfinite x = error "can't stringify infinity"+ | isNaN x = error "can't stringify NaN"+ | otherwise = double x+ go (Object m) = lbrace <+> join comma members $+$ rbrace+ where members = [fsep [strToDoc k <> colon, nest 2 (go v)]+ | (k,v) <- M.toList m]+ go (Array xs) = lbrack <+> join comma (map go xs) <+> rbrack+ go (Bool b) = text $ if b then "true" else "false"+ go Null = text "null"++ strToDoc :: String -> Doc+ strToDoc = doubleQuotes . text . concatMap f+ where f '"' = "\\\""+ f '\\' = "\\\\"+ f '\b' = "\\b"+ f '\f' = "\\f"+ f '\n' = "\\n"+ f '\r' = "\\r"+ f '\t' = "\\t"+ f c | isControl c || needEscape c =+ if c < '\x10000'+ then printf "\\u%04x" c+ else case makeSurrogatePair c of+ (h,l) -> printf "\\u%04x\\u%04x" h l+ | otherwise = [c]++join :: Doc -> [Doc] -> Doc+join s = fcat . punctuate s++makeSurrogatePair :: Char -> (Char,Char)+makeSurrogatePair c = (chr h, chr l)+ where c' = ord c+ h = (c' - 0x10000) `shiftR` 10 .|. 0xd800+ l = c' .&. 1023 .|. 0xdc00+
+ src/Network/AjaxServer.hs view
@@ -0,0 +1,403 @@+module Network.AjaxServer + ( (<*>)+ , call+ , intArg+ , boolArg+ , stringArg+ , readArg+ , jsonArg+ , AjaxParser+ , ajaxServer+ , withMethod+ , alts+ , PageResponse(..)+ , AjaxCallback -- abstract+ , (<@>)+ , ajaxCallback+ , JSON(..) -- a class+ , altsJSON+ , findJSON+ ) where ++++import Data.List+import Data.Maybe+import qualified Data.Map as M+import Data.JSON as JSON+import Control.Monad+import Network.TrivialWebServer++------------------------------------------------------------------------------++-- This is our dictionary like thing.+data AjaxTypeDict a = AjaxTypeDict+ { decodeATD :: String -> Either String a+ , encodeATD :: String -> String+ , nameATD :: String+ }++data AjaxAPI = API_Name String+ | forall a . API_Arg String (AjaxTypeDict a) -- argument name and type+ | API_Join AjaxAPI AjaxAPI+ | API_Alt [AjaxAPI]+++data Request = Request + { reqMethod :: String + , reqURL :: String+ , reqArgs :: [(String,String)]+ , reqBody :: String+ }++data AjaxParser a = AjaxParser AjaxAPI+ (Request -> Either [AjaxParserFailure] a)++data AjaxParserFailure+ = NotCorrectMethod String String -- what you found, what you expected+ | WrongCallName String String+ | ArgumentMissing String+ | DecodeError String String -- what you found, what you expected + deriving Show++alts :: [AjaxParser a] -> AjaxParser a+alts as = AjaxParser (API_Alt (map (\ (AjaxParser a _ ) -> a) as))+ $ \ state -> + let+ res = map (\ (AjaxParser _ f) -> f state) as+ in + case [ r | Right r <- res ] of+ (ans:_) -> Right ans+ [] -> Left $ concat [ e | Left e <- res ]+ ++withMethod :: String -> AjaxParser a -> AjaxParser a+withMethod method (AjaxParser apis fn) = AjaxParser apis fn -- debugging version+{-+withMethod method (AjaxParser apis fn) = AjaxParser apis $ \ req ->+ if reqMethod req == method + then fn req+ else Left $ [NotCorrectMethod (reqMethod req) method]+-} ++infixr 4 <*>++(<*>) :: AjaxParser a -> AjaxParser (a -> b) -> AjaxParser b+(<*>) (AjaxParser ys q) + (AjaxParser xs p) + = AjaxParser (API_Join xs ys) $ \ req ->+ case p req of+ Right f -> case q req of+ Right a -> Right (f a)+ Left msg -> Left msg+ Left msg -> Left msg++call :: String -> a -> AjaxParser a+call apiName caller = AjaxParser (API_Name apiName)+ $ \ req -> if reqURL req == ("/" ++ apiName)+ then Right caller+ else Left [WrongCallName (reqURL req) apiName]++argument :: AjaxTypeDict a -> String -> AjaxParser a+argument ty@(AjaxTypeDict _ _ tyName) str = res+ where+ res = AjaxParser (API_Arg str ty)+ $ \ req -> + case Data.List.lookup str (reqArgs req) of+ Just val -> case decodeATD ty val of+ Right a -> Right a+ Left r -> Left [ DecodeError str tyName ]+ Nothing -> Left [ ArgumentMissing $ show str ]++intArg :: String -> AjaxParser Int+intArg = argument intATD+boolArg :: String -> AjaxParser Bool+boolArg = argument boolATD+stringArg :: String -> AjaxParser String+stringArg = argument stringATD+readArg :: (Read a) => String -> AjaxParser a+readArg = argument readATD++jsonArg :: (JSON a) => String -> AjaxParser a+jsonArg = argument jsonATD++------------------------------------------------------------------------------++getAllFuns :: AjaxParser a -> [AjaxAPI]+getAllFuns (AjaxParser apis _) = findAllFuns apis++findAllFuns :: AjaxAPI -> [AjaxAPI]+findAllFuns (API_Alt alts) = concatMap findAllFuns alts+findAllFuns other = [other]++ajaxURLCodeGen :: AjaxAPI -> String+ajaxURLCodeGen api = + "// usage: " ++ fixName name ++ "(" ++ tyList ++ ")\n" +++ "function " ++ fixName name ++ "(" ++ argList ++ ") {\n" +++ " return \"/" ++ name ++ (if null callList + then ""+ else "?" ++ callList)+ ++ "\";\n" +++ "}\n" + where+ fixName = concatMap $ \ c -> case c of + '/' -> "_"+ c -> [c]+ callList = concat+ $ intersperse "&"+ [ arg ++ "=" ++ "\" + " ++ (encodeATD ty) arg ++ " + \""+ | API_Arg arg ty <- findArgs api + ] ++ tyList = concat + $ intersperse "," + [ nameATD ty+ | API_Arg arg ty <- findArgs api + ]+ argList = concat + $ intersperse "," + [ arg + | API_Arg arg ty <- findArgs api + ]++ Just name = findName api++ findName :: AjaxAPI -> Maybe String+ findName (API_Name str) = return str+ findName (API_Arg _ _) = Nothing+ findName (API_Join a1 a2) = + case findName a1 of + Nothing -> findName a2+ Just res -> return res++ findArgs :: AjaxAPI -> [AjaxAPI]+ findArgs (API_Name str) = []+ findArgs (API_Arg arg ty) = [API_Arg arg ty]+ findArgs (API_Join a1 a2) = findArgs a1 ++ findArgs a2+++ajaxFunCodeGen :: AjaxAPI -> String+ajaxFunCodeGen api = + "// usage: " ++ fixName name ++ "(" ++ tyList ++ ")\n" +++ "function " ++ fixName name ++ "(" ++ argList ++ ") {\n" +++ " send(\"/" ++ name ++ "\",\"" ++ callList ++ "\");\n" +++ "}\n" + where+ fixName = concatMap $ \ c -> case c of + '/' -> "_"+ c -> [c]++ callList = concat+ $ intersperse "&"+ [ arg ++ "=" ++ "\" + " ++ (encodeATD ty) arg ++ " + \""+ | API_Arg arg ty <- findArgs api + ] ++ tyList = concat + $ intersperse "," + [ nameATD ty+ | API_Arg arg ty <- findArgs api + ]+ argList = concat + $ intersperse "," + [ arg + | API_Arg arg ty <- findArgs api + ]++ Just name = findName api++ findName :: AjaxAPI -> Maybe String+ findName (API_Name str) = return str+ findName (API_Arg _ _) = Nothing+ findName (API_Join a1 a2) = + case findName a1 of + Nothing -> findName a2+ Just res -> return res++ findArgs :: AjaxAPI -> [AjaxAPI]+ findArgs (API_Name str) = []+ findArgs (API_Arg arg ty) = [API_Arg arg ty]+ findArgs (API_Join a1 a2) = findArgs a1 ++ findArgs a2++------------------------------------------------------------------------------++intATD :: AjaxTypeDict Int+intATD = AjaxTypeDict (\ a -> Right (read a))+ (\ a -> a)+ "int"++boolATD :: AjaxTypeDict Bool+boolATD = AjaxTypeDict (\ a -> if a == "true" then Right True+ else if a == "false" then Right False+ else Left ("error finding bool: " ++ show a))+ (\ a -> a)+ "bool"++stringATD :: AjaxTypeDict String+stringATD = AjaxTypeDict + (\ a -> Right a)+ (\ a -> "escape(" ++ a ++ ")")+ "string"++readATD :: (Read a) => AjaxTypeDict a+readATD = AjaxTypeDict + (\ a -> case reads a of+ [(r,"")] -> Right $ r+ _ -> Left $ "read error with : " ++ show a)+ (\ a -> "escape(" ++ a ++ ")")+ "(Read a)"++jsonATD :: (JSON a) => AjaxTypeDict a+jsonATD = AjaxTypeDict + (\ a -> case parse a of+ Just json ->+ case fromJSON json of+ Just r -> Right $ r+ _ -> Left $ "coerse error with : " ++ show json+ _ -> Left $ "parse error with : " ++ show a)+ (\ a -> "escape(" ++ a ++ ".toJSONString())")+ "(JSON a)"++------------------------------------------------------------------------------++type URLPath = String+type ContentType = String++data PageResponse = PageResponse Int Bool ContentType String++-- :: [(String,String,AjaxAction PageResponse)]+-- -> [(String,String,AjaxAction PageResponse)]++ajaxServer' :: Int -- ^ port+ -> (String -> [(String,String)] -> IO PageResponse) -- POST+ -> (String -> [(String,String)] -> IO PageResponse) -- GET+ -> IO ()+ajaxServer' portNum fn = undefined++ajaxServer :: Int -- ^ port+ -> (AjaxParser (IO [AjaxCallback])) -- POST, typically+ -> (AjaxParser (IO PageResponse)) -- GET+ -> (String -> IO PageResponse) -- GET, ignore after ?...+ -> IO ()+ajaxServer portNum rpcs pageRpcs getPage = do+-- putStrLn $ ajax_code+ server 8 portNum $ Server $ \ url args send -> do + let req = Request "GET" url args ""+-- print (url,args)+ case url of+ -- The magic page+ "/ajax.js" -> + respondWithPage (return (PageResponse+ 200+ False -- for now+ "text/js"+ ajax_code+ )) send+ _ -> case rpc_parser req of+ Right fn -> do+ callbacks <- fn+ respondWithPage (return (PageResponse+ 200+ False -- always+ "text/js"+ (renderCallbacks callbacks)))+ send+ Left msg -> do+-- print msg -- for now+ case pageRpc_parser req of+ Right fn ->+ respondWithPage fn send+ Left _ ->+ respondWithPage (getPage url) send+ where+ respondWithPage pageResFn send = do+ PageResponse code cache ty body <- pageResFn+-- print body+ case code of+ 200 -> reply send cache ty body+ 404 -> replyWithFailure send body++ pageRpc_parser = ajaxParser pageRpcs+ rpc_parser = ajaxParser rpcs++ ajax_code = addr_gen ++ send_gen++ addr_gen = concatMap ajaxURLCodeGen $ getAllFuns pageRpcs+ send_gen = concatMap ajaxFunCodeGen $ getAllFuns rpcs++------------------------------------------------------------------------------++data AjaxCallback = AjaxCallback String [String]+ deriving Show++renderCallbacks :: [AjaxCallback] -> String+renderCallbacks = concatMap $ \ (AjaxCallback method args) -> + method ++ "(" ++ concat (intersperse "," args) ++ ");\n"+ajaxParser :: AjaxParser a -> Request -> Either [AjaxParserFailure] a +ajaxParser (AjaxParser _ f) req = f req++data AjaxArg = AjaxArg { unAjaxArg :: String }++ajaxCallback :: String -> AjaxCallback+ajaxCallback method = AjaxCallback method []++infixl 2 <@>++(<@>) :: (JSON arg) => AjaxCallback -> arg -> AjaxCallback+(<@>) (AjaxCallback method args) arg = + AjaxCallback method (args ++ [stringify $ toJSON arg])++class JSON a where+ toJSON :: a -> Value+ fromJSON :: Value -> Maybe a++instance JSON Value where+ toJSON = id+ fromJSON = return++instance JSON Bool where+ toJSON =Bool+ fromJSON (Bool b) = Just b+ fromJSON _ = Nothing++instance JSON Int where+ toJSON = Int+ fromJSON (Int i) = Just i+ fromJSON _ = Nothing++instance JSON Double where+ toJSON = Double+ fromJSON (Double i) = Just i+ fromJSON (Int i) = Just (fromInteger $ fromIntegral i)+ fromJSON _ = Nothing++instance JSON String where+ toJSON =String+ fromJSON (String str) = Just str+ fromJSON _ = Nothing++instance JSON a => JSON [a] where+ toJSON = Array . map toJSON+ fromJSON (Array arr) = sequence [ fromJSON a | a <- arr ]+ fromJSON _ = Nothing++instance JSON a => JSON (Maybe a) where+ toJSON Nothing = Object $ M.fromList [ ("tag",toJSON "Nothing")]+ toJSON (Just a) = Object $ M.fromList [ ("tag",toJSON "Just")+ , ("payload",toJSON a)+ ]+ fromJSON (Object m) = case M.lookup "tag" m of+ Just (String "Nothing") -> Just Nothing+ Just (String "Just") -> do+ v1 <- M.lookup "payload" m + fromJSON v1+ _ -> Nothing+ fromJSON _ = Nothing++altsJSON :: [Maybe a] -> Maybe a+altsJSON = listToMaybe . catMaybes ++findJSON :: (JSON a) => String -> JSON.Map String JSON.Value -> Maybe a+findJSON tagName obj = do+ val <- JSON.lookup tagName obj+ fromJSON val
+ src/Network/TrivialWebServer.hs view
@@ -0,0 +1,113 @@+-- (c) Andy Gill++module Network.TrivialWebServer where++import System.Posix+import System.Posix.Signals+import Network+import IO +import Monad ++import Control.Concurrent +import Control.Exception as Exc+import Control.Concurrent.Chan+import qualified List+import qualified Char++-- Trivial web server, taking from the Cherry chess rendering software.+-- Takes callback for each request as an argument.++server :: Int -> Int -> Server -> IO ()+server threadCount portNo (Server { serve = serve }) = do+ installHandler sigPIPE Ignore Nothing+ chan <- newChan+ sequence [ forkIO (worker chan) | i <- take threadCount [0..]]+ sock <- listenOn (PortNumber $ fromIntegral portNo)+ loopIO + (do (h,nm,port) <- accept sock+-- print (h,nm,port)+ writeChan chan h) `finally` sClose sock+ return ()+ where+ loopIO m = do m+ loopIO m++ worker chan = do+ tid <- myThreadId+ h <- readChan chan+ t <- hGetBuffering h +-- print t+ ln <- IO.hGetLine h+-- print $ ">> " ++ show tid ++ ":" ++ ln+ case words ln of+ ["GET",url,"HTTP/1.1"] + -> do +-- print ("GET",url) + serve file args $ Response + { reply = sendMsg h "200 OK"+ , replyWithFailure = sendMsg h "400 Bad Request" False "text/html" + }+ where (file,args) = splitup url+ _ -> sendMsg h "400 Bad Request" False "text/html" $+ "<html><body>Bad Request</body></html>\n"+ worker chan+ + sendMsg h code cache thing reply + = (do -- print $ "<< " ++ reply+ hPutStr h $ "HTTP/1.1 " ++ code ++ "\r\n"+ hPutStr h $ "Connection: close\r\n"+ hPutStr h $ "Content-Type: " ++ thing ++ "\r\n"+ hPutStr h $ "Content-Length: " ++ + show (length reply) ++ "\r\n"+ hPutStr h $ "Cache-Control: " +++ (if cache + then "max-age=3600"+ else "no-cache")+ ++ "\r\n"+ hPutStr h $ "\r\n"+ hPutStr h $ reply ++ "\r\n"+ IO.hClose h+ -- we choose to ignore exceptions inside here+ ) `Exc.catch` \ e -> do print "####################"+ print e+ return ()++splitup url = case span (/= '?') url of+ (path,'?':args) -> (path,splitargs args)+ (path,_) -> (path,[])+ where+ splitargs xs = case span (/= '=') xs of+ (index,'=':rest) ->+ case span (/= '&') rest of+ (value,'&':rest') -> (index,clean value) : splitargs rest'+ (value,_) -> (index,clean value) : []+ _ -> [] ++ clean ('%':d1:d2:cs) + = Char.chr (read $ "0x" ++ [d1,d2]) : clean cs+ clean (c:cs) = c : clean cs+ clean [] = []+++-- These calls may be asyncroynously(sp) done.+-- The contract is that you must return quickly (aka loading+-- a web page). If you have an expensive computation, you should+-- return, and call the reply continuation later when you are done.+-- This allows this thread to continue to service requests.++data Server = Server+ { serve :: String -- ^the URI+ -> [(String,String)] -- ^the arguments after questionmark+ -> Response -- ^the way to reply with a message+ -> IO ()+ }++data Response = Response+ { reply :: Bool -- ^ True => cache the result in the browser+ -> String -- ^ the content-type+ -> String -- ^ the body+ -> IO ()+ , replyWithFailure + :: String -- ^ short html message+ -> IO ()+ }