{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Reflex.LibTelnet
( telnet
, TelnetConfig(..)
, TelnetEvents(..)
, cOptions
, cFlags
, cRecv
, cSend
, cIac
, cNegotiate
, cSubnegotiation
, cBeginCompress2
, cNewEnvironSend
, cNewEnviron
, cTTypeSend
, cTTypeIs
, cSendZmp
, cSendMssp
, eReceived
, eSend
, eWarning
, eError
, eIac
, eWill
, eWont
, eDo
, eDont
, eSubnegotiation
, eZmp
, eTerminalTypeSend
, eTerminalTypeIs
, eCompress
, eEnvironSend
, eEnviron
, eMssp
, eException
) where
import Control.Exception (catch)
import Control.Lens (Lens', (^.), makeLenses)
import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString (ByteString)
import Data.Default (Default(..))
import qualified Data.Dependent.Map as DMap
import Data.Dependent.Sum ((==>))
import Data.Functor ((<&>))
import Data.GADT.Compare.TH (deriveGCompare, deriveGEq)
import Data.GADT.Show.TH (deriveGShow)
import Network.Telnet.LibTelnet (Telnet)
import qualified Network.Telnet.LibTelnet as Telnet
import Network.Telnet.LibTelnet.Iac (Iac)
import Network.Telnet.LibTelnet.Options (Option)
import Reflex
data TelnetConfig t = TelnetConfig
{ _cOptions :: [Telnet.OptionSpec]
, _cFlags :: [Telnet.Flag]
, _cRecv :: Event t ByteString
, _cSend :: Event t ByteString
, _cIac :: Event t Iac
, _cNegotiate :: Event t (Iac, Option)
, _cSubnegotiation :: Event t (Option, ByteString)
, _cBeginCompress2 :: Event t ()
, _cNewEnvironSend :: Event t [(Telnet.Var, ByteString)]
, _cNewEnviron :: Event t ( Telnet.IsInfo
, [(Telnet.Var, ByteString, ByteString)]
)
, _cTTypeSend :: Event t ()
, _cTTypeIs :: Event t ByteString
, _cSendZmp :: Event t [ByteString]
, _cSendMssp :: Event t [(ByteString, [ByteString])]
}
$(makeLenses ''TelnetConfig)
instance Reflex t => Default (TelnetConfig t) where
def = TelnetConfig
{ _cOptions = []
, _cFlags = []
, _cRecv = never
, _cSend = never
, _cIac = never
, _cNegotiate = never
, _cSubnegotiation = never
, _cBeginCompress2 = never
, _cNewEnvironSend = never
, _cNewEnviron = never
, _cTTypeSend = never
, _cTTypeIs = never
, _cSendZmp = never
, _cSendMssp = never
}
data TelnetEvents t = TelnetEvents
{ _eReceived :: Event t ByteString
, _eSend :: Event t ByteString
, _eWarning :: Event t Telnet.Err
, _eError :: Event t Telnet.Err
, _eIac :: Event t Iac
, _eWill :: Event t Option
, _eWont :: Event t Option
, _eDo :: Event t Option
, _eDont :: Event t Option
, _eSubnegotiation :: Event t (Option, ByteString)
, _eZmp :: Event t [ByteString]
, _eTerminalTypeSend :: Event t ()
, _eTerminalTypeIs :: Event t ByteString
, _eCompress :: Event t Bool
, _eEnvironSend :: Event t [(Telnet.Var, ByteString)]
, _eEnviron :: Event t (Telnet.IsInfo, [(Telnet.Var, ByteString, ByteString)])
, _eMssp :: Event t [(ByteString, [ByteString])]
, _eException :: Event t Telnet.TelnetException
}
$(makeLenses ''TelnetEvents)
data EventKey a where
Received :: EventKey ByteString
Send :: EventKey ByteString
Warning :: EventKey Telnet.Err
Error :: EventKey Telnet.Err
Iac :: EventKey Iac
Will :: EventKey Option
Wont :: EventKey Option
Do :: EventKey Option
Dont :: EventKey Option
Subnegotiation :: EventKey (Option, ByteString)
Zmp :: EventKey [ByteString]
TerminalTypeSend :: EventKey ()
TerminalTypeIs :: EventKey ByteString
Compress :: EventKey Bool
EnvironSend :: EventKey [(Telnet.Var, ByteString)]
Environ :: EventKey (Telnet.IsInfo, [(Telnet.Var, ByteString, ByteString)])
Mssp :: EventKey [(ByteString, [ByteString])]
$(deriveGEq ''EventKey)
$(deriveGCompare ''EventKey)
$(deriveGShow ''EventKey)
telnet
:: forall t m .
( MonadIO m, MonadIO (Performable m)
, PerformEvent t m
, TriggerEvent t m
)
=> TelnetConfig t
-> m (TelnetEvents t)
telnet config = do
(telnetE, fireTelnetE) <- newTriggerEvent
(telnetExcE, fireTelnetExcE) <- newTriggerEvent
t <- liftIO $ Telnet.telnetInit
(config ^. cOptions)
(config ^. cFlags)
(const fireTelnetE)
let
perform
:: (Telnet -> a -> IO ())
-> Lens' (TelnetConfig t) (Event t a)
-> m ()
perform f l = performEvent_ $ action <$> config ^. l where
action x = liftIO $ f t x `catch` \(ex :: Telnet.TelnetException) ->
fireTelnetExcE ex
perform Telnet.telnetRecv cRecv
perform Telnet.telnetSend cSend
perform Telnet.telnetIac cIac
perform (uncurry . Telnet.telnetNegotiate) cNegotiate
perform (uncurry . Telnet.telnetSubnegotiation) cSubnegotiation
perform (const . Telnet.telnetBeginCompress2) cBeginCompress2
perform Telnet.telnetNewEnvironSend cNewEnvironSend
perform (uncurry . Telnet.telnetNewEnviron) cNewEnviron
perform (const . Telnet.telnetTTypeSend) cTTypeSend
perform Telnet.telnetTTypeIs cTTypeIs
perform Telnet.telnetSendZmp cSendZmp
perform Telnet.telnetSendMssp cSendMssp
let
selector :: EventSelector t EventKey
selector = fan $ telnetE <&> DMap.fromList . pure . \case
Telnet.Received b -> Received ==> b
Telnet.Send b -> Send ==> b
Telnet.Warning e -> Warning ==> e
Telnet.Error e -> Error ==> e
Telnet.Iac i -> Iac ==> i
Telnet.Will o -> Will ==> o
Telnet.Wont o -> Wont ==> o
Telnet.Do o -> Do ==> o
Telnet.Dont o -> Dont ==> o
Telnet.Subnegotiation o b -> Subnegotiation ==> (o, b)
Telnet.Zmp bs -> Zmp ==> bs
Telnet.TerminalTypeSend -> TerminalTypeSend ==> ()
Telnet.TerminalTypeIs term -> TerminalTypeIs ==> term
Telnet.Compress c -> Compress ==> c
Telnet.EnvironSend envs -> EnvironSend ==> envs
Telnet.Environ isInfo envs -> Environ ==> (isInfo, envs)
Telnet.Mssp msg -> Mssp ==> msg
pure $ TelnetEvents
{ _eReceived = selector `select` Received
, _eSend = selector `select` Send
, _eWarning = selector `select` Warning
, _eError = selector `select` Error
, _eIac = selector `select` Iac
, _eWill = selector `select` Will
, _eWont = selector `select` Wont
, _eDo = selector `select` Do
, _eDont = selector `select` Dont
, _eSubnegotiation = selector `select` Subnegotiation
, _eZmp = selector `select` Zmp
, _eTerminalTypeSend = selector `select` TerminalTypeSend
, _eTerminalTypeIs = selector `select` TerminalTypeIs
, _eCompress = selector `select` Compress
, _eEnvironSend = selector `select` EnvironSend
, _eEnviron = selector `select` Environ
, _eMssp = selector `select` Mssp
, _eException = telnetExcE
}