{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE MultiWayIf           #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE TypeSynonymInstances #-}

{-|
Module      : Network.Telnet.LibTelnet
Description : Bindings to C libtelnet
Copyright   : (c) 2017-2019 Jack Kelly
License     : GPL-3.0-or-later
Maintainer  : jack@jackkelly.name
Stability   : experimental
Portability : non-portable

Getting Started:

1. Skim
<https://github.com/seanmiddleditch/libtelnet the libtelnet documentation>,
as these bindings follow the C library's conventions quite closely.

2. Write an event-handling function, of type 'EventHandler'.

3. When you accept a new connection, create a 'Telnet' state
tracker for it using 'telnetInit'. Options and flags are defined in
the same way as the C library; option constants are exported from
"Network.Telnet.LibTelnet.Options".

4. When you receive data (probably on a socket), tell 'Telnet'
about it using 'telnetRecv'.

5. To send data, negotiate options, &c., use 'telnetSend',
'telnetIac', &c.

6. IAC (Interpret-As-Command) codes are exported from
"Network.Telnet.LibTelnet.Iac".
-}

module Network.Telnet.LibTelnet
  ( telnetInit
  , OptionSpec(..)
  , T.Flag
  , T.flagProxy

  -- * Telnet pointers
  , Telnet
  , TelnetPtr
  , HasTelnetPtr(..)

  -- * Event handling
  , EventHandler
  , Event(..)
  , Err(..)
  , IsInfo(..)
  , Var(..)

  -- * Simple operations
  , telnetRecv
  , telnetSend

  -- * Generic telnet option negotiation
  , telnetIac
  , telnetNegotiate
  , telnetSubnegotiation

  -- * Compression <http://www.gammon.com.au/mccp/protocol.html (MCCP2)>
  , telnetBeginCompress2

  -- * @NEW-ENVIRON@ functions <http://www.faqs.org/rfcs/rfc1572.html (RFC 1572)>
  , telnetNewEnvironSend
  , telnetNewEnviron

  -- * @TERMINAL-TYPE@ functions <http://www.faqs.org/rfcs/rfc1091.html (RFC 1091)>
  , telnetTTypeSend
  , telnetTTypeIs

  -- * ZMP <http://discworld.starturtle.net/external/protocols/zmp.html (Zenith Mud Protocol)>
  , telnetSendZmp

  -- * MSSP <http://tintin.sourceforge.net/mssp/ (Mud Server Status Protocol)>
  , telnetSendMssp

  -- * Exceptions
  , T.TelnetException(..)
  ) where

import qualified Network.Telnet.LibTelnet.Ffi as F
import qualified Network.Telnet.LibTelnet.Iac as I
import           Network.Telnet.LibTelnet.Options (Option(..), optMSSP)
import qualified Network.Telnet.LibTelnet.Types as T

import           Control.Exception (throw, throwIO)
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import           Data.Foldable (traverse_)
import           Data.Function (on)
import           Data.List (groupBy)
import           Data.Monoid ((<>))
import           Data.Typeable (Typeable)
import           Foreign (ForeignPtr, Ptr, peek, peekArray, withForeignPtr)
import           Foreign.C.String (castCUCharToChar)
import           GHC.Generics (Generic)

-- | Create a @libtelnet@ state tracker.
telnetInit :: [OptionSpec] -> [T.Flag] -> EventHandler -> IO Telnet
telnetInit options flags handler =
    F.telnetInit options' (convertEventHandler handler) flags
  where
    options' = map f options
    f (OptionSpec opt us him) =
      let us' = if us then I.iacWill else I.iacWont
          him' = if him then I.iacDo else I.iacDont
      in T.TelnetTeloptT (fromIntegral $ unOption opt) us' him'

-- | Configures which options you want to support. The triple's
-- elements are: option code, support on our end (corresponds to
-- @WILL/WONT@), support on their end (corresponds to @DO/DONT@).
data OptionSpec = OptionSpec
  { _code :: Option -- ^ Option code
  , _us :: Bool -- ^ Supported on our end? (@WILL@/@WONT@)
  , _him :: Bool -- ^ Can other end use it with us? (@DO@/@DONT@)
  } deriving (Eq, Generic, Show, Typeable)

-- | Garbage-collected pointer to the @libtelnet@ state tracker. Your
-- program should hang on to this.
type Telnet = ForeignPtr T.TelnetT

-- | Raw pointer to the @libtelnet@ state tracker. This is passed to
-- the event handlers and you shouldn't see it elsewhere.
type TelnetPtr = Ptr T.TelnetT

-- | The pointer you get back from 'telnetInit' is a 'ForeignPtr'
-- because it carries around its finalizers, but the pointer that gets
-- passed into your 'EventHandler' is a bare 'Ptr' because it's being
-- passed in from C. This class lets us generalise across both types.
class HasTelnetPtr t where
  withTelnetPtr :: t -> (TelnetPtr -> IO a) -> IO a

-- | Unwrap with 'withForeignPtr'.
instance HasTelnetPtr Telnet where
  withTelnetPtr = withForeignPtr

-- | No unwrapping needed.
instance HasTelnetPtr TelnetPtr where
  withTelnetPtr t f = f t

-- | Type of the event handler callback.
type EventHandler = TelnetPtr -> Event -> IO ()

-- | Structure provided to the event handler.
data Event
  = Received ByteString
    -- ^ Data received; you should pass it to the application.
  | Send ByteString
    -- ^ Data you need to send out to the socket.
  | Warning Err
    -- ^ Something has gone wrong inside of libtelnet but
    -- recovery is (likely) possible.
  | Error Err
    -- ^ Something has gone wrong. The application should
    -- immediately close the connection.
  | Iac I.Iac -- ^ Telnet interpret-as-command.
  | Will Option -- ^ Other end offers an option.
  | Wont Option -- ^ Other end cannot support option.
  | Do Option -- ^ Other end asked you to support option.
  | Dont Option -- ^ Other end asked you to stop using option.
  | Subnegotiation Option ByteString
    -- ^ Subnegotiation received for some option.
  | Zmp [ByteString]
    -- ^ <http://discworld.starturtle.net/external/protocols/zmp.html Zenith Mud Protocol>
    -- message
  | TerminalTypeSend
    -- ^ @TERMINAL-TYPE SEND@ message
    -- <http://www.faqs.org/rfcs/rfc1091.html (RFC 1091)>.
    -- The server wants to know about your terminal-type.
  | TerminalTypeIs ByteString
    -- ^ @TERMINAL-TYPE IS@ message
    -- <http://www.faqs.org/rfcs/rfc1091.html (RFC 1091)>.
    -- The client has told us a terminal-type.
  | Compress Bool
    -- ^ Would the client like
    -- <http://www.gammon.com.au/mccp/protocol.html MCCP Version 2>?
  | EnvironSend [(Var, ByteString)]
    -- ^ Request to send the following environment variables, per
    -- <http://www.faqs.org/rfcs/rfc1408.html (RFC 1408)> and
    -- <http://www.faqs.org/rfcs/rfc1572.html (RFC 1572)>.
  | Environ IsInfo [(Var, ByteString, ByteString)]
    -- ^ @ENVIRON@/@NEW-ENVIRON@ options, per
    -- <http://www.faqs.org/rfcs/rfc1408.html (RFC 1408)> and
    -- <http://www.faqs.org/rfcs/rfc1572.html (RFC 1572)>.
    -- Keys come before values in the tuples.
  | Mssp [(ByteString, [ByteString])]
    -- ^ <http://tintin.sourceforge.net/mssp/ Mud Server Status Protocol>
    -- List is @(key, values)@.
  deriving (Eq, Generic, Show, Typeable)

-- | Error message from @libtelnet@.
data Err = Err
  { _file :: ByteString
  , _func :: ByteString
  , _msg :: ByteString
  , _line :: Int
  , _errcode :: T.TelnetErrorT
  }
  deriving (Eq, Generic, Show, Typeable)

-- | Were the 'Environ' fields sent as part of a @NEW-ENVIRON IS@
-- message, or part of a @NEW-ENVIRON INFO@ message?
data IsInfo = Is | Info deriving (Eq, Show)

-- | In an 'Environ' message, are the vars being sent as @VAR@s or @USERVAR@s?
data Var = Var | UserVar deriving (Eq, Show)

-- | Tell the state tracker about received data.
telnetRecv :: HasTelnetPtr t => t -> ByteString -> IO ()
telnetRecv t bs = withTelnetPtr t $ \telnetP -> F.telnetRecv telnetP bs

-- | Send non-command data.
telnetSend :: HasTelnetPtr t => t -> ByteString -> IO ()
telnetSend t bs = withTelnetPtr t $ \telnetP -> F.telnetSend telnetP bs

-- | Send a telnet command.
telnetIac :: HasTelnetPtr t => t -> I.Iac -> IO ()
telnetIac t c = withTelnetPtr t $ \telnetP -> F.cTelnetIac telnetP c

-- | Send a negotiation command.
telnetNegotiate :: HasTelnetPtr t => t -> I.Iac -> Option -> IO ()
telnetNegotiate t cmd opt = withTelnetPtr t $
  \telnetP -> F.cTelnetNegotiate telnetP cmd opt

-- | Send a subnegotiation.
telnetSubnegotiation :: HasTelnetPtr t => t -> Option -> ByteString -> IO ()
telnetSubnegotiation t opt bs = withTelnetPtr t $
  \telnetP -> F.telnetSubnegotiation telnetP opt bs

-- | Begin sending compressed data, using the @COMPRESS2@ option. The
-- server should call this command in response to a @'Compress' True@
-- event.
telnetBeginCompress2 :: HasTelnetPtr t => t -> IO ()
telnetBeginCompress2 t = withTelnetPtr t $
  \telnetP -> F.cTelnetBeginCompress2 telnetP

-- | Ask the client to send us these environment variables.
telnetNewEnvironSend :: HasTelnetPtr t => t -> [(Var, ByteString)] -> IO ()
telnetNewEnvironSend t vars = withTelnetPtr t $
  \telnetP -> do
    let sendVar (var, str) = B8.useAsCString str (sendVal $ varToEvar var)
        sendVal = F.cTelnetNewEnvironValue telnetP

    F.cTelnetBeginNewEnviron telnetP T.eCmdSend
    traverse_ sendVar vars
    F.cTelnetIac telnetP I.iacSE

-- | Tell the server about our environment variables.
telnetNewEnviron
  :: HasTelnetPtr t => t -> IsInfo -> [(Var, ByteString, ByteString)] -> IO ()
telnetNewEnviron t isInfo vars = withTelnetPtr t $
  \telnetP -> do
    let isInfo' = case isInfo of
          Is -> T.eCmdIs
          Info -> T.eCmdInfo

        sendVar (var, name, value) =
          B8.useAsCString name (sendVal $ varToEvar var) *>
          B8.useAsCString value (sendVal T.eValue)

        sendVal = F.cTelnetNewEnvironValue telnetP

    F.cTelnetBeginNewEnviron telnetP isInfo'
    traverse_ sendVar vars
    F.cTelnetIac telnetP I.iacSE

-- | Ask the client to give us a terminal type.
telnetTTypeSend :: HasTelnetPtr t => t -> IO ()
telnetTTypeSend t = withTelnetPtr t F.cTelnetTTypeSend

-- | Tell the server a terminal type.
telnetTTypeIs :: HasTelnetPtr t => t -> ByteString -> IO ()
telnetTTypeIs t bs = withTelnetPtr t $
  \telnetP -> B8.useAsCString bs (F.cTelnetTTypeIs telnetP)

-- | Send a ZMP command.
telnetSendZmp :: HasTelnetPtr t => t -> [ByteString] -> IO ()
telnetSendZmp t cmd = withTelnetPtr t $
  \telnetP -> F.telnetSendZmp telnetP cmd

-- | Send an MSSP status.
telnetSendMssp :: HasTelnetPtr t => t -> [(ByteString, [ByteString])] -> IO ()
telnetSendMssp t stats = telnetSubnegotiation t optMSSP stats' where
  stats' = foldMap pack stats
  pack (var, vals) = msspVar <> var <> foldMap (msspVal <>) vals

  msspVar = B8.singleton . castCUCharToChar . T.unMsspVar $ T.msspVar
  msspVal = B8.singleton . castCUCharToChar . T.unMsspVar $ T.msspVal

-- | Convert the event structure from the FFI into something nicer.
convertEventT :: T.EventT -> IO Event
convertEventT (T.Data (str, len)) =
  Received <$> B8.packCStringLen (str, fromIntegral len)

convertEventT (T.Send (str, len)) =
  Send <$> B8.packCStringLen (str, fromIntegral len)

convertEventT (T.Warning e) = Warning <$> packErrorT e

convertEventT (T.Error e) = Error <$> packErrorT e

convertEventT (T.Command cmd) = pure $ Iac cmd

convertEventT (T.Will opt) = pure $ Will opt

convertEventT (T.Wont opt) = pure $ Wont opt

convertEventT (T.Do opt) = pure $ Do opt

convertEventT (T.Dont opt) = pure $ Dont opt

convertEventT (T.Subnegotiation opt (str, len)) =
  Subnegotiation opt <$> B8.packCStringLen (str, fromIntegral len)

convertEventT (T.Zmp (argv, argc)) =
  Zmp <$> (traverse B8.packCString =<< peekArray (fromIntegral argc) argv)

convertEventT (T.TerminalType cmd name)
  | cmd == T.tCmdIs = TerminalTypeIs <$> B8.packCString name
  | cmd == T.tCmdSend = pure TerminalTypeSend
  | otherwise = throwIO $ T.UnexpectedTerminalTypeCmd cmd

convertEventT (T.Compress ok) = pure . Compress $ ok == 1

convertEventT (T.Environ cmd (values, size)) = do
  environs <- peekArray (fromIntegral size) values
  if | cmd == T.eCmdSend -> do
         vars <- traverse packVar environs
         pure $ EnvironSend vars
     | cmd `elem` [T.eCmdIs, T.eCmdInfo] -> do
         isInfo <- if | cmd == T.eCmdIs -> pure Is
                      | cmd == T.eCmdInfo -> pure Info
                      | otherwise -> throwIO $ T.UnexpectedEnvironCmd cmd
         vars <- traverse packVarVal environs
         pure $ Environ isInfo vars
     | otherwise -> throwIO $ T.UnexpectedEnvironCmd cmd

convertEventT (T.Mssp (values, size)) = do
  environs <- peekArray (fromIntegral size) values
  packed <- traverse packVarVal' environs

  let grouped = groupBy ((==) `on` fst) packed

      extract [] = error "Grouping should have made lists nonempty!"
      extract ((var, val):vals) = (var, val : map snd vals)

  pure . Mssp $ map extract grouped

varToEvar :: Var -> T.EVar
varToEvar Var = T.eVar
varToEvar UserVar = T.eUserVar

eVarToVar :: T.EVar -> Var
eVarToVar var
  | var == T.eVar = Var
  | var == T.eUserVar = UserVar
  | otherwise = throw $ T.UnexpectedEnvironVar var

-- | Convert 'T.ErrorT' into managed strings.
packErrorT :: T.ErrorT -> IO Err
packErrorT T.ErrorT{..} = do
  file <- B8.packCString _file
  func <- B8.packCString _func
  msg <- B8.packCString _msg
  pure $ Err file func msg (fromIntegral _line) _errcode

-- | Convert 'T.TelnetEnvironT' representing a request for an
-- environment var.
packVar :: T.TelnetEnvironT -> IO (Var, ByteString)
packVar T.TelnetEnvironT{..} = do
  var <- B8.packCString _var
  pure (eVarToVar _type, var)

-- | Convert 'T.TelnetEnvironT' representing a message about an
-- environment var's value.
packVarVal :: T.TelnetEnvironT -> IO (Var, ByteString, ByteString)
packVarVal T.TelnetEnvironT{..} = do
  var <- B8.packCString _var
  value <- B8.packCString _value
  pure (eVarToVar _type, var, value)

-- | Convert 'T.TelnetEnvironT' representing an MSSP message (i.e.,
-- type is undefined).
packVarVal' :: T.TelnetEnvironT -> IO (ByteString, ByteString)
packVarVal' T.TelnetEnvironT{..} =
  (,) <$> B8.packCString _var <*> B8.packCString _value

-- | Turn your event handler into one that the FFI can handle.
convertEventHandler :: EventHandler -> F.TelnetEventHandlerT
convertEventHandler f telnetP eventP _ =
  peek eventP >>= convertEventT >>= f telnetP