{-# 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 Data.ByteString (ByteString)
import Data.ByteString.Char8 (pack)
import Data.Text.Encoding
import MarkupParse
import Optics.Core hiding (element)
import Prettychart.Any
import Web.Rep

-- | 'Page' containing a web socket and javascript needed to run it.
chartSocketPage :: Maybe ByteString -> Page
chartSocketPage :: Maybe ByteString -> Page
chartSocketPage Maybe ByteString
title =
  Page
bootstrapPage
    Page -> (Page -> Page) -> Page
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Page Page Js Js
#jsOnLoad
    Optic A_Lens NoIx Page Page Js Js -> Js -> Page -> Page
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [Js] -> Js
forall a. Monoid a => [a] -> a
mconcat
      [ Js
webSocket,
        Js
runScriptJs,
        Js
refreshJsbJs
      ]
    Page -> (Page -> Page) -> Page
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Page Page Markup Markup
#htmlBody
    Optic A_Lens NoIx Page Page Markup Markup -> Markup -> Page -> Page
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ByteString -> [Attr] -> Markup -> Markup
element ByteString
"div" [ByteString -> ByteString -> Attr
Attr ByteString
"class" ByteString
"container"] (ByteString -> [Attr] -> Markup -> Markup
element ByteString
"row" [ByteString -> ByteString -> Attr
Attr ByteString
"class" ByteString
"col"] (Markup -> (ByteString -> Markup) -> Maybe ByteString -> Markup
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Markup
forall a. Monoid a => a
mempty (ByteString -> [Attr] -> ByteString -> Markup
elementc ByteString
"h4" []) Maybe ByteString
title) Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Attr] -> Markup
element_ ByteString
"div" (Attr -> [Attr]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attr -> [Attr]) -> Attr -> [Attr]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Attr
Attr ByteString
"id" ByteString
"prettychart"))
    Page -> (Page -> Page) -> Page
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Page Page Css Css
#cssBody
    Optic A_Lens NoIx Page Page Css Css -> Css -> Page -> Page
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Css
cssColorScheme

-- | 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 (a -> String
forall a. Show a => a -> String
show a
s) of
  Left String
_ -> a -> IO ()
forall a. Show a => a -> IO ()
print a
s
  Right ChartOptions
co -> do
    Bool
b <- ChartOptions -> IO Bool
send ChartOptions
co
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b Bool -> Bool -> Bool
|| Bool
reprint) (a -> IO ()
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 (Just "prettychart")
-- >> sendChart unitExample
--
-- ... point browser to localhost:9160 ...
--
-- >> quitChartServer
startChartServer :: Maybe String -> IO (ChartOptions -> IO Bool, IO ())
startChartServer :: Maybe String -> IO (ChartOptions -> IO Bool, IO ())
startChartServer Maybe String
title = SocketConfig -> Page -> IO (ChartOptions -> IO Bool, IO ())
startChartServerWith SocketConfig
defaultSocketConfig (Maybe ByteString -> Page
chartSocketPage (Maybe ByteString -> Page) -> Maybe ByteString -> Page
forall a b. (a -> b) -> a -> b
$ String -> ByteString
pack (String -> ByteString) -> Maybe String -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
title)

-- | 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) <- Queue ChartOptions -> IO (Box IO ChartOptions ChartOptions, IO ())
forall a. Queue a -> IO (Box IO a a, IO ())
toBoxM Queue ChartOptions
forall a. Queue a
Single
  Async ()
x <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ SocketConfig -> Page -> Box IO Text Text -> IO ()
serveSocketBox SocketConfig
scfg Page
page (Committer IO Text -> Emitter IO Text -> Box IO Text Text
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer IO Text
toStdout (ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ChartOptions -> ByteString) -> ChartOptions -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
replace ByteString
"prettychart" (ByteString -> ByteString)
-> (ChartOptions -> ByteString) -> ChartOptions -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChartOptions -> ByteString
encodeChartOptions (ChartOptions -> Text)
-> Emitter IO ChartOptions -> Emitter IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Emitter IO ChartOptions
e))
  (ChartOptions -> IO Bool, IO ())
-> IO (ChartOptions -> IO Bool, IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Committer IO ChartOptions -> ChartOptions -> IO Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO ChartOptions
c, Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
q)