Pipes.hs

{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import           Control.Concurrent         (forkIO, threadDelay)
import           Control.Exception          (catch)
import           Control.Monad              (forever, void, when)
import           Control.Monad.State.Strict (StateT, get, runStateT)
import           Data.ByteString            (ByteString)
import           Network.WebSockets         (Connection, ConnectionException,
                                             WebSocketsData, acceptRequest,
                                             receiveData, runServer)
import           Pipes
import           Pipes.Concurrent           (Output, fromInput, spawn, toOutput,
                                             unbounded)

import           Mermaid.Input

main :: IO ()
main = do
  (w,r) <- spawn unbounded

  serve "127.0.0.1" 8001 w mkAdmin
  serve "127.0.0.1" 8000 w mkClient
  tick 1000 Tick w

  runEffect $ fromInput r >-> handler

  where mkClient socket = Client (lift (tryReceiveData socket) >>= \case
                                     Just name -> yield (NewPlayer name socket) >> pure (Just name)
                                     Nothing   -> pure Nothing)
                                 (\msg -> get >>= \name -> yield (PlayerSay name msg))
                                 (get >>= yield . PlayerLeft)

        mkAdmin _ = Client (pure $ Just ())
                           (\msg -> when (msg == "quit") $ yield Quit)
                           (pure ())

forkEffect :: Effect IO a -> IO ()
forkEffect = void . forkIO . void . runEffect

tick :: Int -> a -> Output a -> IO ()
tick x v w = forkEffect $ aux >-> toOutput w
  where
    aux = forever $ lift (threadDelay $ 1000 * x) >> yield v

handler :: Consumer Input IO ()
handler =
  await >>= \case
    Quit -> lift $ putStrLn "Bye."
    x -> lift (print x) >> handler

type ClientM s m a r = Producer a (StateT s m) r

runClient :: (Monad m, MonadIO m)
          => s
          -> Output a
          -> ClientM s m a r
          -> m (r, s)
runClient s w op = runStateT (runEffect $ for op (\x -> yield x >-> toOutput w)) s

evalClient :: (Monad m, MonadIO m)
           => s
           -> Output a
           -> ClientM s m a r
           -> m r
evalClient s w op = fst <$> runClient s w op

data Client s m a =
  Client { onConnect :: Producer a m (Maybe s)
         , onRecv    :: ByteString -> ClientM s m a ()
         , onClose   :: ClientM s m a ()
         }

tryReceiveData :: (WebSocketsData a)
               => Connection
               -> IO (Maybe a)
tryReceiveData conn =
  (Just <$> receiveData conn)
    `catch` \(_ :: ConnectionException) -> pure Nothing

serve :: String
      -> Int
      -> Output a
      -> (Connection -> Client s IO a)
      -> IO ()
serve host name w initClient =
  void . forkIO $ runServer host name $ \pending -> do
    socket <- acceptRequest pending
    let client = initClient socket
    runEffect (for (onConnect client) $ \x -> yield x >-> toOutput w)
      >>= \case
        (Just s) -> aux s client socket
        Nothing  -> pure ()
  where
    aux s client socket =
      tryReceiveData socket >>= \case
        Just msg -> do
          ((), s') <- runClient s w (onRecv client msg)
          aux s' client socket
        Nothing  -> evalClient s w (onClose client)

data Input = Tick
           | Quit
           | NewPlayer ByteString Connection
           | PlayerLeft ByteString
           | PlayerSay ByteString ByteString

instance Show Input where
  show Tick                 = "compute new frame"
  show (NewPlayer name _)   = "new player <" ++ show name ++ "> arrived"
  show (PlayerLeft name)    = "player <" ++ show name ++ "> left"
  show (PlayerSay name msg) = "<" ++ show name ++ ">: " ++ show msg
  show Quit                 = "request to quit"