messing around

configuration.yaml

@@ -2,4 +2,4 @@ setSocketPath         : "/tmp/wizard.sock"
 setMapRows            : 20
 setMapColumns         : 20
 setSpawnerProbability : 0.01
-setFPS                : 30
+setFPS                : 1

src-client/Client/Communication.hs

@@ -1,16 +1,59 @@
+{-# LANGUAGE LambdaCase #-}
 module Client.Communication where
 
+import qualified Data.Aeson as A
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Char8 as B8
+
 import Network.Socket
 
 import System.IO
 
+-- internal imports
+
+import Library.Types
+
 connectSocket
   :: FilePath
-  -> IO Handle
+  -> IO Socket
 connectSocket path = do
   sock <- socket AF_UNIX Stream defaultProtocol
   setSocketOption sock KeepAlive 1
   connect sock (SockAddrUnix path)
-  handle <- socketToHandle sock ReadWriteMode
+  -- handle <- socketToHandle sock ReadWriteMode
+  -- hSetBuffering handle (BlockBuffering Nothing)
+  pure sock
+
+-- | Sends a specified message through given socket to the server
+sendMessage
+  :: ClientMessages
+  -> Socket
+  -> IO ()
+sendMessage msg sock = do
+  handle <- socketToHandle sock WriteMode
   hSetBuffering handle (BlockBuffering Nothing)
-  pure handle
+  let msgJson = A.encode msg
+  B.hPutStr handle $ B.toStrict msgJson
+  hFlush handle
+  -- hClose handle
+
+receiveMessage
+  :: Socket
+  -> IO ServerMessage
+receiveMessage sock = do
+  handle <- socketToHandle sock ReadMode
+  hSetBuffering handle LineBuffering
+  handleOpen <- hIsOpen handle
+  if handleOpen
+  then do
+    message <- hGetContents handle
+    let mJsonMessage = A.decode' $ B8.pack message :: Maybe ServerMessage
+        errMsg = error $ "unexpected message from Server: " <> message
+    -- hClose handle
+    maybe
+      errMsg
+      pure
+      mJsonMessage
+  else
+    error "Handle is closed"

src-client/Client/Types.hs

@@ -4,9 +4,9 @@ import Control.Monad.RWS
 
 import Data.UUID
 
-import Options.Applicative as O
+import Network.Socket
 
-import System.IO
+import Options.Applicative as O
 
 -- internal imports
 
@@ -24,7 +24,7 @@ options = Options
     )
 
 data ReaderContainer = ReaderContainer
-  { rcSocketHandle :: Handle
+  { rcSocketHandle :: Socket
   , rcClientUUID   :: UUID
   }
 

src-client/Main.hs

@@ -3,14 +3,8 @@ module Main where
 
 import Control.Concurrent (threadDelay)
 
-import Data.Aeson as A
-
-import qualified Data.ByteString.Lazy.Char8 as B8
-
 import Options.Applicative
 
-import System.IO
-
 -- internal imports
 
 import Client.Communication
@@ -23,27 +17,18 @@ main = do
   putStrLn "Hello, Arena!"
   (Options socketLocation) <- execParser opts
   putStrLn $ "connecting to Socket " <> socketLocation
-  handle <- connectSocket socketLocation
-  message <- hGetContents handle
-  let mJsonMessage = decode' $ B8.pack message :: Maybe ServerMessage
-      errMsg = (error $ "unexpected message from Server: " <> message)
-      uuid   = maybe
-        errMsg
-        (\case
-          (AcceptClient uuid) -> uuid
-          _ -> errMsg
-        )
-        mJsonMessage
-      -- reader = ReaderContainer handle uuid
-  putStrLn $ "received uuid " <> show uuid
-  -- mock communication code
-  hPutStrLn handle "meow!"
-  hFlush handle
+  sock <- connectSocket socketLocation
+  putStrLn "connected"
+  sendMessage (IdRequest) sock
   threadDelay $ 5 * 10 ^ 6
-  hPutStrLn handle "Goodbye!"
-  hFlush handle
-  threadDelay $ 5 * 10 ^ 6
-  -- end mock
+  -- message <- receiveMessage sock
+  -- putStrLn $ "getting first message" <> show message
+  -- let clientUUID = case message of
+  --       (AcceptClient aclientUUID ) -> aclientUUID
+  --       x -> error $ "unexpected message from server: " <> show message
+  -- let reader = ReaderContainer sock clientUUID
+  -- putStrLn $ "received uuid " <> show clientUUID
+  -- threadDelay $ 5 * 10 ^ 6
   where
     opts = info (options <**> helper)
       ( fullDesc

src-lib/Library/Types/Communication.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE DeriveGeneric #-}
+module Library.Types.Communication where
+
+import Data.Aeson
+
+import Data.UUID
+
+import GHC.Generics
+
+data ServerMessage
+  = ServerQuit
+  | AcceptClient
+    { acClientUUID :: UUID
+    }
+  deriving (Eq, Show, Generic)
+
+instance FromJSON ServerMessage
+
+instance ToJSON ServerMessage
+
+data ClientMessages
+  = ClientQuit
+  | IdRequest
+  deriving (Eq, Show, Generic)
+
+instance FromJSON ClientMessages
+
+instance ToJSON ClientMessages

src-server/Server/Communication.hs

@@ -59,7 +59,7 @@ terminateGameOnSigint = do
       disconnectClients clients
       threadDelay (10 ^ 6)
       (SockAddrUnix path) <- getSocketName sock
-      close' sock
+      close sock
       removeIfExists path
       -- Raise SIGINT again so it does not get blocked
       raiseSignal keyboardSignal
@@ -69,7 +69,7 @@ terminateGameOnSigint = do
     disconnectClients = mapM_
       (\(clientSocket, mThread) -> do
         maybe (pure ()) killThread mThread
-        close' clientSocket
+        close clientSocket
       )
 
 -- | Process incoming connection requests
@@ -80,11 +80,14 @@ processRequests = do
   void $ liftIO $ forkIO $ acceptConnection mainSocket socketList
   where
     acceptConnection mainSocket socketList = do
+      putStrLn "accepting new connections…"
       (clientSock, _) <- accept mainSocket
+      -- clientHandle <- socketToHandle clientSock ReadWriteMode
+      -- hSetBuffering clientHandle (BlockBuffering Nothing)
       putStrLn "accepted new connection"
-      uuid <- nextRandom
-      putStrLn $ "accepting client with uuid " <> show uuid
-      sendMessage (AcceptClient uuid) clientSock
+      -- uuid <- nextRandom
+      -- putStrLn $ "accepting client with uuid " <> show uuid
+      -- sendMessage (AcceptClient uuid) clientHandle
       liftIO $ STM.atomically $ do
         list <- STM.takeTMVar socketList
         STM.putTMVar socketList ((clientSock, Nothing) : list)
@@ -96,36 +99,30 @@ sendMessage
   -> Socket
   -> IO ()
 sendMessage msg sock = do
-  connectionHandle <- socketToHandle sock WriteMode
-  hSetBuffering connectionHandle (BlockBuffering Nothing)
+  handle <- socketToHandle sock WriteMode
+  hSetBuffering handle (BlockBuffering Nothing)
   let msgJson = A.encode msg
-  B.hPutStr connectionHandle $ B.toStrict msgJson
-  hFlush connectionHandle
-  hClose connectionHandle
+  B.hPutStr handle $ B.toStrict msgJson
+  hFlush handle
+  -- hClose handle
 
 -- | process incoming messages from clients
 processMessages :: Game ()
 processMessages = do
   clientsVar <- gets scClientSockets
   clients <- liftIO $ STM.atomically $ STM.readTMVar clientsVar
-  newClients <- foldM
-    (\acc (clientSocket, mThread) ->
-      case mThread of
-      Nothing -> liftIO $ do
-        thread <- forkIO
-          (listenTo clientSocket)
-        pure $ (clientSocket, Just thread) : acc
-      Just _ -> liftIO $ do
-        pure acc
+  mapM_
+    (\(clientSocket, _) -> liftIO $
+      receiveMessage clientSocket
     )
-    []
     clients
-  liftIO $ STM.atomically $ do
-    void $ STM.swapTMVar clientsVar newClients
-  where
-    listenTo clientSocket = do
-      connectionHandle <- socketToHandle clientSocket ReadMode
-      hSetBuffering connectionHandle LineBuffering
-      message <- hGetContents connectionHandle
+
+receiveMessage
+  :: Socket
+  -> IO ()
+receiveMessage clientSocket = do
+  clientHandle <- socketToHandle clientSocket ReadMode
+  hSetBuffering clientHandle (BlockBuffering Nothing)
+  message <- hGetContents clientHandle
   putStr message
-      hClose connectionHandle
+  -- hClose connectionHandle

src-server/Server/Types.hs

@@ -17,6 +17,8 @@ import Network.Socket
 
 import Options.Applicative as O
 
+import System.IO
+
 --internal imports
 
 import Library.Types