Server.hs

{-# LANGUAGE OverloadedStrings #-}
module Charts.Internal.Server where


import Charts.Internal.Chart
import Network.Wai
import Network.Wai.Handler.Warp
import Network.HTTP.Types.Status
import Data.Aeson
import Paths_charter
import Control.Concurrent.Async
import System.Process
import Control.Monad
import Control.Concurrent.MVar

-- | Serve a chart, updating along with the MVar
chartApp :: MVar Chart -> FilePath -> Application
chartApp chartVar indexFile req handler
      | pathInfo req == ["data"] = do
          chart <- readMVar chartVar
          handler (responseLBS ok200 [("Content-Type", "application/json")] (encode chart))
      | otherwise = do
          handler (responseFile ok200 mempty indexFile Nothing)

-- | Serve a single static chart on the given port
serveChart :: Port ->  Chart -> IO ()
serveChart port chart = do
    serveDynamicChart port (\handler -> handler (chart{dynamic=False}))

-- | Serve a chart on the given port.
-- The application can update the chart using the given handler.
serveDynamicChart :: Port -> ((Chart -> IO ()) -> IO ()) -> IO ()
serveDynamicChart port handler = do
    indexHtml <- getDataFileName "templates/index.html"
    chartVar <- newEmptyMVar
    let runServer = run port (chartApp chartVar indexHtml)
    let runHandler = handler (updateChart chartVar)
    withAsync (concurrently_ runServer runHandler) $ \procHandle -> do
        void $ spawnProcess "open" [("http://localhost:" <> show port)]
        wait procHandle
  where
    updateChart :: MVar Chart -> Chart -> IO ()
    updateChart var c = void $ do
      isEmpty <- isEmptyMVar var
      if isEmpty then putMVar var c
                 else void $ swapMVar var c