~jack/libtelnet-haskell

ref: 435aa32599e2e9c1c4195732f05e960697c58058 libtelnet-haskell/src/Network/Telnet/LibTelnet.hs -rw-r--r-- 13.5 KiB
435aa325Jack Kelly Fix comment typo 2 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE MultiWayIf           #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE TypeSynonymInstances #-}

-- | 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