{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Serve a chart web page with a web socket in it, that accepts 'ChartOptions'.
module Prettychart.Server
  ( startChartServer,
    startChartServerWith,
    printChart,
    chartSocketPage,
  )
where

import Box
import Chart
import Control.Concurrent.Async
import Control.Monad (when)
import Lucid as L
import Optics.Core
import Prettychart.Any
import Web.Rep

-- | 'Page' containing a web socket and javascript needed to run it.
chartSocketPage :: Page
chartSocketPage :: Page
chartSocketPage =
  Page
bootstrap5Page
    forall a b. a -> (a -> b) -> b
& forall a. IsLabel "jsOnLoad" a => a
#jsOnLoad
      forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ forall a. Monoid a => [a] -> a
mconcat
        [ RepJs
webSocket,
          RepJs
runScriptJs,
          RepJs
refreshJsbJs
        ]
    forall a b. a -> (a -> b) -> b
& forall a. IsLabel "htmlBody" a => a
#htmlBody
      forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Text -> Html () -> Html ()
divClass_
        Text
"container"
        ( forall a. Monoid a => [a] -> a
mconcat
            [ Text -> Html () -> Html ()
divClass_ Text
"row" forall a b. (a -> b) -> a -> b
$ Text -> Html () -> Html ()
divClass_ Text
"col" (forall arg result. Term arg result => arg -> result
h4_ Html ()
"prettychart" forall a. Semigroup a => a -> a -> a
<> forall a. With a => a -> [Attribute] -> a
L.with forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
id_ Text
"prettychart"] forall a. Monoid a => a
mempty)
            ]
        )

-- | Print a chart supplying a 'ChartOptions' consumer, and a showable thing that may be chartable. The first argument flags whether to also print the item to stdout.
printChart :: (Show a) => Bool -> (ChartOptions -> IO Bool) -> a -> IO ()
printChart :: forall a. Show a => Bool -> (ChartOptions -> IO Bool) -> a -> IO ()
printChart Bool
reprint ChartOptions -> IO Bool
send a
s = case String -> Either String ChartOptions
anyChart (forall a. Show a => a -> String
show a
s) of
  Left String
_ -> forall a. Show a => a -> IO ()
print a
s
  Right ChartOptions
co -> do
    Bool
b <- ChartOptions -> IO Bool
send ChartOptions
co
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b Bool -> Bool -> Bool
|| Bool
reprint) (forall a. Show a => a -> IO ()
print a
s)

-- | Start the chart server. Returns the chart consumer, and a server quit signal effect.
--
-- An iconic ghci session transcript:
--
-- >> import Chart.Examples
-- >> (sendChart, quitChartServer) <- startChartServer
-- >> sendChart unitExample
--
-- ... point browser to localhost:9160 ...
--
-- >> quitChartServer
startChartServer :: IO (ChartOptions -> IO Bool, IO ())
startChartServer :: IO (ChartOptions -> IO Bool, IO ())
startChartServer = SocketConfig -> Page -> IO (ChartOptions -> IO Bool, IO ())
startChartServerWith SocketConfig
defaultSocketConfig Page
chartSocketPage

-- | Start the chart server protocol with bespoke 'SocketConfig' and 'Page' configurations.
--
-- > startChartServerWith (defaultSocketConfig & #port .~ 4567) (defaultSocketPage & #htmlBody %~ divClass_ "row" "bespoke footnote")
startChartServerWith :: SocketConfig -> Page -> IO (ChartOptions -> IO Bool, IO ())
startChartServerWith :: SocketConfig -> Page -> IO (ChartOptions -> IO Bool, IO ())
startChartServerWith SocketConfig
scfg Page
page = do
  (Box Committer IO ChartOptions
c Emitter IO ChartOptions
e, IO ()
q) <- forall a. Queue a -> IO (Box IO a a, IO ())
toBoxM forall a. Queue a
Single
  Async ()
x <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ SocketConfig -> Page -> Box IO Text Text -> IO ()
serveSocketBox SocketConfig
scfg Page
page (forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer IO Text
toStdout (Text -> Text -> Text
replace Text
"prettychart" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChartOptions -> Text
renderChartOptions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Emitter IO ChartOptions
e))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO ChartOptions
c, forall a. Async a -> IO ()
cancel Async ()
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
q)