{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Network.SLCAN
  ( Transport(..)
  , withSLCANTransport
  , sendSLCANMessage
  , sendSLCANControl
  , recvSLCANMessage
  , sendCANMessage
  , module Network.SLCAN.Types
  , SLCANT(..)
  , SLCANException(..)
  , runSLCAN
  ) where

import Control.Exception (Exception)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader, ask)
import Control.Monad.Trans (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..))

import Network.Socket (Socket, SockAddr)
import Network.CAN (CANMessage, MonadCAN(..))
import Network.SLCAN.Types
import System.IO (Handle)
import UnliftIO (MonadUnliftIO)

import qualified Control.Monad
import qualified Control.Exception
import qualified Data.ByteString
import qualified Data.ByteString.Char8
import qualified System.IO
import qualified Network.SLCAN.Builder
import qualified Network.SLCAN.Parser
import qualified Network.Socket.ByteString
import qualified UnliftIO

data Transport =
    Transport_Handle Handle
  | Transport_UDP Socket SockAddr

withSLCANTransport
  :: Transport
  -> SLCANConfig
  -> (Transport -> IO a)
  -> IO a
withSLCANTransport :: forall a. Transport -> SLCANConfig -> (Transport -> IO a) -> IO a
withSLCANTransport Transport
transport SLCANConfig{Bool
SLCANBitrate
slCANConfigBitrate :: SLCANBitrate
slCANConfigResetErrors :: Bool
slCANConfigListenOnly :: Bool
slCANConfigListenOnly :: SLCANConfig -> Bool
slCANConfigResetErrors :: SLCANConfig -> Bool
slCANConfigBitrate :: SLCANConfig -> SLCANBitrate
..} Transport -> IO a
act = do
  let sendC :: SLCANControl -> IO ()
sendC = Transport -> SLCANControl -> IO ()
sendSLCANControl Transport
transport
  IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
Control.Exception.finally
    (do
       SLCANControl -> IO ()
sendC SLCANControl
SLCANControl_Close
       SLCANControl -> IO ()
sendC (SLCANBitrate -> SLCANControl
SLCANControl_Bitrate SLCANBitrate
slCANConfigBitrate)
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.when
         Bool
slCANConfigResetErrors
         (SLCANControl -> IO ()
sendC SLCANControl
SLCANControl_ResetErrors)
       SLCANControl -> IO ()
sendC
         (if Bool
slCANConfigListenOnly
          then SLCANControl
SLCANControl_ListenOnly
          else SLCANControl
SLCANControl_Open
         )

       Transport -> IO a
act Transport
transport
    )
    (SLCANControl -> IO ()
sendC SLCANControl
SLCANControl_Close)

sendSLCANMessage
  :: Transport
  -> SLCANMessage
  -> IO ()
sendSLCANMessage :: Transport -> SLCANMessage -> IO ()
sendSLCANMessage (Transport_Handle Handle
handle) SLCANMessage
msg = do
  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Control.Monad.void
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
Data.ByteString.hPutStr
        Handle
handle
        (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ SLCANMessage -> ByteString
Network.SLCAN.Builder.buildSLCANMessage
            SLCANMessage
msg
  Handle -> IO ()
System.IO.hFlush Handle
handle
sendSLCANMessage (Transport_UDP Socket
socket SockAddr
target) SLCANMessage
msg = do
  Socket -> ByteString -> SockAddr -> IO ()
Network.Socket.ByteString.sendAllTo
    Socket
socket
    (SLCANMessage -> ByteString
Network.SLCAN.Builder.buildSLCANMessage SLCANMessage
msg)
    SockAddr
target

sendSLCANControl
  :: Transport
  -> SLCANControl
  -> IO ()
sendSLCANControl :: Transport -> SLCANControl -> IO ()
sendSLCANControl Transport
t =
  Transport -> SLCANMessage -> IO ()
sendSLCANMessage Transport
t
  (SLCANMessage -> IO ())
-> (SLCANControl -> SLCANMessage) -> SLCANControl -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SLCANControl -> SLCANMessage
SLCANMessage_Control

recvSLCANMessage
  :: Transport
  -> IO (Either String SLCANMessage)
recvSLCANMessage :: Transport -> IO (Either String SLCANMessage)
recvSLCANMessage (Transport_Handle Handle
handle) = do
  ByteString -> Either String SLCANMessage
Network.SLCAN.Parser.parseSLCANMessage
  (ByteString -> Either String SLCANMessage)
-> IO ByteString -> IO (Either String SLCANMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
hGetTillCR Handle
handle

  where
    hGetTillCR :: Handle -> IO ByteString
hGetTillCR Handle
h = do
      ByteString
msg <-
        Handle -> Int -> IO ByteString
Data.ByteString.hGetSome
          Handle
h
          Int
1024
      if ByteString -> Char
Data.ByteString.Char8.last ByteString
msg Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'
      then ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
msg
      else Handle -> IO ByteString
hGetTillCR Handle
h IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
msg ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)

recvSLCANMessage (Transport_UDP Socket
socket SockAddr
_target) = do
  ByteString -> Either String SLCANMessage
Network.SLCAN.Parser.parseSLCANMessage
  (ByteString -> Either String SLCANMessage)
-> IO ByteString -> IO (Either String SLCANMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> IO ByteString
sockGetTillCR Socket
socket
  where
    sockGetTillCR :: Socket -> IO ByteString
sockGetTillCR Socket
s = do
      (ByteString
msg, SockAddr
_source) <-
        Socket -> Int -> IO (ByteString, SockAddr)
Network.Socket.ByteString.recvFrom
          Socket
s
          Int
1024
      if ByteString -> Char
Data.ByteString.Char8.last ByteString
msg Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r'
      then ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
msg
      else Socket -> IO ByteString
sockGetTillCR Socket
s IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
msg ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>)

sendCANMessage
  :: Transport
  -> CANMessage
  -> IO ()
sendCANMessage :: Transport -> CANMessage -> IO ()
sendCANMessage Transport
t =
  Transport -> SLCANMessage -> IO ()
sendSLCANMessage Transport
t
  (SLCANMessage -> IO ())
-> (CANMessage -> SLCANMessage) -> CANMessage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CANMessage -> SLCANMessage
SLCANMessage_Data

newtype SLCANT m a = SLCANT
  { forall (m :: * -> *) a. SLCANT m a -> ReaderT Transport m a
_unSLCANT :: ReaderT Transport m a }
  deriving
    ( (forall a b. (a -> b) -> SLCANT m a -> SLCANT m b)
-> (forall a b. a -> SLCANT m b -> SLCANT m a)
-> Functor (SLCANT m)
forall a b. a -> SLCANT m b -> SLCANT m a
forall a b. (a -> b) -> SLCANT m a -> SLCANT m b
forall (m :: * -> *) a b.
Functor m =>
a -> SLCANT m b -> SLCANT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SLCANT m a -> SLCANT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> SLCANT m a -> SLCANT m b
fmap :: forall a b. (a -> b) -> SLCANT m a -> SLCANT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> SLCANT m b -> SLCANT m a
<$ :: forall a b. a -> SLCANT m b -> SLCANT m a
Functor
    , Functor (SLCANT m)
Functor (SLCANT m) =>
(forall a. a -> SLCANT m a)
-> (forall a b. SLCANT m (a -> b) -> SLCANT m a -> SLCANT m b)
-> (forall a b c.
    (a -> b -> c) -> SLCANT m a -> SLCANT m b -> SLCANT m c)
-> (forall a b. SLCANT m a -> SLCANT m b -> SLCANT m b)
-> (forall a b. SLCANT m a -> SLCANT m b -> SLCANT m a)
-> Applicative (SLCANT m)
forall a. a -> SLCANT m a
forall a b. SLCANT m a -> SLCANT m b -> SLCANT m a
forall a b. SLCANT m a -> SLCANT m b -> SLCANT m b
forall a b. SLCANT m (a -> b) -> SLCANT m a -> SLCANT m b
forall a b c.
(a -> b -> c) -> SLCANT m a -> SLCANT m b -> SLCANT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (SLCANT m)
forall (m :: * -> *) a. Applicative m => a -> SLCANT m a
forall (m :: * -> *) a b.
Applicative m =>
SLCANT m a -> SLCANT m b -> SLCANT m a
forall (m :: * -> *) a b.
Applicative m =>
SLCANT m a -> SLCANT m b -> SLCANT m b
forall (m :: * -> *) a b.
Applicative m =>
SLCANT m (a -> b) -> SLCANT m a -> SLCANT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SLCANT m a -> SLCANT m b -> SLCANT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> SLCANT m a
pure :: forall a. a -> SLCANT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
SLCANT m (a -> b) -> SLCANT m a -> SLCANT m b
<*> :: forall a b. SLCANT m (a -> b) -> SLCANT m a -> SLCANT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> SLCANT m a -> SLCANT m b -> SLCANT m c
liftA2 :: forall a b c.
(a -> b -> c) -> SLCANT m a -> SLCANT m b -> SLCANT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
SLCANT m a -> SLCANT m b -> SLCANT m b
*> :: forall a b. SLCANT m a -> SLCANT m b -> SLCANT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
SLCANT m a -> SLCANT m b -> SLCANT m a
<* :: forall a b. SLCANT m a -> SLCANT m b -> SLCANT m a
Applicative
    , Applicative (SLCANT m)
Applicative (SLCANT m) =>
(forall a b. SLCANT m a -> (a -> SLCANT m b) -> SLCANT m b)
-> (forall a b. SLCANT m a -> SLCANT m b -> SLCANT m b)
-> (forall a. a -> SLCANT m a)
-> Monad (SLCANT m)
forall a. a -> SLCANT m a
forall a b. SLCANT m a -> SLCANT m b -> SLCANT m b
forall a b. SLCANT m a -> (a -> SLCANT m b) -> SLCANT m b
forall (m :: * -> *). Monad m => Applicative (SLCANT m)
forall (m :: * -> *) a. Monad m => a -> SLCANT m a
forall (m :: * -> *) a b.
Monad m =>
SLCANT m a -> SLCANT m b -> SLCANT m b
forall (m :: * -> *) a b.
Monad m =>
SLCANT m a -> (a -> SLCANT m b) -> SLCANT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
SLCANT m a -> (a -> SLCANT m b) -> SLCANT m b
>>= :: forall a b. SLCANT m a -> (a -> SLCANT m b) -> SLCANT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
SLCANT m a -> SLCANT m b -> SLCANT m b
>> :: forall a b. SLCANT m a -> SLCANT m b -> SLCANT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> SLCANT m a
return :: forall a. a -> SLCANT m a
Monad
    , MonadReader Transport
    , Monad (SLCANT m)
Monad (SLCANT m) =>
(forall a. IO a -> SLCANT m a) -> MonadIO (SLCANT m)
forall a. IO a -> SLCANT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (SLCANT m)
forall (m :: * -> *) a. MonadIO m => IO a -> SLCANT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> SLCANT m a
liftIO :: forall a. IO a -> SLCANT m a
MonadIO
    , MonadIO (SLCANT m)
MonadIO (SLCANT m) =>
(forall b. ((forall a. SLCANT m a -> IO a) -> IO b) -> SLCANT m b)
-> MonadUnliftIO (SLCANT m)
forall b. ((forall a. SLCANT m a -> IO a) -> IO b) -> SLCANT m b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
forall (m :: * -> *). MonadUnliftIO m => MonadIO (SLCANT m)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. SLCANT m a -> IO a) -> IO b) -> SLCANT m b
$cwithRunInIO :: forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. SLCANT m a -> IO a) -> IO b) -> SLCANT m b
withRunInIO :: forall b. ((forall a. SLCANT m a -> IO a) -> IO b) -> SLCANT m b
MonadUnliftIO
    )

instance MonadTrans SLCANT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> SLCANT m a
lift = ReaderT Transport m a -> SLCANT m a
forall (m :: * -> *) a. ReaderT Transport m a -> SLCANT m a
SLCANT (ReaderT Transport m a -> SLCANT m a)
-> (m a -> ReaderT Transport m a) -> m a -> SLCANT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT Transport m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Transport m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Run SLCANT transformer
runSLCANT
  :: Monad m
  => Transport
  -> SLCANT m a
  -> m a
runSLCANT :: forall (m :: * -> *) a. Monad m => Transport -> SLCANT m a -> m a
runSLCANT Transport
t =
    (ReaderT Transport m a -> Transport -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Transport
t)
  (ReaderT Transport m a -> m a)
-> (SLCANT m a -> ReaderT Transport m a) -> SLCANT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SLCANT m a -> ReaderT Transport m a
forall (m :: * -> *) a. SLCANT m a -> ReaderT Transport m a
_unSLCANT

data SLCANException = SLCANException_ParseError String
    deriving Int -> SLCANException -> ShowS
[SLCANException] -> ShowS
SLCANException -> String
(Int -> SLCANException -> ShowS)
-> (SLCANException -> String)
-> ([SLCANException] -> ShowS)
-> Show SLCANException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SLCANException -> ShowS
showsPrec :: Int -> SLCANException -> ShowS
$cshow :: SLCANException -> String
show :: SLCANException -> String
$cshowList :: [SLCANException] -> ShowS
showList :: [SLCANException] -> ShowS
Show

instance Exception SLCANException

runSLCAN
  :: ( MonadIO m
     , MonadUnliftIO m
     )
  => Transport
  -> SLCANConfig
  -> SLCANT m a
  -> m a
runSLCAN :: forall (m :: * -> *) a.
(MonadIO m, MonadUnliftIO m) =>
Transport -> SLCANConfig -> SLCANT m a -> m a
runSLCAN Transport
transport SLCANConfig
config SLCANT m a
act = do
  ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
UnliftIO.withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    Transport -> SLCANConfig -> (Transport -> IO a) -> IO a
forall a. Transport -> SLCANConfig -> (Transport -> IO a) -> IO a
withSLCANTransport
      Transport
transport
      SLCANConfig
config
      (\Transport
t -> m a -> IO a
forall a. m a -> IO a
runInIO (Transport -> SLCANT m a -> m a
forall (m :: * -> *) a. Monad m => Transport -> SLCANT m a -> m a
runSLCANT Transport
t SLCANT m a
act))

instance MonadIO m => MonadCAN (SLCANT m) where
  send :: CANMessage -> SLCANT m ()
send CANMessage
cm = do
    SLCANT m Transport
forall r (m :: * -> *). MonadReader r m => m r
ask SLCANT m Transport -> (Transport -> SLCANT m ()) -> SLCANT m ()
forall a b. SLCANT m a -> (a -> SLCANT m b) -> SLCANT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> SLCANT m ()
forall a. IO a -> SLCANT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SLCANT m ())
-> (Transport -> IO ()) -> Transport -> SLCANT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transport -> CANMessage -> IO ())
-> CANMessage -> Transport -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Transport -> CANMessage -> IO ()
sendCANMessage CANMessage
cm
  recv :: SLCANT m CANMessage
recv = do
    Transport
transport <- SLCANT m Transport
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO (Either String SLCANMessage)
-> SLCANT m (Either String SLCANMessage)
forall a. IO a -> SLCANT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (Transport -> IO (Either String SLCANMessage)
recvSLCANMessage Transport
transport)
    SLCANT m (Either String SLCANMessage)
-> (Either String SLCANMessage -> SLCANT m CANMessage)
-> SLCANT m CANMessage
forall a b. SLCANT m a -> (a -> SLCANT m b) -> SLCANT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left String
e ->
        SLCANException -> SLCANT m CANMessage
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
UnliftIO.throwIO (SLCANException -> SLCANT m CANMessage)
-> SLCANException -> SLCANT m CANMessage
forall a b. (a -> b) -> a -> b
$ String -> SLCANException
SLCANException_ParseError String
e
      Right (SLCANMessage_Data CANMessage
cm) ->
        CANMessage -> SLCANT m CANMessage
forall a. a -> SLCANT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CANMessage
cm
      Right SLCANMessage
_other ->
        -- TODO: do something with
        -- SLCANMessage_Error
        -- and SLCANMessage_State
        -- like allow registering handlers for these
        -- or throwIO on _Error one
        SLCANT m CANMessage
forall (m :: * -> *). MonadCAN m => m CANMessage
recv