monomer/examples/ticker/Main.hs

{-|
Module      : Main
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Main module for the 'Ticker' example.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Control.Concurrent
import Control.Concurrent.STM.TChan
import Control.Lens
import Control.Monad (forever, forM_, void, when)
import Control.Monad.IO.Class
import Control.Monad.STM
import Data.Aeson
import Data.Default
import Data.Foldable (foldl')
import Data.Maybe
import Data.Text (Text)

import qualified Formatting as F
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Network.Wreq as W
import qualified Network.WebSockets as WS
import qualified Wuss

import Monomer

import BinanceTypes
import TickerTypes

import qualified Monomer.Lens as L

type TickerWenv = WidgetEnv TickerModel TickerEvt
type TickerNode = WidgetNode TickerModel TickerEvt

tickerPct :: Ticker -> TickerNode
tickerPct t = pctLabel where
  diff = 100 * (t ^. close - t ^. open)
  pct = diff / t ^. open

  pctText = formatTickerPct pct <> "%"
  pctColor
    | abs pct < 0.01 = rgbHex "#428FE0"
    | pct > 0 = rgbHex "#51A39A"
    | otherwise = rgbHex "#E25141"

  pctLabel = label pctText `styleBasic` [width 100, textRight, textColor pctColor]

tickerRow :: TickerWenv -> Int -> Ticker -> TickerNode
tickerRow wenv idx t = row where
  sectionBg = wenv ^. L.theme . L.sectionColor
  dragColor = rgbaHex "#D3D3D3" 0.5
  rowSep = rgbaHex "#A9A9A9" 0.5
  rowBg = wenv ^. L.theme . L.userColorMap . at "rowBg" . non def

  trashBg = wenv ^. L.theme . L.userColorMap . at "trashBg" . non def
  trashFg = wenv ^. L.theme . L.userColorMap . at "trashFg" . non def
  trashIcon action = button remixDeleteBinLine action
    `styleBasic` [textFont "Remix", textMiddle, textColor trashFg, bgColor transparent, border 0 transparent]
    `styleHover` [bgColor trashBg]
    `styleFocus` [bgColor (sectionBg & L.a .~ 0.5)]
    `styleFocusHover` [bgColor trashBg]

  dropTicker pair
    = dropTarget_ (TickerMovePair pair) [dropTargetStyle [bgColor darkGray]]

  tickerInfo = hstack [
      label (t ^. symbolPair) `styleBasic` [width 100],
      spacer,
      label (formatTickerValue (t ^. close))
        `styleBasic` [textRight, minWidth 100],
      spacer,
      tickerPct t
    ] `styleBasic` [cursorHand]

  row = hstack [
      dropTicker (t ^. symbolPair) $
        draggable_ (t ^. symbolPair) [draggableStyle [bgColor dragColor]]
          tickerInfo,
      spacer,
      trashIcon (TickerRemovePairBegin (t ^. symbolPair))
    ] `styleBasic` [padding 10, borderB 1 rowSep]
      `styleHover` [bgColor rowBg]

buildUI :: TickerWenv -> TickerModel -> TickerNode
buildUI wenv model = widgetTree where
  sectionBg = wenv ^. L.theme . L.sectionColor

  tickerList = vstack tickerRows where
    orderedTickers = (\e -> model ^? tickers . ix e) <$> model ^. symbolPairs
    tickerFade idx t = animRow where
      action = TickerRemovePair (t ^. symbolPair)
      item = tickerRow wenv idx t
      animRow = animFadeOut_ [onFinished action] item `nodeKey` (t ^. symbolPair)

    tickerRows = zipWith tickerFade [0..] (catMaybes orderedTickers)

  widgetTree = vstack [
      hstack [
        label "New pair:",
        spacer,
        keystroke [("Enter", TickerAddClick)] $ textField newPair `nodeKey` "newPair",
        spacer,
        button "Add" TickerAddClick
      ] `styleBasic` [padding 20, bgColor sectionBg],
      scroll_ [scrollOverlay] $ tickerList `styleBasic` [padding 10]
    ]

handleEvent
  :: AppEnv
  -> TickerWenv
  -> TickerNode
  -> TickerModel
  -> TickerEvt
  -> [EventResponse TickerModel TickerEvt TickerModel TickerEvt]
handleEvent env wenv node model evt = case evt of
  TickerInit -> [
    Model $ model
      & symbolPairs .~ initialList,
    Producer (startProducer env),
    Task (subscribeInitial env initialList),
    SetFocusOnKey "newPair"
    ]

  TickerAddClick -> [
    Model $ model
      & symbolPairs %~ (model ^. newPair <|)
      & newPair .~ "",
    Task $ subscribe env [model ^. newPair],
    SetFocusOnKey "newPair"
    ]

  TickerRemovePairBegin pair -> [
    Message (WidgetKey pair) AnimationStart]

  TickerRemovePair pair -> [
      Task $ unsubscribe env [pair],
      Model $ model & tickers . at pair .~ Nothing
    ]

  TickerMovePair target pair -> [
      Model $ model & symbolPairs .~ moveBefore (model^.symbolPairs) target pair
    ]

  TickerUpdate updates -> [
    Model (processTickerUpdates model updates)
    ]

  TickerError err -> [Task $ print ("Error", err) >> return TickerIgnore]

  TickerResponse resp -> [Task $ print ("Response", resp) >> return TickerIgnore]

  TickerIgnore -> []

processTickerUpdates :: TickerModel -> [Ticker] -> TickerModel
processTickerUpdates model updates = foldl' stepTicker model updates where
  stepTicker model ticker = model
    & tickers . at (ticker ^. symbolPair) ?~ ticker

handleSubscription :: AppEnv -> [Text] -> Text -> IO TickerEvt
handleSubscription env pairs action = do
  atomically $ writeTChan (env ^. channel) req
  return TickerIgnore
  where
    subscription pair = T.toLower pair <> "@miniTicker"
    req = ServerRequest 1 action (subscription <$> pairs)

subscribe :: AppEnv -> [Text] -> IO TickerEvt
subscribe env pairs = handleSubscription env pairs "SUBSCRIBE"

unsubscribe :: AppEnv -> [Text] -> IO TickerEvt
unsubscribe env pairs = handleSubscription env pairs "UNSUBSCRIBE"

moveBefore :: Eq a => [a] -> a -> a -> [a]
moveBefore list target item = result where
  result
    | target == item = list
    | otherwise = moveBefore_ cleanList target item
  cleanList = filter (/= item) list
  moveBefore_ [] target item = [item]
  moveBefore_ (x:xs) target item
    | x == target = item : x : xs
    | otherwise = x : moveBefore_ xs target item

startProducer :: AppEnv -> (TickerEvt -> IO ()) -> IO ()
startProducer env sendMsg = do
  groupChannel <- newTChanIO

  Wuss.runSecureClient url port path $ \connection -> do
    groupTickers groupChannel sendMsg
    receiveWs connection groupChannel sendMsg
    sendWs (env ^. channel) connection
  where
    url = "stream.binance.com"
    port = 9443
    path = "/ws"

subscribeInitial :: AppEnv -> [Text] -> IO TickerEvt
subscribeInitial env initialList = do
  threadDelay 500000
  subscribe env initialList

groupTickers :: TChan Ticker -> (TickerEvt -> IO a) -> IO ()
groupTickers channel sendMsg = void . forkIO . forever $ do
  ticker <- atomically $ readTChan channel
  tickers <- collectJustM . atomically $ tryReadTChan channel
  sendMsg $ TickerUpdate (ticker : tickers)

  threadDelay $ 500 * 1000

receiveWs :: WS.Connection -> TChan Ticker -> (TickerEvt -> IO ()) -> IO ()
receiveWs conn groupChannel sendMsg = void . forkIO . forever $ do
  msg <- WS.receiveData conn
  let serverMsg = decode msg

  forM_ serverMsg $ \case
    MsgResponse resp -> sendMsg $ TickerResponse resp
    MsgError err -> sendMsg $ TickerError err
    MsgTicker ticker -> atomically $ writeTChan groupChannel ticker

sendWs :: (Show a, ToJSON a) => TChan a -> WS.Connection -> IO ()
sendWs channel connection = forever $ do
  msg <- atomically $ readTChan channel
  WS.sendTextData connection (encode msg)

main :: IO ()
main = do
  channel <- newTChanIO
  let env = AppEnv channel

  startApp initModel (handleEvent env) buildUI config
  where
    config = [
      appWindowTitle "Ticker",
      appWindowIcon "./assets/images/icon.png",
      appTheme customDarkTheme,
      appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",
      appFontDef "Remix" "./assets/fonts/remixicon.ttf",
      appInitEvent TickerInit
      ]
    initModel = def

customLightTheme :: Theme
customLightTheme = lightTheme
  & L.userColorMap . at "rowBg" ?~ rgbHex "#ECECEC"
  & L.userColorMap . at "trashBg" ?~ rgbHex "#D3D3D3"
  & L.userColorMap . at "trashFg" ?~ rgbHex "#808080"

customDarkTheme :: Theme
customDarkTheme = darkTheme
  & L.userColorMap . at "rowBg" ?~ rgbHex "#656565"
  & L.userColorMap . at "trashBg" ?~ rgbHex "#555555"
  & L.userColorMap . at "trashFg" ?~ rgbHex "#909090"

collectJustM :: MonadIO m => m (Maybe a) -> m [a]
collectJustM action = do
  x <- action
  case x of
    Nothing -> return []
    Just x -> do
      xs <- collectJustM action
      return (x : xs)

formatTickerValue :: FixedFloat -> Text
formatTickerValue = F.sformat (F.fixed 8)

formatTickerPct :: FixedFloat -> Text
formatTickerPct = F.sformat (F.fixed 2)

initialList :: [Text]
initialList = ["BTCUSDT", "ETHBTC", "BNBBTC", "ADABTC", "DOTBTC", "XRPBTC",
  "UNIBTC", "LTCBTC", "LINKBTC", "BCHBTC", "DOGEBTC", "THETABTC", "LUNABTC",
  "AAVEBTC", "CROBTC", "VETBTC", "XMRBTC", "ATOMBTC", "FTTBTC", "SOLBTC",
  "SXPBTC", "BATBTC", "VETBTC", "REEFBTC"]