IO types reenineering

src/Game.hs

@@ -12,7 +12,7 @@ import Control.Exception (finally)
 import qualified Network.WebSockets as WS
 import Data.Aeson (encode, decode)
 
-import qualified TypesGame as TG
+import qualified TypesGame as G
 import qualified TypesGameInput as I
 import qualified TypesGameOutput as O
 
@@ -22,10 +22,10 @@ import qualified TypesGameOutput as O
 
 data GameState = GameState {
     clients :: [Client]
-  , history :: TG.Grid
+  , history :: G.Grid
   }
 
-type Client = (TG.Player, WS.Connection)
+type Client = (G.Player, WS.Connection)
 
 --------------------------------------------------
 --------------------------------------------------
@@ -54,16 +54,16 @@ broadcast message state = do
   forM_ (clients state) $ \(_, conn) ->
     WS.sendTextData conn message
 
-addMove :: TG.Cell -> GameState -> GameState
-addMove (TG.Cell coord value) state =
+addMove :: G.Cell -> GameState -> GameState
+addMove (G.Cell coord value) state =
   GameState
   (clients state)
   (HM.insert coord value (history state))
 
-lastMove :: GameState -> TG.Cell
+lastMove :: GameState -> G.Cell
 lastMove state = let (c, v) = head $
                        HM.toRevList (history state)
-                 in TG.Cell c v
+                 in G.Cell c v
 
 --------------------------------------------------
 -- Game server functions
@@ -74,43 +74,41 @@ type GameAction = MVar GameState -> IO ()
 -- Function that encapsulates message processing logic
 gameLogic :: Client -> I.Message -> GameAction
 gameLogic client msg state = case msg of
-  I.Get d -> case d of
-    I.History -> sendHistory client state
-  I.Delete d -> case d of
-    I.History -> cleanHistory state
-  I.Post d -> case d of
-    I.Move cell -> saveMove client cell state
-
-saveMove :: Client -> TG.Cell -> GameAction
+  I.GetHistory -> sendHistory client state
+  I.CleanHistory -> cleanHistory state
+  I.PostMove (I.Cell cell) -> saveMove client cell state
+
+saveMove :: Client -> G.Cell -> GameAction
 saveMove (user, conn) cell state = do
   -- Save move into game history
   modifyMVar_ state $ \s -> do
     let s' = addMove cell s
     return s'
   -- Share the move with other clients
   readMVar state >>= \s -> do
-    let ctrlMsg = O.Message O.User (O.Move cell)
+    let ctrlMsg = O.Move (O.Cell cell)
     broadcast (encode ctrlMsg) s
       -- Then check if player won
     if winSituation s
-      then let ctrlMsg = O.Message O.User (O.Win user)
+      then let ctrlMsg = O.Win (O.Player user)
            in broadcast (encode ctrlMsg) s
       else return ()
 
 sendHistory :: Client -> GameAction
 sendHistory (user, conn) state = do
   readMVar state >>= \s -> do
-    let ctrlMsg = O.Message O.Game
-                  ( O.History ( TG.toCell <$> HM.toList (history s)
-                              , fst <$> clients s ))
+    let moves = G.toCell <$> HM.toList (history s)
+        players = fst <$> clients s
+    let ctrlMsg = O.SetHistory $
+                  O.History moves players
     WS.sendTextData conn (encode ctrlMsg)
 
 cleanHistory :: GameAction
 cleanHistory state = do
   modifyMVar_ state $ \s -> return $
     GameState (clients s) HM.empty
   readMVar state >>= \s ->
-    let ctrlMsg = O.Message O.Game O.Clean
+    let ctrlMsg = O.Clean
     in broadcast (encode ctrlMsg) s
 
 --------------------------------------------------
@@ -121,29 +119,29 @@ type Direction = (Int, Int)
 type Counter = Int
 
 -- Recursively counts symbols in one direction
-countStrike :: TG.Cell -> TG.Grid
+countStrike :: G.Cell -> G.Grid
             -> Direction -> Counter
 countStrike cell history axis =
   go 0 cell history axis
-  where go :: Counter -> TG.Cell
-           -> TG.Grid -> Direction -> Counter
-        go i (TG.Cell coord cellValue)
+  where go :: Counter -> G.Cell
+           -> G.Grid -> Direction -> Counter
+        go i (G.Cell coord cellValue)
           history (deltaR, deltaC) = do
           -- Calculate updated coordinates
-          let nextMove = TG.Coordinate
-                         (TG.row coord + deltaR)
-                         (TG.col coord + deltaC)
+          let nextMove = G.Coordinate
+                         (G.row coord + deltaR)
+                         (G.col coord + deltaC)
           let nextValue = HM.lookup nextMove history
           case nextValue of
             Nothing -> i
             Just v -> if v == cellValue
-              then go (i + 1) (TG.Cell nextMove v)
+              then go (i + 1) (G.Cell nextMove v)
                    history (deltaR, deltaC)
               else i
 
 -- Counts symbols in direct and inversed direction
 -- Then sums them up and adds 1 (actual recent move)
-countStrikes :: TG.Cell -> TG.Grid -> [Counter]
+countStrikes :: G.Cell -> G.Grid -> [Counter]
 countStrikes cell history =
   let count = map (countStrike cell history)
       zipWithSum = zipWith (fmap (+1) . (+))

src/Router.hs

@@ -1,4 +1,4 @@
- {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric #-}
 
 module Router where
@@ -17,7 +17,7 @@ import System.Random
 
 import qualified TypesGameInput as I
 import qualified TypesGameOutput as O
-import qualified TypesGame as TG
+import qualified TypesGame as G
 import Game
 
 ----------------------------------------------------------------------
@@ -29,29 +29,28 @@ import Game
 -- to join specific session.
 
 -- To make that possible we need to define router state
-type RouterState = HashMap SessionId (MVar GameState)
-type SessionId = [Char]
+type RouterState = HashMap G.SessionId (MVar GameState)
 
 newRouterState :: RouterState
 newRouterState = HM.empty
 
-addSession :: SessionId -> MVar GameState
+addSession :: G.SessionId -> MVar GameState
            -> RouterState -> RouterState
 addSession = HM.insert
 
-getSession :: SessionId -> RouterState
+getSession :: G.SessionId -> RouterState
            -> Maybe (MVar GameState)
 getSession = HM.lookup
 
-data RouterMessage = Route (Maybe SessionId) I.Message
+data RouterMessage = Route (Maybe G.SessionId) I.Message
   deriving (Generic, Eq, Show)
 instance FromJSON RouterMessage
 instance ToJSON RouterMessage
 
 data StateVersion = New | Existing
   deriving (Eq, Show)
 
-fetchGameSession :: Maybe SessionId
+fetchGameSession :: Maybe G.SessionId
                  -> WS.Connection
                  -> MVar RouterState
                  -> IO ( MVar GameState )
@@ -81,7 +80,7 @@ fetchGameSession maybeSession conn rState =
       -- Generate new sessionId
       sId <- genHash
       -- Send sessionId to the client
-      let ctrlMsg = O.Message O.Game (O.NewSession sId)
+      let ctrlMsg = O.SetSession (O.SessionId sId)
       WS.sendTextData conn (encode ctrlMsg)
       -- Update the router state
       modifyMVar_ rState $ \s ->
@@ -114,7 +113,7 @@ startRouter rState pending = do
             modifyMVar_ gState $ \s -> do
               let s' = Game.addClient client s
               -- Warn everybody
-              let ctrlMsg = O.Message O.User (O.Connected name)
+              let ctrlMsg = O.Connected (O.Player name)
               Game.broadcast (encode ctrlMsg) s'
               return s'
 
@@ -143,15 +142,15 @@ disconnect client gState = do
     let s' = removeClient client s in return (s',s')
 
   -- Broadcast that one of the players is disconnected
-  let ctrlMsg = O.Message O.User
-                (O.Disconnected $ fst client)
+  let ctrlMsg = O.Disconnected $
+                O.Player (fst client)
   broadcast (encode ctrlMsg) s
 
 incorrectMessage :: ByteString -> IO ()
 incorrectMessage msg =
   print ("Incorrect message: " <> msg)
 
-genHash :: IO SessionId
+genHash :: IO G.SessionId
 genHash = do
   let hashChr = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']
   xs <- sequenceA .

src/TypesGame.hs

@@ -7,6 +7,8 @@ import Data.Aeson
 import GHC.Generics
 import Data.Hashable
 
+type SessionId = [Char]
+
 type Player = Text
 type Grid = HM.InsOrdHashMap Coordinate CellValue
 

src/TypesGameInput.hs

@@ -4,23 +4,36 @@
 module TypesGameInput where
 
 import Data.Aeson
+import Data.Aeson.TH
 import GHC.Generics
 
 import qualified TypesGame as TG
 
+messageOptions = defaultOptions
+  { sumEncoding = TaggedObject
+    { tagFieldName = "method"
+    , contentsFieldName = "resource" }
+  }
+
+resourceOptions = defaultOptions
+  { sumEncoding = ObjectWithSingleField }
+
 data Message =
     Connect Data
-  | Get Data
-  | Post Data
-  | Delete Data
+  | PostMove Data
+  | GetHistory
+  | CleanHistory
   deriving (Generic, Eq, Show)
-instance FromJSON Message
-instance ToJSON Message
+instance FromJSON Message where
+  parseJSON = genericParseJSON messageOptions
+instance ToJSON Message where
+  toJSON = genericToJSON messageOptions
 
 data Data =
     Player TG.Player
-  | Move TG.Cell
-  | History
+  | Cell TG.Cell
   deriving (Generic, Eq, Show)
-instance FromJSON Data
-instance ToJSON Data
+instance FromJSON Data where
+  parseJSON = genericParseJSON resourceOptions
+instance ToJSON Data where
+  toJSON = genericToJSON resourceOptions

src/TypesGameOutput.hs

@@ -9,27 +9,30 @@ import GHC.Generics
 import qualified TypesGame as TG
 
 -- Structure for output messages
-data Message = Message {
-    mType  :: MessageType
-  , mValue :: MessageValue
-  } deriving (Generic, Show)
-instance ToJSON Message
-
-data MessageType =
-    User
-  | Game
-  deriving (Generic, Eq, Show)
-instance ToJSON MessageType
-
-data MessageValue =
-  -- User values
-    Connected TG.Player
-  | Disconnected TG.Player
-  | Move TG.Cell
-  | Win TG.Player
-  -- Game values
-  | NewSession [Char]
-  | History ([TG.Cell],[TG.Player])
+data Message =
+    Connected Data
+  | Disconnected Data
+  | Win Data
+  | SetSession Data
+  | SetHistory Data
+  | Move Data
   | Clean
   deriving (Generic, Show)
-instance ToJSON MessageValue
+instance ToJSON Message where
+  toJSON = genericToJSON defaultOptions
+    { sumEncoding = TaggedObject
+      { tagFieldName = "message"
+      , contentsFieldName = "data" }
+    }
+
+data Data =
+    Player TG.Player
+  | Cell TG.Cell
+  | SessionId TG.SessionId
+  | History { moves :: [TG.Cell]
+            , players :: [TG.Player] }
+  deriving (Generic, Show)
+instance ToJSON Data where
+  toJSON = genericToJSON defaultOptions
+    { allNullaryToStringTag = True
+    , sumEncoding = ObjectWithSingleField }