~jack/reflex-libtelnet

reflex-libtelnet/reflex-libtelnet-example/src/Main.hs -rw-r--r-- 3.0 KiB
ffea5fa8Jack Kelly Fix README/ChangeLog 7 days 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
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RecursiveDo         #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}

module Main where

import           Control.Lens ((^.), (.~))
import           Control.Monad.Fix (MonadFix)
import           Control.Monad.IO.Class (MonadIO)
import           Data.Function ((&))
import           Data.Generics.Product (field')
import           Data.Map (Map)
import qualified Data.Map as Map
import qualified Network.Socket as NS
import           Reflex
import qualified Reflex.Backend.Socket as RS
import           Reflex.Host.Headless
import           Reflex.LibTelnet

perClient
  :: forall t m.
     (Reflex t,
      MonadFix m,
      MonadIO m,
      MonadIO (Performable m),
      MonadSample t m,
      PerformEvent t m,
      PostBuild t m,
      TriggerEvent t m)
  => Dynamic t NS.Socket
  -> m (Event t ())
perClient dSocket = mdo
  -- Set up the socket.
  s <- sample $ current dSocket
  -- The output event feeding the socket is the "you should send this"
  -- event from libtelnet.
  let sConfig = RS.SocketConfig s 4096 (telnetEvents ^. field' @"send") never
  sock <- RS.socket sConfig

  -- Feed data arriving on the socket into libtelnet, and feed the
  -- decoded data from libtelnet back into itself, as data to be sent.
  let
    telnetConfig = newTelnetConfig
        & field' @"recv" .~ (sock ^. RS.sReceive)
        & field' @"send" .~ (telnetEvents ^. field' @"received")
  telnetEvents <- telnet telnetConfig

  -- The only time we want to stop is if the socket was closed from
  -- underneath us.
  pure $ sock ^. RS.sClose

guest :: MonadHeadlessApp t m => m (Event t ())
guest = mdo
  -- Open a listen socket.
  eAccept <- snd . fanEither <$> RS.accept
    (RS.AcceptConfig Nothing (Just "4000") 5 [(NS.ReuseAddr, 1)] never)

  eNewClient <- switchHold never $ RS._aAcceptSocket <$> eAccept

  -- Give each client's socket an increasing number.
  eIns :: Event t (Integer, NS.Socket) <- numberOccurrences $
    fst <$> eNewClient

  -- Build a map of all currently-connected clients.
  dClients :: Dynamic t (Map Integer NS.Socket) <-
    foldDyn ($) Map.empty . mergeWith (.) $
      [ uncurry Map.insert <$> eIns
      , flip (foldr Map.delete) <$> eRemoves
      ]

  -- Map of potential "socket closed" events based on currently-open
  -- socket map.
  dClientCloses :: Dynamic t (Map Integer (Event t ())) <-
    list dClients perClient

  let
    -- `fmap mergeMap` gives us a `Dynamic t (Event t (Map Integer ()))`;
    -- these are the "socket closed" events that fired this frame.
    --
    -- `switchDyn` turns a `Dynamic`-of-`Event` into an `Event`;
    -- in our case, it gives us `Event t (Map Integer ())`;
    -- its firings are maps containing the keys of every socket that
    -- closed this frame.
    --
    -- `fmap Map.keys` pulls out the keys, a list of socket numbers.
    eRemoves = fmap Map.keys . switchDyn . fmap mergeMap $ dClientCloses
  pure never

main :: IO ()
main = runHeadlessApp guest