WebSockets attempt

Main.hs

--------------------------------------------------------------------------------
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
module Main
  ( main
  ) where
--------------------------------------------------------------------------------
import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.Async as Async
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Exception as Exception
import qualified Data.Aeson as Aeson
import qualified Data.Foldable as Foldable
import qualified Data.Text as Text
import qualified Data.Text.IO as TextIO
import qualified Network.WebSockets as WebSockets
--------------------------------------------------------------------------------
import           Control.Concurrent.MVar (MVar)
import           Control.Monad (when)
import           Data.Function ((&))
import           Data.Text (Text)
--------------------------------------------------------------------------------
import qualified History as History
import qualified Metrics as Metrics
--------------------------------------------------------------------------------
import           History (History(..))
import           Metrics (Uptime(..))
--------------------------------------------------------------------------------

type Clients = [WebSockets.Connection]

data State =
  State { clients :: [WebSockets.Connection]
        , history :: History
        }

-- | Our application's main loop
-- Continuously get the `uptime`, decode the result, store 10 minutes worth in
-- the application state, and push the updates to connected clients over a
-- socket.
main :: IO ()
main = do
  state <- mkState
  a <- Async.async $ do
    Exception.finally (doMain state) logErrors

  b <- Async.async $ do
    WebSockets.runServer host port (application state)

  c <- Async.async $ do
    WebSockets.runClient host port "/" client

  Foldable.mapM_ Async.wait [a, b, c]
  where
    host = "127.0.0.1"
    port = 9160

logErrors :: IO ()
logErrors = putStrLn "Done."

client :: WebSockets.ClientApp ()
client conn = do
  Concurrent.threadDelay (2 * 1000000)
  WebSockets.sendTextData conn ("Hello, server!"::Text)

doMain :: MVar State -> IO ()
doMain serverState = do
  State{clients, history} <- MVar.readMVar serverState
  up <- Metrics.uptime
  putStrLn $ "Num connected clients: " <> show (length clients)
  case up of
    Just uptime -> do
      -- broadcast uptime clients
      Concurrent.threadDelay (seconds 1)
      MVar.modifyMVar_
        serverState
        (\s@State{history} -> pure $ s { history = History.push uptime history })
      when (length clients > 0) $ do
        broadcast uptime clients
      doMain serverState
    _ -> do
      Concurrent.threadDelay (seconds 1)
      doMain serverState
  where
    seconds = (* 1000000)

-- | Handles incoming socket connections
application :: MVar State -> WebSockets.ServerApp
application serverState pending = do
  conn <- WebSockets.acceptRequest pending
  WebSockets.forkPingThread conn 30
  MVar.modifyMVar_
    serverState
    (\s@State{clients} -> pure $ s { clients = conn:clients })

-- | Sends the encoded Uptime to all connected clients
broadcast :: Uptime -> Clients -> IO ()
broadcast uptime clients = do
  Foldable.forM_ clients
    (\client -> do
        WebSockets.sendTextData client (Aeson.encode uptime))

-- | Returns the default state for the application wrapped in an MVar
mkState :: IO (MVar State)
mkState = MVar.newMVar $
  State { clients = [], history = History.def }