module Parry.WebUI (
webUI,Html(..)
) where
import Control.Concurrent
import Network
import qualified Data.Map as M
import qualified Data.Set as S
import System.IO
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.Format
import System.Locale
import System.Directory
import System.Process
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Lazy.Builder
import Data.ByteString.Lazy.Builder.ASCII
import Control.Exception
import Numeric
import Parry.Server
import Data.Monoid
type Graphs=MVar (L.ByteString,L.ByteString,L.ByteString,L.ByteString)
makeSvg::(Exhaustive j)=>Graphs->MVar (State j r)->IO ()
makeSvg graphs state=onException (
do {
st<-withMVar state $ return;
if M.size (ongoing st)==0 && (S.size (jobs st)==0) then return () else do {
t<-getPOSIXTime;
let { show_t=intDec $ round $ realToFrac t };
L.appendFile "parry.log" $
toLazyByteString $
show_t `mappend` (byteString " ") `mappend` (intDec $ M.size $ ongoing st)
`mappend` (byteString " ") `mappend` (intDec $ S.size $ jobs st)
`mappend` (byteString "\n");
let { jobs_=jobs st;
ongoing_=ongoing st;
(adepth0,njobs0)=M.foldl' (\(d,n) (_,_,j,_,_)->(d+depth j,n+1)) (0,0) $ ongoing_ :: (Int,Int);
(adepth1,njobs1)=S.foldl' (\(d,n) (_,j)->(d+depth j,n+1)) (0,0) $ jobs_ :: (Int,Int);
depth0=if njobs0>0 then (fromIntegral adepth0)/(fromIntegral njobs0) else 0 :: Double;
depth1=if njobs1>0 then (fromIntegral adepth1)/(fromIntegral njobs1) else 0 :: Double;
depth2=M.foldl' (\d (_,_,j,_,_)->min d $ depth j) maxBound $ ongoing_ :: Int;
depth3=S.foldl' (\d (_,j)->min d $ depth j) maxBound $ jobs_ :: Int
};
L.appendFile "solved.log" $
toLazyByteString $
show_t `mappend` (byteString " ") `mappend` (integerDec $ solved st) `mappend` (byteString "\n");
if njobs0>0 then
L.appendFile "depth.log" $
toLazyByteString $
show_t `mappend` (byteString " ") `mappend` (doubleDec depth0)`mappend` (byteString "\n")
else L.appendFile "depth.log" "\n";
if njobs1>0 then
L.appendFile "depth_av.log" $
toLazyByteString $
show_t `mappend` (byteString " ") `mappend` (doubleDec depth1)`mappend` (byteString "\n")
else L.appendFile "depth_av.log" "\n";
if depth2<maxBound then
L.appendFile "depth_min.log" $
toLazyByteString $
show_t `mappend` (byteString " ")`mappend` (intDec depth2) `mappend` (byteString "\n")
else L.appendFile "depth_min.log" "\n";
if depth3<maxBound then
L.appendFile "depth_min_av.log" $
toLazyByteString $
show_t `mappend` (byteString " ")`mappend` (intDec depth3) `mappend` (byteString "\n")
else L.appendFile "depth_min_av.log" "\n";
_<-readProcessWithExitCode "gnuplot" [] $
concat [
"set term svg\nset output \"solved.svg\"\nset title \"Number of finished jobs\"\nset xtics rotate by -90\nset style data fsteps\nset xlabel \"Date\"\nset timefmt \"%s\"\nset format x \"%m/%d/%Y %H:%M\"\nset xdata time\nset ylabel \"Jobs\"\nset grid\nset key left\nplot \"solved.log\" using 1:2 with lines title \"Finished jobs\"\n",
"set output \"machines.svg\"\nset title \"Number of jobs\"\nset xtics rotate by -90\nset style data fsteps\nset xlabel \"Date\"\nset timefmt \"%s\"\nset format x \"%m/%d/%Y %H:%M\"\nset xdata time\nset ylabel \"Machines\"\nset grid\nset key left\nplot \"parry.log\" using 1:2 with lines title \"Ongoing jobs\", \"parry.log\" using 1:3 with lines title\"Available jobs\"\n",
"set output \"depth_av.svg\"\nset title \"Average depth of jobs\"\nset ylabel \"Depth\"\nset timefmt \"%s\"\nset format x \"%m/%d/%Y %H:%M\"\nset xdata time\nplot \"depth.log\" using 1:2 with lines title \"Ongoing jobs\",\"depth_av.log\" using 1:2 with lines title \"Available jobs\"\n\n",
"set output \"depth_min.svg\"\nset title \"Minimal depth of jobs\"\nset ylabel \"Depth\"\nset timefmt \"%s\"\nset format x \"%m/%d/%Y %H:%M\"\nset xdata time\nplot \"depth_min.log\" using 1:2 with lines title \"Ongoing jobs\",\"depth_min_av.log\" using 1:2 with lines title \"Available jobs\""];
let { readOr x=do { e<-doesFileExist x; if e then L.readFile x else return blankSvg }};
a<-readOr "machines.svg";
b<-readOr "depth_av.svg";
c<-readOr "depth_min.svg";
e<-readOr "solved.svg";
modifyMVar_ graphs $ \_->return (a,b,c,e);
return ()
}})
(return ())
class Html a where
toHtml::a->Builder
webserver::(Html j,Html r)=>
Graphs
->MVar (State j r)
->Handle->IO()
webserver graphs state dsth=do {
req<-B.hGetLine dsth;
let { getHeaders hdr=do {
h<-B.hGetLine dsth;
if B.length h<=1 then return $ reverse hdr else
let { (a,b)=B.span (/=':') h } in
getHeaders $ (B.takeWhile (/=' ') a,B.dropWhile (/=' ') $ B.drop 1 b):hdr
};
};
hdr<-getHeaders [];
_<-case lookup "Content-Length" hdr of {
Just x->case reads (B.unpack x) of {
[(a,_)]->B.hGet dsth a;
_->return B.empty
};
_->return B.empty
};
let { repl code typ dat=do {
B.hPutStr dsth "HTTP/1.1 ";
B.hPutStr dsth code;
B.hPutStr dsth " \r\n";
B.hPutStr dsth typ;
if L.length dat>0 then do {
B.hPutStr dsth "Content-Length: ";
L.hPutStr dsth (toLazyByteString $ int64Dec $ L.length dat);
B.hPutStr dsth "\r\n\r\n";
L.hPutStr dsth dat
} else B.hPutStr dsth "\r\n"
};
ok dat=repl "200 OK" "Content-Type: text/html; charset=utf-8\r\n" dat;
img dat=repl "200 OK" "Content-Type: image/svg+xml; charset=utf-8\r\n" dat;
notFound dat=repl "404 Not found" "Content-Type: text/html; charset=utf-8\r\n" dat;
};
case B.split ' ' req of {
"GET":addr:_->
case addr of {
"/machines.svg"-> do {
(a,_,_,_)<-withMVar graphs return;
img a
};
"/depth_min.svg" -> do {
(_,a,_,_)<-withMVar graphs return;
img a
};
"/depth_av.svg" -> do {
(_,_,a,_)<-withMVar graphs return;
img a
};
"/solved.svg" -> do {
(_,_,_,a)<-withMVar graphs return;
img a
};
"/"->do {
st<-withMVar state $ return;
let {page=
toLazyByteString $
(mconcat [
byteString $ "<!DOCTYPE HTML><html><head><meta http-equiv=\"Content-type\" content=\"text/html;charset=UTF-8\"/><title>Parry Web UI</title></head><body><h1 style=\"font-family:sans-serif;\">Results</h1>",
toHtml $ results st,
byteString "<img src=\"machines.svg\"/><br/><img src=\"solved.svg\"/><br/><img src=\"depth_min.svg\"/><br/><img src=\"depth_av.svg\"/><br/>",
byteString "<h1 style=\"font-family:sans-serif\">Available jobs</h1><p>"
])
`mappend`
(intDec $ S.size $ jobs st)
`mappend`
(byteString "</p><h1 style=\"font-family:sans-serif\">Ongoing jobs</h1><div style=\"font-family:monospace\">")
`mappend`
(mconcat $ map (\(x,(h,_,j,t,t'))->
(byteString "<p>")
`mappend`
integerDec x
`mappend`
(byteString " ")
`mappend`
(byteString $ B.pack h)
`mappend`
(byteString "<br/>Started: ")
`mappend`
(string8 $
formatTime defaultTimeLocale "%c" $
posixSecondsToUTCTime $ realToFrac t)
`mappend`
(byteString "<br/>")
`mappend`
toHtml j
`mappend`
(byteString "</p>")
) $ M.toList $ ongoing st)
`mappend`
(byteString "</div></body></html>")
};
ok $ page
};
_->notFound ""
};
_->ok ""
};
hClose dsth;
}
blankSvg::L.ByteString
blankSvg=
"<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\" \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\"><svg xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\"></svg>"
webUI::(Exhaustive j,Html j,Html r)=>PortNumber->MVar (State j r)->IO ()
webUI wport state=do {
sock <- listenOn (PortNumber wport);
graphs<-newMVar $ (blankSvg,blankSvg,blankSvg,blankSvg);
makeSvg graphs state;
let {list=do {
(s,_,_)<-accept sock;
_<-forkIO $ webserver graphs state s;
list
};
svg=do {
threadDelay $ 30000000;
makeSvg graphs state;
svg
}};
_<-forkIO svg;
list
}