{-# OPTIONS
            -XScopedTypeVariables

            #-}
module MFlow.Forms.Admin(adminLoop, wait, addAdminWF) where
import MFlow.Forms
import MFlow
import MFlow.Forms.Blaze.Html
import Text.Blaze.Html5 hiding (map)
import Control.Applicative
import Control.Workflow
import Control.Monad.Trans
import Data.TCache
import Data.TCache.IndexQuery
import System.Exit
import System.IO
import System.IO.Unsafe
import Data.ByteString.Lazy.Char8 as B (unpack,tail,hGetNonBlocking,append, pack)
import System.IO
import Data.RefSerialize hiding ((<|>))
import Data.Typeable
import Data.Monoid
import Data.Maybe
import Data.Map as M (keys, toList)
import System.Exit
import Control.Exception as E
import Control.Concurrent
import Control.Concurrent.MVar
import GHC.Conc


ssyncCache= putStr "sync..." >> syncCache >> putStrLn "done"

-- | A small console interpreter with some commands:
--
-- [@sync@] Synchronize the cache with persistent storage (see `syncCache`)
--
-- [@flush@] Flush the cache
--
-- [@end@] Synchronize and exit
--
-- [@abort@] Exit. Do not synchronize
--
-- on exception, for example Control-c, it sync and exits.
-- It must be used as the last statement of the main procedure.
adminLoop :: IO ()
adminLoop= do
  msgs <- getMessageFlows
  putStrLn ""
  putStrLn $  "Served:"
  mapM putStrLn  [ "     http://server:port/"++ i  | i <- M.keys msgs]
  putStrLn ""
  putStrLn "Commands: sync, flush, end, abort"
  adminLoop1
  `E.catch` (\(e:: E.SomeException) ->do
                      ssyncCache
                      error $ "\nException: "++ show e)

adminLoop1= do
       putStr ">"; hFlush stdout
       op <- getLine
       case op of
        "sync"  -> ssyncCache
        "flush" -> atomically flushAll >> putStrLn "flushed cache"
        "end"   -> ssyncCache >> putStrLn "bye" >> exitWith ExitSuccess
        "abort" -> exitWith ExitSuccess
        _       -> return()
       adminLoop1

-- | execute the process and wait for its finalization.
--  then it synchronizes the cache
wait f= do
    putChar '\n'
    putStrLn "Using configuration: "
    mapM_ putStrLn [k ++"= "++ show v | (k,v) <- M.toList config]
    putChar '\n'
    mv <- newEmptyMVar
    forkIO (f1 >> putMVar mv True)
    putStrLn "wait: ready"
    takeMVar mv
    return ()
   `E.catch` (\(e:: E.SomeException) ->do
                  ssyncCache
                  error $ "Signal: "++ show e)

    where
    f1= do
        mv <- newEmptyMVar
        n <- getNumProcessors
        putStr "Running in "
        putStr $ show n
        putStrLn " core(s)"
        hFlush stdout
        f

-- | Install the admin flow in the list of flows handled by `HackMessageFlow`
-- this gives access to an administrator page. It is necessary to
-- create an admin user with `setAdminUser`.
--
-- The administration page is reached with the path \"adminserv\"
addAdminWF= addMessageFlows[("adminserv", runFlow $ transientNav adminMFlow)]


adminMFlow ::  FlowM   Html IO ()
adminMFlow= do
   let admin = getAdminName
   u <- getUser (Just admin) $ p << b << "Please login as Administrator" ++> userLogin
   op <- ask  $  p <<< wlink "sync"  (b << "sync")
             <|> p <<< wlink "flush" (b << "flush")
             <|> p <<< wlink "errors"(b << "errors")
             <|> p <<< wlink "users" (b << "users")
             <|> p <<< wlink "end"   (b << "end")
             <|> wlink "abort" (b << "abort")

   case op of
    "users" -> users
    "sync" ->  liftIO $ syncCache >> print "syncronized cache"
    "flush" -> liftIO $ atomically flushAll >> print "flushed cache"

    "errors" -> errors
    "end"  -> liftIO $ syncCache >> print "bye" >> exitWith(ExitSuccess)
    "abort" -> liftIO $ exitWith(ExitSuccess)
    _ -> return()
   adminMFlow


errors= do
  size <- liftIO $ hFileSize hlog
  if size == 0
   then ask $ wlink () (b << "no error log")
   else do
       liftIO $ hSeek hlog AbsoluteSeek 0
       log   <- liftIO $ hGetNonBlocking hlog  (fromIntegral size)

       let ls :: [[String ]]= runR  readp $ pack "[" `append` (B.tail log) `append` pack "]"
       let rows= [wlink (Prelude.head e) (b << Prelude.head e) `waction` optionsUser  : map (\x ->noWidget <++ fromStr x) (Prelude.tail e) | e <- ls]
       showFormList rows 0 10
  breturn()







users= do
  users <- liftIO $ atomically $ return . map  fst =<< indexOf userName

  showFormList   [[wlink u (b << u) `waction` optionsUser   ] | u<- users] 0 10

showFormList
  :: [[View Html IO ()]]
     -> Int -> Int -> FlowM Html IO b
showFormList ls n l= do
  nav <- ask  $  updown n l <|> (list **> updown n l)
  showFormList ls nav l

  where
  list= table <<< firstOf (span1 n l [tr <<< cols  e | e <- ls ])

  cols e= firstOf[td <<< c | c <- e]
  span1 n l = take l . drop n
  updown n l= wlink ( n +l) (b << "up ") <|> wlink ( n -l) (b << "down ") <++ br

optionsUser  us = do
    wfs <- liftIO $ return . M.keys =<< getMessageFlows
    stats <-  let u= undefined
              in  liftIO $ mapM  (\wf -> getWFHistory wf (Token wf us u u u u u u)) wfs
    let wfss= filter (isJust . snd) $ zip wfs stats
    if null wfss
     then ask $ b << " not logs for this user" ++> wlink () (b << "Press here")
     else do
      wf <-  ask $ firstOf [ wlink wf (p << wf) | (wf,_) <-  wfss]
      ask $ p << unpack (showHistory . fromJust . fromJust $ lookup wf  wfss) ++>  wlink () (p << "press to menu")