{-# LANGUAGE OverloadedStrings #-}
module Prettychart.Server
(
SocketConfig (..),
defaultSocketConfig,
ChartServerConfig (..),
defaultChartServerConfig,
startChartServerHyperbole,
startChartServerPush,
)
where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Data.ByteString.Lazy qualified as BL
import Data.IORef
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text.Encoding
import Network.HTTP.Types (ok200)
import Network.Wai
import Network.Wai.Handler.Warp (run)
data SocketConfig = SocketConfig
{ SocketConfig -> String
host :: String,
SocketConfig -> Int
port :: Int,
SocketConfig -> String
path :: String
}
deriving (SocketConfig -> SocketConfig -> Bool
(SocketConfig -> SocketConfig -> Bool)
-> (SocketConfig -> SocketConfig -> Bool) -> Eq SocketConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketConfig -> SocketConfig -> Bool
== :: SocketConfig -> SocketConfig -> Bool
$c/= :: SocketConfig -> SocketConfig -> Bool
/= :: SocketConfig -> SocketConfig -> Bool
Eq, Int -> SocketConfig -> ShowS
[SocketConfig] -> ShowS
SocketConfig -> String
(Int -> SocketConfig -> ShowS)
-> (SocketConfig -> String)
-> ([SocketConfig] -> ShowS)
-> Show SocketConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocketConfig -> ShowS
showsPrec :: Int -> SocketConfig -> ShowS
$cshow :: SocketConfig -> String
show :: SocketConfig -> String
$cshowList :: [SocketConfig] -> ShowS
showList :: [SocketConfig] -> ShowS
Show)
defaultSocketConfig :: SocketConfig
defaultSocketConfig :: SocketConfig
defaultSocketConfig = String -> Int -> String -> SocketConfig
SocketConfig String
"127.0.0.1" Int
9160 String
"/ws"
data ChartServerConfig = ChartServerConfig
{ ChartServerConfig -> Int
serverPort :: Int,
ChartServerConfig -> Maybe Text
serverTitle :: Maybe Text
}
deriving (Int -> ChartServerConfig -> ShowS
[ChartServerConfig] -> ShowS
ChartServerConfig -> String
(Int -> ChartServerConfig -> ShowS)
-> (ChartServerConfig -> String)
-> ([ChartServerConfig] -> ShowS)
-> Show ChartServerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChartServerConfig -> ShowS
showsPrec :: Int -> ChartServerConfig -> ShowS
$cshow :: ChartServerConfig -> String
show :: ChartServerConfig -> String
$cshowList :: [ChartServerConfig] -> ShowS
showList :: [ChartServerConfig] -> ShowS
Show)
defaultChartServerConfig :: ChartServerConfig
defaultChartServerConfig :: ChartServerConfig
defaultChartServerConfig = Int -> Maybe Text -> ChartServerConfig
ChartServerConfig Int
9160 Maybe Text
forall a. Maybe a
Nothing
renderChartHtml :: Maybe Text -> Maybe Text -> BL.ByteString
renderChartHtml :: Maybe Text -> Maybe Text -> ByteString
renderChartHtml Maybe Text
title Maybe Text
mChart =
ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
Text
"<!DOCTYPE html><html><head><meta charset=\"utf-8\"><title>"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"prettychart" Maybe Text
title
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</title><meta http-equiv=\"refresh\" content=\"2\"></head><body>"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"<div class=\"container\" style=\"padding: 20px\">"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\Text
t -> Text
"<h4>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</h4>") Maybe Text
title
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"Waiting for chart..." Maybe Text
mChart
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</div></body></html>"
renderChartHtmlPush :: Maybe Text -> Maybe Text -> BL.ByteString
renderChartHtmlPush :: Maybe Text -> Maybe Text -> ByteString
renderChartHtmlPush Maybe Text
title Maybe Text
mChart =
ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$
Text
"<!DOCTYPE html><html><head><meta charset=\"utf-8\"><title>"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"prettychart" Maybe Text
title
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</title></head><body>"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"<div class=\"container\" style=\"padding: 20px\">"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (\Text
t -> Text
"<h4>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</h4>") Maybe Text
title
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"Waiting for chart..." Maybe Text
mChart
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</div></body></html>"
startChartServerHyperbole :: ChartServerConfig -> IO (Text -> IO Bool, IO ())
startChartServerHyperbole :: ChartServerConfig -> IO (Text -> IO Bool, IO ())
startChartServerHyperbole ChartServerConfig
cfg = do
chartRef <- Maybe Text -> IO (IORef (Maybe Text))
forall a. a -> IO (IORef a)
newIORef Maybe Text
forall a. Maybe a
Nothing
serverAsync <- async $
run (serverPort cfg) $ \Request
_ Response -> IO ResponseReceived
respond -> do
mChart <- IORef (Maybe Text) -> IO (Maybe Text)
forall a. IORef a -> IO a
readIORef IORef (Maybe Text)
chartRef
let html = Maybe Text -> Maybe Text -> ByteString
renderChartHtml (ChartServerConfig -> Maybe Text
serverTitle ChartServerConfig
cfg) Maybe Text
mChart
let response = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
ok200 [(HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")] ByteString
html
respond response
threadDelay 100000
putStrLn $ "Chart server listening on port " <> show (serverPort cfg)
putStrLn $ "Open browser to http://localhost:" <> show (serverPort cfg)
putStrLn "(ctrl-c to quit)"
let sendChart Text
content = do
IORef (Maybe Text) -> Maybe Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Text)
chartRef (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
content)
String -> IO ()
putStrLn String
"chartRef updated"
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
let quitServer = Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
serverAsync
pure (sendChart, quitServer)
startChartServerPush :: ChartServerConfig -> IO (Text -> IO Bool, IO ())
startChartServerPush :: ChartServerConfig -> IO (Text -> IO Bool, IO ())
startChartServerPush ChartServerConfig
cfg = do
chartRef <- Maybe Text -> IO (IORef (Maybe Text))
forall a. a -> IO (IORef a)
newIORef Maybe Text
forall a. Maybe a
Nothing
serverAsync <- async $
run (serverPort cfg) $ \Request
_ Response -> IO ResponseReceived
respond -> do
mChart <- IORef (Maybe Text) -> IO (Maybe Text)
forall a. IORef a -> IO a
readIORef IORef (Maybe Text)
chartRef
let html = Maybe Text -> Maybe Text -> ByteString
renderChartHtmlPush (ChartServerConfig -> Maybe Text
serverTitle ChartServerConfig
cfg) Maybe Text
mChart
let response = Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
ok200 [(HeaderName
"Content-Type", ByteString
"text/html; charset=utf-8")] ByteString
html
respond response
threadDelay 100000
putStrLn $ "Chart server (push mode) listening on port " <> show (serverPort cfg)
putStrLn $ "Open browser to http://localhost:" <> show (serverPort cfg)
putStrLn "(ctrl-c to quit)"
let sendChart Text
content = do
IORef (Maybe Text) -> Maybe Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Text)
chartRef (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
content)
String -> IO ()
putStrLn String
"chartRef updated"
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
let quitServer = Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
serverAsync
pure (sendChart, quitServer)