LibTelnet.hs

{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}

{-|
Module      : Reflex.LibTelnet
Description : Reflex wrapper around libtelnet
Copyright   : (c) 2019, 2022 Jack Kelly
License     : GPL-3.0-or-later
Maintainer  : jack@jackkelly.name
Stability   : experimental
Portability : non-portable

How to run a libtelnet state tracker off Reflex 'Event's:

1. Construct a 'TelnetConfig' by using 'newTelnetConfig' to get an
   empty config, and then fill it out using record updates or lenses.

2. Start a state tracker by calling 'telnet' on your config.

3. Wire the events from the returned 'TelnetEvents' into the rest of
   your application.
-}

module Reflex.LibTelnet
  ( telnet

    -- * Input Events
  , TelnetConfig(..)
  , newTelnetConfig

    -- * Output Events
  , TelnetEvents(..)
  ) where

import           Control.Exception (catch)
import           Control.Monad.IO.Class (MonadIO(..))
import           Data.ByteString (ByteString)
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           GHC.Generics (Generic)
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

-- | A @'TelnetConfig' t@ contains all the input events for a telnet
-- state tracker. When passed to 'telnet', the network will call each
-- libtelnet function when its corresponding event fires. An "input
-- event" describes all events the state tracker listens to; it
-- doesn't care whether the events are coming from "above" or "below"
-- itself in the application stack. Data arriving on the socket
-- (@recv@) is an "input event" from "below"; data pasing through
-- libtelnet on its way out to the socket (@send@) is also an "input
-- event", but from "above".
--
-- You will almost certainly want to:
--
-- 1. use 'newTelnetConfig' to get an empty 'TelnetConfig';
-- 2. replace the @recv@ event with incoming socket data; and
-- 3. replace the @send@ event with outgoing data from your application.
--
-- @since 0.1.0.0
data TelnetConfig t = TelnetConfig
  { options :: [Telnet.OptionSpec]
    -- ^ Passed to 'Telnet.telnetInit'
  , flags :: [Telnet.Flag]
    -- ^ Passed to 'Telnet.telnetInit'
  , recv :: Event t ByteString
    -- ^ 'Telnet.telnetRecv' - "I just received this data, please decode it"
  , send :: Event t ByteString
    -- ^ 'Telnet.telnetSend' - "I want to send this data out, please encode it"
  , iac :: Event t Iac
    -- ^ 'Telnet.telnetIac'
  , negotiate :: Event t (Iac, Option)
    -- ^ 'Telnet.telnetNegotiate'
  , subnegotiation :: Event t (Option, ByteString)
    -- ^ 'Telnet.telnetSubnegotiation'
  , beginCompress2 :: Event t ()
    -- ^ 'Telnet.telnetBeginCompress2'
  , newEnvironSend :: Event t [(Telnet.Var, ByteString)]
    -- ^ 'Telnet.telnetNewEnvironSend'
  , newEnviron :: Event t ( Telnet.IsInfo
                            , [(Telnet.Var, ByteString, ByteString)]
                            )
    -- ^ 'Telnet.telnetNewEnviron'
  , tTypeSend :: Event t ()
    -- ^ 'Telnet.telnetTTypeSend'
  , tTypeIs :: Event t ByteString
    -- ^ 'Telnet.telnetTTypeIs'
  , sendZmp :: Event t [ByteString]
    -- ^ 'Telnet.telnetSendZmp'
  , sendMssp :: Event t [(ByteString, [ByteString])]
    -- ^ 'Telnet.telnetSendMssp'
  }
  deriving Generic -- ^ @since 0.2.0.0

-- | No options set and all events are 'never'.
--
-- @since 0.2.0.0
newTelnetConfig :: Reflex t => TelnetConfig t
newTelnetConfig = TelnetConfig
  { options = []
  , flags = []
  , recv = never
  , send = never
  , iac = never
  , negotiate = never
  , subnegotiation = never
  , beginCompress2 = never
  , newEnvironSend = never
  , newEnviron = never
  , tTypeSend = never
  , tTypeIs = never
  , sendZmp = never
  , sendMssp = never
  }

-- | The libtelnet 'Telnet.Event' type is fanned out into a set of
-- individual "output events". An "output event" describes all events
-- that should be listened to, regardless of whether they are going
-- "up" or "down" the application stack: parsed data (@received@) is
-- an "output event" that should be listened to by the layer "above";
-- encoded data that should go to a socket (@send@) is also an
-- "output event", but listened to by the layer below.
--
-- @since 0.1.0.0
data TelnetEvents t = TelnetEvents
  { received :: Event t ByteString
    -- ^ 'Telnet.Received' - "Here is some decoded data, please send
    -- it up to the application"
  , send :: Event t ByteString
    -- ^ 'Telnet.Send' - "Here is some encoded data, please send it
    -- out on the socket"
  , warning :: Event t Telnet.Err
    -- ^ 'Telnet.Warning'
  , error :: Event t Telnet.Err
    -- ^ 'Telnet.Error'
  , iac :: Event t Iac
    -- ^ 'Telnet.Iac'
  , will :: Event t Option
    -- ^ 'Telnet.Will'
  , wont :: Event t Option
    -- ^ 'Telnet.Wont'
  , do_ :: Event t Option
    -- ^ 'Telnet.Do'
  , dont :: Event t Option
    -- ^ 'Telnet.Dont'
  , subnegotiation :: Event t (Option, ByteString)
    -- ^ 'Telnet.Subnegotiation'
  , zmp :: Event t [ByteString]
    -- ^ 'Telnet.Zmp'
  , terminalTypeSend :: Event t ()
    -- ^ 'Telnet.TerminalTypeSend'
  , terminalTypeIs :: Event t ByteString
    -- ^ 'Telnet.TerminalTypeIs'
  , compress :: Event t Bool
    -- ^ 'Telnet.Compress'
  , environSend :: Event t [(Telnet.Var, ByteString)]
    -- ^ 'Telnet.EnvironSend'
  , environ :: Event t (Telnet.IsInfo, [(Telnet.Var, ByteString, ByteString)])
    -- ^ 'Telnet.Environ'
  , mssp :: Event t [(ByteString, [ByteString])]
    -- ^ 'Telnet.Mssp'
  , exception :: Event t Telnet.TelnetException
    -- ^ Exceptions thrown by the binding are caught and emitted
    -- here. Protocol errors and warnings are emitted on the
    -- @warning@ and @error@ events.
  }
  deriving Generic -- ^ @since 0.2.0.0

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)

-- | Process telnet streams using
-- <https://github.com/seanmiddleditch/libtelnet libtelnet>. Use
-- 'newTelnetConfig' to get a @'TelnetConfig' t@, and update it as
-- required.
--
-- @since 0.1.0.0
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
    (options config)
    (flags config)
    (const fireTelnetE)

  let
    perform
      :: (Telnet -> a -> IO ())
      -> (TelnetConfig t -> Event t a)
      -> m ()
    perform act get = performEvent_ $ action <$> get config where
      action x = liftIO $ act t x `catch` \(ex :: Telnet.TelnetException) ->
        fireTelnetExcE ex

  perform Telnet.telnetRecv recv
  perform Telnet.telnetSend send
  perform Telnet.telnetIac iac
  perform (uncurry . Telnet.telnetNegotiate) negotiate
  perform (uncurry . Telnet.telnetSubnegotiation) subnegotiation
  perform (const . Telnet.telnetBeginCompress2) beginCompress2
  perform Telnet.telnetNewEnvironSend newEnvironSend
  perform (uncurry . Telnet.telnetNewEnviron) newEnviron
  perform (const . Telnet.telnetTTypeSend) tTypeSend
  perform Telnet.telnetTTypeIs tTypeIs
  perform Telnet.telnetSendZmp sendZmp
  perform Telnet.telnetSendMssp sendMssp

  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
    { received = selector `select` Received
    , send = selector `select` Send
    , warning = selector `select` Warning
    , error = selector `select` Error
    , iac = selector `select` Iac
    , will = selector `select` Will
    , wont = selector `select` Wont
    , do_ = selector `select` Do
    , dont = selector `select` Dont
    , subnegotiation  = selector `select` Subnegotiation
    , zmp = selector `select` Zmp
    , terminalTypeSend = selector `select` TerminalTypeSend
    , terminalTypeIs = selector `select` TerminalTypeIs
    , compress = selector `select` Compress
    , environSend = selector `select` EnvironSend
    , environ = selector `select` Environ
    , mssp = selector `select` Mssp
    , exception = telnetExcE
    }