Utility.hs

{-# LANGUAGE OverloadedStrings #-}

module PMS.Infra.Agent.Serial.DS.Utility where

import Control.Lens
import System.Log.FastLogger
import qualified Control.Exception.Safe as E
import Control.Monad.IO.Class
import Control.Monad.Except
import Control.Monad.Reader
import qualified Control.Concurrent.STM as STM
import System.Hardware.Serialport
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as C8
import Data.Char (toUpper)
import qualified Text.Read as R

import qualified PMS.Domain.Model.DM.Type as DM
import qualified PMS.Domain.Model.DS.Utility as DM
import PMS.Infra.Agent.Serial.DM.Type

-- |
--
runApp :: DM.DomainData -> AppData -> TimedFastLogger -> AppContext a -> IO (Either DM.ErrorData a)
runApp domDat appDat logger ctx =
  DM.runFastLoggerT domDat logger
    $ runExceptT
    $ flip runReaderT domDat
    $ runReaderT ctx appDat


-- |
--
liftIOE :: IO a -> AppContext a
liftIOE f = liftIO (go f) >>= liftEither
  where
    go :: IO b -> IO (Either String b)
    go x = E.catchAny (Right <$> x) errHdl

    errHdl :: E.SomeException -> IO (Either String a)
    errHdl = return . Left . show

---------------------------------------------------------------------------------
-- |
--
errorToolsCallResponse :: DM.JsonRpcRequest -> String -> AppContext ()
errorToolsCallResponse jsonRpc errStr = do
  let content = [ DM.McpToolsCallResponseResultContent "text" errStr ]
      result = DM.McpToolsCallResponseResult {
                  DM._contentMcpToolsCallResponseResult = content
                , DM._isErrorMcpToolsCallResponseResult = True
                }
      resDat = DM.McpToolsCallResponseData jsonRpc result
      res = DM.McpToolsCallResponse resDat

  resQ <- view DM.responseQueueDomainData <$> lift ask
  liftIOE $ STM.atomically $ STM.writeTQueue resQ res



---------------------------------------------------------------------------------
-- | Decode an uppercase/lowercase hex string to a ByteString.
-- Input is uppercased before decoding to tolerate mixed case (e.g. "000a1BFF").
-- Returns Left with an error message if the input is not valid hex.
hexToBytes :: String -> Either String BS.ByteString
hexToBytes hex =
  case B16.decode (C8.pack (map toUpper hex)) of
    Right bs  -> Right bs
    Left  err -> Left $ "hexToBytes: invalid hex string: " ++ err


getCommSpeed :: Int -> AppContext CommSpeed
getCommSpeed n = case R.readMaybe ("CS" ++ show n) of
  Just cs -> return cs
  Nothing -> throwError $ "invalid comm speed: " ++ show n

-- |
--
getStopBits :: Maybe Int -> StopBits
getStopBits (Just 2) = Two
getStopBits _        = One

-- |
--
getParity :: Maybe String -> Parity
getParity (Just "Odd")  = Odd
getParity (Just "Even") = Even
getParity _             = NoParity

-- |
--
getFlowControl :: Maybe String -> FlowControl
getFlowControl (Just "Software") = Software
getFlowControl _                 = NoFlowControl

-- |
--
getSerialSetting :: SerialToolParams -> AppContext SerialPortSettings
getSerialSetting params = do
  cs <- case params^.commSpeedSerialToolParams of
          Just n  -> getCommSpeed n
          Nothing -> return $ commSpeed defaultSerialSettings
  let bpw  = maybe (bitsPerWord defaultSerialSettings) fromIntegral
                   (params^.bitsPerWordSerialToolParams)
      sb   = getStopBits    (params^.stopbSerialToolParams)
      par  = getParity      (params^.paritySerialToolParams)
      fc   = getFlowControl (params^.flowControlSerialToolParams)
      tout = maybe 1 id     (params^.timeoutSerialToolParams)
  return defaultSerialSettings {
      commSpeed   = cs
    , bitsPerWord = bpw
    , stopb       = sb
    , parity      = par
    , flowControl = fc
    , timeout     = tout
    }