{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.RTView.Server
    ( launchServer
    ) where

import           Cardano.Prelude hiding (readMVar)

import           Control.Concurrent.MVar.Strict (MVar, readMVar)
import qualified Graphics.UI.Threepenny as UI
import           Graphics.UI.Threepenny.Core (UI, onEvent, set, ( # ), ( #+ ))
import           Graphics.UI.Threepenny.Timer (interval, start, tick, timer)

import           Cardano.BM.Data.Configuration (RemoteAddrNamed (..))

import           Cardano.RTView.CLI (RTViewParams (..))
import           Cardano.RTView.GUI.CSS.Style (ownCSS)
import           Cardano.RTView.GUI.Markup (mkPageBody)
import           Cardano.RTView.GUI.Updater (updateGUI)
import           Cardano.RTView.NodeState.Types (NodesState)

-- | Launch web server.
launchServer
  :: MVar NodesState
  -> RTViewParams
  -> [RemoteAddrNamed]
  -> IO ()
launchServer :: MVar NodesState -> RTViewParams -> [RemoteAddrNamed] -> IO ()
launchServer MVar NodesState
nsMVar RTViewParams
params [RemoteAddrNamed]
acceptors =
  Config -> (Window -> UI ()) -> IO ()
UI.startGUI Config
config ((Window -> UI ()) -> IO ()) -> (Window -> UI ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar NodesState
-> RTViewParams -> [RemoteAddrNamed] -> Window -> UI ()
mainPage MVar NodesState
nsMVar RTViewParams
params [RemoteAddrNamed]
acceptors
 where
  config :: Config
config = Config
UI.defaultConfig
    { jsStatic :: Maybe FilePath
UI.jsStatic = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ RTViewParams -> FilePath
rtvStatic RTViewParams
params
    , jsPort :: Maybe Int
UI.jsPort   = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ RTViewParams -> Int
rtvPort RTViewParams
params
    }

mainPage
  :: MVar NodesState
  -> RTViewParams
  -> [RemoteAddrNamed]
  -> UI.Window
  -> UI ()
mainPage :: MVar NodesState
-> RTViewParams -> [RemoteAddrNamed] -> Window -> UI ()
mainPage MVar NodesState
nsMVar RTViewParams
params [RemoteAddrNamed]
acceptors Window
window = do
  UI Window -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Window -> UI ()) -> UI Window -> UI ()
forall a b. (a -> b) -> a -> b
$ Window -> UI Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
window UI Window -> (UI Window -> UI Window) -> UI Window
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Window FilePath ()
-> FilePath -> UI Window -> UI Window
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Window FilePath ()
UI.title FilePath
"Cardano Node RTView"

  -- It is assumed that CSS files are available at 'pathToStatic/css/'.
  Window -> FilePath -> UI ()
UI.addStyleSheet Window
window FilePath
"w3.css"
  Window -> UI ()
embedOwnCSS Window
window

  -- It is assumed that JS files are available at 'pathToStatic/js/'.
  Window -> FilePath -> UI ()
addJavaScript Window
window FilePath
"chart.js"

  -- Make page's body (HTML markup).
  (Element
pageBody, (NodesStateElements
nodesStateElems, NodesStateElements
gridNodesStateElems)) <- Window
-> [RemoteAddrNamed]
-> UI (Element, (NodesStateElements, NodesStateElements))
mkPageBody Window
window [RemoteAddrNamed]
acceptors

  -- Start the timer for GUI update. Every second it will
  -- call a function which updates node state elements on the page.
  Timer
guiUpdateTimer <- UI Timer
timer UI Timer -> (UI Timer -> UI Timer) -> UI Timer
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Timer Int Int -> Int -> UI Timer -> UI Timer
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Timer Int Int
interval Int
2000 -- Every 2 s.
  UI (UI ()) -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI (UI ()) -> UI ()) -> UI (UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ Event () -> (() -> UI ()) -> UI (UI ())
forall a void. Event a -> (a -> UI void) -> UI (UI ())
onEvent (Timer -> Event ()
tick Timer
guiUpdateTimer) ((() -> UI ()) -> UI (UI ())) -> (() -> UI ()) -> UI (UI ())
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
    NodesState
newState <- IO NodesState -> UI NodesState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NodesState -> UI NodesState) -> IO NodesState -> UI NodesState
forall a b. (a -> b) -> a -> b
$ MVar NodesState -> IO NodesState
forall a. NFData a => MVar a -> IO a
readMVar MVar NodesState
nsMVar
    Window
-> NodesState
-> RTViewParams
-> [RemoteAddrNamed]
-> (NodesStateElements, NodesStateElements)
-> UI ()
updateGUI Window
window NodesState
newState RTViewParams
params [RemoteAddrNamed]
acceptors (NodesStateElements
nodesStateElems, NodesStateElements
gridNodesStateElems)
  Timer -> UI ()
start Timer
guiUpdateTimer

  UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
UI.element Element
pageBody

-- | ...
addJavaScript
  :: UI.Window
  -> FilePath
  -> UI ()
addJavaScript :: Window -> FilePath -> UI ()
addJavaScript Window
w FilePath
filename = UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ do
  Element
el <- FilePath -> UI Element
UI.mkElement FilePath
"script" UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element FilePath ()
-> FilePath -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element FilePath ()
UI.src (FilePath
"/static/js/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filename)
  Window -> UI Element
UI.getHead Window
w UI Element -> [UI Element] -> UI Element
#+ [Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
UI.element Element
el]

-- | We generate our own CSS using 'clay' package, so embed it in the page's header.
embedOwnCSS
  :: UI.Window
  -> UI ()
embedOwnCSS :: Window -> UI ()
embedOwnCSS Window
w = UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ do
  Element
el <- FilePath -> UI Element
UI.mkElement FilePath
"style" UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element FilePath ()
-> FilePath -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element FilePath ()
UI.html FilePath
ownCSS
  Window -> UI Element
UI.getHead Window
w UI Element -> [UI Element] -> UI Element
#+ [Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
UI.element Element
el]