{-#LANGUAGE OverloadedStrings,MultiParamTypeClasses #-}
{-|
Module      :  Parry.DefaultUI
Copyright   :  (c) Pierre-Étienne Meunier 2014
License     :  GPL-3
Maintainer  :  pierre-etienne.meunier@lif.univ-mrs.fr
Stability   :  experimental
Portability :  All
-}
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`
                   {-
                   (mconcat $ map (\(_,x)->
                                    mconcat [byteString "<p>",toHtml x,byteString "</p>"]
                                  ) $ S.toList $ jobs st)
-}
                   (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>"


-- | Starts the default web server.
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
  }