{-# 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,
    startFileServerWith,
    watchE,
    watchSvg,
    svgEvent,
    displayFile,
  )
where

import Box
import Chart
import Control.Category ((>>>))
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Monad (forever, void, when)
import Data.Bool
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Char8 (pack)
import Data.Maybe
import Data.Text.Encoding
import MarkupParse
import Optics.Core hiding (element)
import Prettychart.Any
import System.FSNotify
import System.FilePath
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)

-- | Start a file server protocol with bespoke 'SocketConfig' and 'Page' configurations.
--
-- > startFileServerWith (defaultSocketConfig & #port .~ 4567) (defaultSocketPage & #htmlBody %~ divClass_ "row" "bespoke footnote")
startFileServerWith :: SocketConfig -> Page -> IO (FilePath -> IO Bool, IO ())
startFileServerWith :: SocketConfig -> Page -> IO (String -> IO Bool, IO ())
startFileServerWith SocketConfig
scfg Page
page = do
  (Box Committer IO String
c Emitter IO String
e, IO ()
q) <- Queue String -> IO (Box IO String String, IO ())
forall a. Queue a -> IO (Box IO a a, IO ())
toBoxM Queue String
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)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
replace ByteString
"prettychart" (ByteString -> Text) -> Emitter IO ByteString -> Emitter IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe ByteString))
-> Emitter IO String -> Emitter IO ByteString
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE (String -> IO ByteString
B.readFile (String -> IO ByteString)
-> (IO ByteString -> IO (Maybe ByteString))
-> String
-> IO (Maybe ByteString)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just) Emitter IO String
e))
  (String -> IO Bool, IO ()) -> IO (String -> IO Bool, IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Committer IO String -> String -> IO Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO String
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)

-- | Emit from the fsnotify watch manager.
watchE :: [Char] -> Codensity IO (Emitter IO Event)
watchE :: String -> Codensity IO (Emitter IO Event)
watchE String
fp =
  Queue Event
-> (Committer IO Event -> IO ()) -> Codensity IO (Emitter IO Event)
forall a r. Queue a -> (Committer IO a -> IO r) -> CoEmitter IO a
emitQ
    Queue Event
forall a. Queue a
New
    ( \Committer IO Event
c -> (WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> do
        String -> IO ()
putStrLn String
"watchDir started"
        IO ()
_ <- WatchManager -> String -> ActionPredicate -> Action -> IO (IO ())
watchDir WatchManager
mgr String
fp (Bool -> ActionPredicate
forall a b. a -> b -> a
const Bool
True) (IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> (Event -> IO Bool) -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Committer IO Event -> Event -> IO Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO Event
c)
        Any
_ <- IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
        -- never gets to here:
        String -> IO ()
putStrLn String
"watchDir stopped"
    )

-- | Emit from the fsnotify watch manager.
-- > glue' toStdout <$|> fmap (Text.pack . show) <$> watchE "."
watchSvg :: FilePath -> CoEmitter IO FilePath
watchSvg :: String -> CoEmitter IO String
watchSvg String
fp =
  Queue String
-> (Committer IO String -> IO ()) -> CoEmitter IO String
forall a r. Queue a -> (Committer IO a -> IO r) -> CoEmitter IO a
emitQ
    Queue String
forall a. Queue a
New
    ( \Committer IO String
c -> (WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> do
        String -> IO ()
putStrLn String
"watchDir started"
        IO ()
_ <- WatchManager -> String -> ActionPredicate -> Action -> IO (IO ())
watchDir WatchManager
mgr String
fp (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool)
-> (Event -> Maybe String) -> ActionPredicate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Maybe String
svgEvent) (IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> (String -> IO Bool) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Committer IO String -> String -> IO Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer IO String
c) (Maybe String -> IO ()) -> (Event -> Maybe String) -> Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Maybe String
svgEvent)
        Any
_ <- IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
        -- never gets to here:
        String -> IO ()
putStrLn String
"watchDir stopped"
    )

-- | Filter for svg file additions and modifications.
svgEvent :: Event -> Maybe FilePath
svgEvent :: Event -> Maybe String
svgEvent (Added String
fp UTCTime
_ EventIsDirectory
dir) = Maybe String -> Maybe String -> Bool -> Maybe String
forall a. a -> a -> Bool -> a
bool Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
fp) (String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".svg" Bool -> Bool -> Bool
&& EventIsDirectory
dir EventIsDirectory -> EventIsDirectory -> Bool
forall a. Eq a => a -> a -> Bool
== EventIsDirectory
IsFile)
svgEvent (Modified String
fp UTCTime
_ EventIsDirectory
dir) = Maybe String -> Maybe String -> Bool -> Maybe String
forall a. a -> a -> Bool -> a
bool Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
fp) (String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".svg" Bool -> Bool -> Bool
&& EventIsDirectory
dir EventIsDirectory -> EventIsDirectory -> Bool
forall a. Eq a => a -> a -> Bool
== EventIsDirectory
IsFile)
svgEvent Event
_ = Maybe String
forall a. Maybe a
Nothing

-- | Create a file committer to serve an SVG file.
displayFile :: SocketConfig -> Page -> IO (Committer IO FilePath, IO ())
displayFile :: SocketConfig -> Page -> IO (Committer IO String, IO ())
displayFile SocketConfig
scfg Page
page = do
  (Box Committer IO ByteString
c Emitter IO ByteString
e, IO ()
q) <- Queue ByteString -> IO (Box IO ByteString ByteString, IO ())
forall a. Queue a -> IO (Box IO a a, IO ())
toBoxM Queue ByteString
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)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
replace ByteString
"prettychart" (ByteString -> Text) -> Emitter IO ByteString -> Emitter IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Emitter IO ByteString
e))
  (Committer IO String, IO ()) -> IO (Committer IO String, IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> IO (Maybe ByteString))
-> Committer IO ByteString -> Committer IO String
forall (m :: * -> *) b a.
Monad m =>
(b -> m (Maybe a)) -> Committer m a -> Committer m b
witherC (String -> IO ByteString
B.readFile (String -> IO ByteString)
-> (IO ByteString -> IO (Maybe ByteString))
-> String
-> IO (Maybe ByteString)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just) Committer IO ByteString
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)