content: {-|
  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"]
  