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