robocom-zero/src/ATrade/Driver/Junction/RemoteControl.hs

{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE OverloadedStrings #-}

module ATrade.Driver.Junction.RemoteControl
  (
    handleRemoteControl
  ) where

import           ATrade.Driver.Junction.JunctionMonad (JunctionEnv (peLogAction, peRemoteControlSocket, peRobots),
                                                       JunctionM)
import           ATrade.Driver.Junction.Types         (StrategyInstanceDescriptor)
import           ATrade.Logging                       (logErrorWith)
import           Control.Monad                        (unless)
import           Control.Monad.Reader                 (asks)
import           Data.Aeson                           (decode)
import qualified Data.ByteString                      as B
import qualified Data.ByteString.Lazy                 as BL
import qualified Data.Map.Strict                      as M
import qualified Data.Text                            as T
import           Data.Text.Encoding                   (decodeUtf8', encodeUtf8)
import           System.ZMQ4                          (Event (In), Poll (Sock),
                                                       poll, receive, send)
import           UnliftIO                             (MonadIO (liftIO))

data RemoteControlResponse =
    ResponseOk
  | ResponseError T.Text
  deriving (Show, Eq)

data RemoteControlRequest =
    StartRobot StrategyInstanceDescriptor
  | StopRobot T.Text
  | ReloadConfig T.Text
  | SetState T.Text B.ByteString
  | Ping
  deriving (Show)

data ParseError =
    UnknownCmd
  | UtfDecodeError
  | JsonDecodeError
  deriving (Show, Eq)

parseRemoteControlRequest :: B.ByteString -> Either ParseError RemoteControlRequest
parseRemoteControlRequest bs =
  if
    | cmd == "START" -> parseStart
    | cmd == "STOP" -> parseStop
    | cmd == "RELOAD_CONFIG" -> parseReloadConfig
    | cmd == "SET_STATE" -> parseSetState
    | cmd == "PING" -> Right Ping
    | otherwise -> Left UnknownCmd
  where
    cmd = B.takeWhile (/= 0x20) bs
    rest = B.dropWhile (== 0x20) . B.dropWhile (/= 0x20) $ bs

    parseStart = case decode . BL.fromStrict $ rest of
      Just inst -> Right (StartRobot inst)
      Nothing   -> Left JsonDecodeError

    parseStop = case decodeUtf8' rest of
      Left _  -> Left UtfDecodeError
      Right r -> Right (StopRobot (T.strip r))

    parseReloadConfig = case decodeUtf8' rest of
      Left _  -> Left UtfDecodeError
      Right r -> Right (ReloadConfig (T.strip r))

    parseSetState = case decodeUtf8' (B.takeWhile (/= 0x20) rest) of
      Left _  -> Left UtfDecodeError
      Right r -> Right (SetState r (B.dropWhile (== 0x20) . B.dropWhile (/= 0x20) $ rest))


makeRemoteControlResponse :: RemoteControlResponse -> B.ByteString
makeRemoteControlResponse ResponseOk          = "OK"
makeRemoteControlResponse (ResponseError msg) = "ERROR " <> encodeUtf8 msg

handleRemoteControl :: Int -> JunctionM ()
handleRemoteControl timeout = do
  sock <- asks peRemoteControlSocket
  logger <- asks peLogAction
  evs <- poll (fromIntegral timeout) [Sock sock [In] Nothing]
  unless (null evs) $ do
    rawRequest <- liftIO $ receive sock
    case parseRemoteControlRequest rawRequest of
      Left err      -> logErrorWith logger "RemoteControl" ("Unable to parse request: " <> (T.pack . show) err)
      Right request -> do
        response <- handleRequest request
        liftIO $ send sock [] (makeRemoteControlResponse response)
  where
    handleRequest (StartRobot inst)          = undefined
    handleRequest (StopRobot instId)         = undefined
    handleRequest (ReloadConfig instId)      = undefined
    handleRequest (SetState instId rawState) = undefined
    handleRequest Ping                       = return ResponseOk