diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -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 \ + >> $@ + diff --git a/hpc-tracer.cabal b/hpc-tracer.cabal --- a/hpc-tracer.cabal +++ b/hpc-tracer.cabal @@ -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 maintainer: Andy Gill -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 + diff --git a/src/Data/JSON.hs b/src/Data/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Data/JSON.hs @@ -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 + diff --git a/src/Network/AjaxServer.hs b/src/Network/AjaxServer.hs new file mode 100644 --- /dev/null +++ b/src/Network/AjaxServer.hs @@ -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 diff --git a/src/Network/TrivialWebServer.hs b/src/Network/TrivialWebServer.hs new file mode 100644 --- /dev/null +++ b/src/Network/TrivialWebServer.hs @@ -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" $ + "Bad Request\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 () + }