Basic client dialogs to login and start a new game

ChangeLog.md

@@ -1,5 +1,9 @@
 # Revision history for hanafudapi
 
+## 0.1.1.0  -- 2018-05-11
+
+* Basic client dialogs to login and start a new game
+
 ## 0.1.0.0  -- 2018-03-17
 
 * First version. Released on an unsuspecting world.

hanafudapi.cabal

@@ -2,8 +2,8 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                hanafudapi
-version:             0.1.0.0
+version:             0.1.1.0
-synopsis:            An API for the Haskell hanafuda library
+synopsis:            A webapp for the Haskell hanafuda library
 -- description:         
 homepage:            https://framagit.org/hanafuda
 license:             BSD3
@@ -21,7 +21,8 @@ source-repository head
 
 executable hanafudapi
   main-is:             Main.hs
-  other-modules:       Automaton
+  other-modules:       App
+                     , Automaton
                      , Config
                      , Message
                      , Game

src/App.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module App (
+      T
+    , Context(..)
+    , connection
+    , debug
+    , get
+    , current
+    , server
+    , try
+    , update
+    , update_
+  ) where
+
+import Data.Map ((!))
+import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar)
+import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
+import Network.WebSockets (Connection)
+import qualified Player (Key)
+import qualified Session (T(..))
+import qualified Server (T(..))
+
+data Context = Context {
+      mServer :: MVar Server.T
+    , key :: Player.Key
+  }
+
+type T a = ReaderT Context IO a
+
+server :: T Server.T
+server = asks mServer >>= lift . readMVar
+
+get :: Player.Key -> T Session.T
+get key =
+  (! key) . Server.sessions <$> server
+
+current :: T Session.T
+current = do
+  asks key >>= get
+
+connection :: T Connection
+connection = Session.connection <$> current
+
+debug :: String -> T ()
+debug message =
+  show <$> asks key
+  >>= lift . putStrLn . (++ ' ':message)
+
+try :: (Server.T -> Either String Server.T) -> T (Maybe String)
+try f = do
+  Context {mServer} <- ask
+  currentValue <- lift $ takeMVar mServer
+  lift $ case f currentValue of
+    Left message -> putMVar mServer currentValue >> return (Just message)
+    Right updated -> putMVar mServer updated >> return Nothing
+
+{- Not using the previous to minimize the duration mServer gets locked -}
+update :: (Server.T -> (Server.T, a)) -> T a
+update f = do
+  Context {mServer} <- ask
+  lift $ modifyMVar mServer (return . f)
+
+update_ :: (Server.T -> Server.T) -> T ()
+update_ f = update $ (\x -> (x, ())) . f

src/Automaton.hs

@@ -3,66 +3,78 @@ module Automaton (
     start
   ) where
 
-import Control.Monad.Reader (asks)
+import Control.Monad.Reader (asks, lift)
-import qualified Player (Session(..), Status(..))
+import qualified Game (export, new)
-import qualified Server (logIn, logOut, setStatus)
+import qualified Session (Status(..), T(..))
-import qualified Session (App, T(..), current, debug, get, server, try, update)
+import qualified Server (get, logIn, logOut, setStatus, register)
-import qualified Message (FromClient(..), T(..), broadcast, get, relay, send, sendTo)
+import qualified App (Context(..), T, current, debug, get, server, try, update, update_)
+import qualified Message (FromClient(..), T(..), broadcast, get, relay, send, sendTo, update)
 
-type Vertex = Player.Status
+type Vertex = Session.Status
 
-edges :: Vertex -> Message.FromClient -> Session.App Vertex
+edges :: Vertex -> Message.FromClient -> App.T Vertex
 
-edges (Player.LoggedIn False) logIn@(Message.LogIn login) =
+edges (Session.LoggedIn False) logIn@(Message.LogIn login) =
-  asks Session.key >>= Session.try . (Server.logIn login)
+  asks App.key >>= App.try . (Server.logIn login)
   >>= maybe
-   (Message.relay logIn Message.broadcast >> return (Player.LoggedIn True))
+   (Message.relay logIn Message.broadcast >> return (Session.LoggedIn True))
-   (withError $ Player.LoggedIn False)
+   (withError $ Session.LoggedIn False)
 
-edges (Player.LoggedIn True) logOut@Message.LogOut = do
+edges (Session.LoggedIn True) logOut@Message.LogOut = do
   Message.relay logOut Message.broadcast
-  asks Session.key >>= Session.update . Server.logOut
+  asks App.key >>= App.update_ . Server.logOut
-  return (Player.LoggedIn False)
+  return (Session.LoggedIn False)
 
-edges (Player.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
+edges (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
-  session <- Session.get to
+  session <- App.get to
-  case Player.status session of
+  case Session.status session of
-    Player.LoggedIn True -> do
+    Session.LoggedIn True -> do
-      key <- asks Session.key
+      key <- asks App.key
-      Session.update (Server.setStatus (Player.Answering key) to)
+      App.update_ (Server.setStatus (Session.Answering key) to)
-      (Message.relay invitation $ Message.sendTo (to, session))
+      Message.broadcast $ Message.update {Message.paired = [key, to]}
-      return (Player.Waiting to)
+      (Message.relay invitation $ Message.sendTo [(to, session)])
-    _ -> Player.LoggedIn True `withError` "They just left"
+      return (Session.Waiting to)
+    _ -> Session.LoggedIn True `withError` "They just left"
 
-edges (Player.Answering to) message@(Message.Answer {Message.accept}) = do
+edges (Session.Answering to) message@(Message.Answer {Message.accept}) = do
-  session <- Session.get to
+  session <- App.get to
-  key <- asks Session.key
+  key <- asks App.key
-  case Player.status session of
+  case Session.status session of
-    Player.Waiting for | for == key -> do
+    Session.Waiting for | for == key -> do
-      Message.relay message $ Message.sendTo (to, session)
+      Message.relay message $ Message.sendTo [(to, session)]
-      if accept
+      newStatus <-
-        then Session.debug "Yeah ! Let's start a game" >> return (Player.LoggedIn True)
+        if accept
-        else Session.debug "Oh, they said no" >> return (Player.LoggedIn True)
+          then do
-    _ -> (Player.LoggedIn True) `withError` "They're not waiting for your answer"
+            gameKey <- Server.register <$> (lift $ Game.new for to) >>= App.update
+            game <- Server.get gameKey <$> App.server
+            current <- App.current
+            Message.sendTo [(to, session), (key, current)] $ Message.NewGame $ Game.export game
+            return $ Session.Playing gameKey
+          else do
+            Message.broadcast $ Message.update {Message.alone = [key, to]}
+            return $ Session.LoggedIn True
+      App.update_ $ Server.setStatus newStatus for
+      return newStatus
+    _ -> (Session.LoggedIn True) `withError` "They're not waiting for your answer"
 
 edges state _ =
   state `withError` ("Invalid message in state " ++ show state)
 
-withError :: Vertex -> String -> Session.App Vertex
+withError :: Vertex -> String -> App.T Vertex
 withError vertex message = 
   (Message.send $ Message.Error message) >> return vertex
 
-run :: Session.App ()
+run :: App.T ()
 run = do
   message <- Message.get
-  status <- Player.status <$> Session.current
+  status <- Session.status <$> App.current
   newStatus <- edges status message
-  Server.setStatus newStatus <$> asks Session.key >>= Session.update
+  asks App.key >>= App.update_ . Server.setStatus newStatus
-  Session.debug $ show newStatus
+  App.debug $ show newStatus
   run
 
-start :: Session.App ()
+start :: App.T ()
 start = do
-  Session.debug "Initial state"
+  App.debug "Initial state"
-  Message.Welcome <$> Session.server <*> asks Session.key >>= Message.send
+  Message.Welcome <$> App.server <*> asks App.key >>= Message.send
   run

src/Data.hs

@@ -1,9 +1,30 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
 module Data (
-    RW(..)
+      Key(..)
+    , RW(..)
   ) where
 
+import Data.Aeson (FromJSON(..), ToJSON(..), ToJSONKey(..), genericToEncoding)
+import Data.Aeson.Types (toJSONKeyText)
+import Data.Text (pack)
+import GHC.Generics
+import qualified JSON (defaultOptions)
+
 class RW a b where
-  update :: (a -> a) -> b -> b
+  get :: b -> a
   set :: a -> b -> b
-  set = update . const
+  update :: (a ->  a) -> b -> b
+  update f v =
+    set (f (get v)) v
+
+newtype Key a = Key Int deriving (Eq, Ord, Enum, Read, Show, Generic)
+
+instance FromJSON (Key a)
+instance ToJSON (Key a) where
+  toEncoding = genericToEncoding JSON.defaultOptions
+
+instance ToJSONKey (Key a) where
+  toJSONKey = toJSONKeyText (pack . \(Key n) -> show n)

src/Game.hs

@@ -1,19 +1,62 @@
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DeriveGeneric #-}
-module Game where
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Game (
+      Key
+    , State(..)
+    , T(..)
+    , export
+    , new
+  ) where
 
-import Hanafuda (Card(..))
+import Data.Map (Map, (!), fromList, mapKeys)
-import Hanafuda.KoiKoi (Move(..))
 import Data.Aeson (FromJSON(..), ToJSON(..), genericToEncoding)
 import qualified JSON (singleLCField)
+import qualified Data (Key)
+import qualified Player (Key)
+import qualified Hanafuda (Card(..), cardsOfPack)
+import qualified Hanafuda.Player (Player(..), Seat(..))
+import qualified Hanafuda.KoiKoi (Mode(..), Move(..), On(..), new)
 import GHC.Generics
 
-deriving instance Generic Card
+deriving instance Generic Hanafuda.Card
-deriving instance Generic Move
+deriving instance Generic Hanafuda.KoiKoi.Move
 
-instance FromJSON Card
+instance FromJSON Hanafuda.Card
-instance ToJSON Card
+instance ToJSON Hanafuda.Card
 
-instance FromJSON Move
+instance FromJSON Hanafuda.KoiKoi.Move
-instance ToJSON Move where
+instance ToJSON Hanafuda.KoiKoi.Move where
   toEncoding = genericToEncoding JSON.singleLCField
+
+data T = T {
+      seats :: Map Hanafuda.Player.Seat Player.Key
+    , state :: Hanafuda.KoiKoi.On
+  }
+type Key = Data.Key T
+
+data State = State {
+      river :: [Hanafuda.Card]
+    , yakus :: Map Player.Key [Hanafuda.Card]
+  } deriving (Generic)
+
+instance ToJSON State where
+  toEncoding = genericToEncoding JSON.singleLCField
+
+new :: Player.Key -> Player.Key -> IO T
+new p1 p2 = do
+  state <- Hanafuda.KoiKoi.new Hanafuda.KoiKoi.WholeYear
+  return $ T {
+      seats = fromList [(Hanafuda.Player.Player1, p1), (Hanafuda.Player.Player2, p2)]
+    , state
+  }
+
+export :: T -> State
+export (T {seats, state}) = State {
+      river = Hanafuda.cardsOfPack $ Hanafuda.KoiKoi.river state
+    , yakus = fmap extractYakus players
+  }
+  where
+    extractYakus = Hanafuda.cardsOfPack . Hanafuda.Player.meld
+    players = mapKeys (seats !) $ Hanafuda.KoiKoi.players state

src/Main.hs

@@ -11,28 +11,27 @@ import Control.Monad.Reader (ReaderT(..), asks)
 import Control.Concurrent (newMVar, modifyMVar)
 import Control.Exception (finally)
 import qualified Config (listenPort)
-import qualified Player (openSession)
+import qualified Session (open)
-import qualified Server (disconnect, join, new)
+import qualified Server (disconnect, new, register)
-import qualified Session (App, T(..), update)
+import qualified App (Context(..), T, update_)
 import qualified Message (FromClient(..), broadcast, relay)
 import qualified Automaton (start)
 
-exit :: Session.App ()
+exit :: App.T ()
 exit = do
-  asks Session.key >>= Session.update . Server.disconnect
+  asks App.key >>= App.update_ . Server.disconnect
   Message.relay Message.LogOut Message.broadcast
 
-serverApp :: Session.App () -> Session.App () -> IO ServerApp
+serverApp :: App.T () -> App.T () -> IO ServerApp
 serverApp onEnter onExit = do
   mServer <- newMVar Server.new
   return $ \pending -> do
-    key <- acceptRequest pending
+    session <- Session.open <$> acceptRequest pending
-                 >>= return . Player.openSession
+    key <- modifyMVar mServer (return . Server.register session)
-                 >>= modifyMVar mServer . Server.join
+    let app = App.Context {App.mServer, App.key}
-    let session = Session.T {Session.mServer, Session.key}
     finally
-      (runReaderT onEnter session)
+      (runReaderT onEnter app)
-      (runReaderT onExit session)
+      (runReaderT onExit app)
 
 main :: IO ()
 main = do

src/Message.hs

@@ -9,25 +9,29 @@ module Message (
     , relay
     , send
     , sendTo
+    , update
   ) where
 
+import Data.List (intercalate)
+import Data.Foldable (forM_)
 import Data.Map (toList)
 import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecode', encode, genericParseJSON, genericToEncoding, defaultOptions)
 import Network.WebSockets (receiveData, sendTextData)
 import Data.ByteString.Lazy.Char8 (unpack)
-import Control.Monad (mapM_)
+import Data.Text (Text)
 import Control.Monad.Reader (asks, lift)
-import qualified Player (Key, Name, Session(..))
+import qualified Player (Key)
+import qualified Game (State)
+import qualified Session (T(..))
 import qualified Server (T(..))
-import qualified Session (App, T(..), connection, current, debug, server)
+import qualified App (Context(..), T, connection, current, debug, server)
 import qualified Hanafuda.KoiKoi as KoiKoi (Move(..))
 import GHC.Generics (Generic)
-import Game ()
 
 data FromClient =
     Answer {accept :: Bool}
   | Invitation {to :: Player.Key}
-  | LogIn {name :: Player.Name}
+  | LogIn {name :: Text}
   | LogOut
   | Game {move :: KoiKoi.Move}
   | Ping
@@ -41,6 +45,8 @@ instance FromJSON FromClient where
 data T =
     Relay {from :: Player.Key, message :: FromClient}
   | Welcome {room :: Server.T, key :: Player.Key}
+  | Update {alone :: [Player.Key], paired :: [Player.Key]}
+  | NewGame Game.State
   | Pong
   | Error {error :: String}
   deriving (Generic)
@@ -48,40 +54,45 @@ data T =
 instance ToJSON T where
   toEncoding = genericToEncoding defaultOptions
 
-sendTo :: (Player.Key, Player.Session) -> T -> Session.App ()
+sendTo :: [(Player.Key, Session.T)] -> T -> App.T ()
-sendTo (key, session) obj = do
+sendTo sessions obj = do
-  Session.debug $ '(' : show key ++ ") <" ++ (unpack encoded)
+  App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
-  lift $ sendTextData (Player.connection session) $ encoded
+  lift $ forM_ connections $ flip sendTextData encoded
   where
     encoded = encode $ obj
+    (recipients, connections) = unzip [
+        (show key, Session.connection session) | (key, session) <- sessions
+      ]
 
-send :: T -> Session.App ()
+send :: T -> App.T ()
 send obj = do
-  key <- asks Session.key
+  key <- asks App.key
-  session <- Session.current
+  session <- App.current
-  sendTo (key, session) obj
+  sendTo [(key, session)] obj
 
-broadcast :: T -> Session.App ()
+broadcast :: T -> App.T ()
 broadcast obj =
-  (toList . Server.sessions) <$> Session.server
+  App.server >>= flip sendTo obj . toList . Server.sessions
-  >>= mapM_ (flip sendTo obj)
 
-relay :: FromClient -> (T -> Session.App ()) -> Session.App ()
+relay :: FromClient -> (T -> App.T ()) -> App.T ()
 relay message f = do
-  Session.debug "Relaying"
+  App.debug "Relaying"
-  (\from -> f $ Relay {from, message}) =<< asks Session.key
+  (\from -> f $ Relay {from, message}) =<< asks App.key
 
-receive :: Session.App FromClient
+receive :: App.T FromClient
 receive = do
-  received <- ((lift . receiveData) =<< Session.connection)
+  received <- ((lift . receiveData) =<< App.connection)
-  Session.debug $ '>':(unpack received)
+  App.debug $ '>':(unpack received)
   case eitherDecode' received of
     Left errorMessage -> send (Message.Error errorMessage) >> receive
     Right clientMessage -> return clientMessage
 
-get :: Session.App Message.FromClient
+get :: App.T Message.FromClient
 get =
   receive >>= pong
   where
     pong Ping = send Pong >> get
     pong m = return m
+
+update :: T
+update = Update {alone = [], paired = []}

src/Player.hs

@@ -1,25 +1,22 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Player (
-      Key(..)
+      Key
-    , Name
+    , T(..)
-    , Session(..)
-    , Status(..)
-    , openSession
   ) where
 
-import Data.Text (Text, pack)
+import Data.Text (Text)
-import Data.Aeson (FromJSON(..), ToJSON(..), ToJSONKey(..), genericToEncoding)
+import qualified Data (Key)
-import Data.Aeson.Types (toJSONKeyText)
-import qualified JSON (defaultOptions)
-import qualified Data (RW(..))
-import Network.WebSockets (Connection)
 import GHC.Generics
 
-newtype Key = Key Int deriving (Eq, Ord, Read, Show, Generic)
+data T = T {
-newtype Name = Name Text deriving (Eq, Ord, Generic)
+    name :: Text
+  } deriving (Eq, Ord, Generic)
+type Key = Data.Key T
 
+{-
 instance FromJSON Key
 instance ToJSON Key where
   toEncoding = genericToEncoding JSON.defaultOptions
@@ -30,23 +27,4 @@ instance ToJSONKey Key where
 instance FromJSON Name
 instance ToJSON Name where
   toEncoding = genericToEncoding JSON.defaultOptions
-
+-}
-data Status =
-    LoggedIn Bool
-  | Answering Key
-  | Waiting Key
-  deriving (Show, Generic)
-
-data Session = Session {
-      connection :: Connection
-    , status :: Status
-  }
-
-instance Data.RW Status Session where
-  update f session@(Session {status}) = session {status = f status}
-
-openSession :: Connection -> Session
-openSession connection = Session {
-      connection
-    , status = LoggedIn False
-  }

src/Server.hs

@@ -1,78 +1,115 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Server (
       T(..)
     , disconnect
-    , join
+    , get
     , logIn
     , logOut
     , new
+    , register
     , setStatus
   ) where
 
-import Data.Map ((!?), Map, adjust, delete, insert, lookupMax)
+import Data.Aeson (ToJSON(..), (.=), object, pairs)
+import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey)
 import qualified Data.Map as Map (empty)
-import Data.Aeson (ToJSON(..))
+import Data.Monoid ((<>))
+import Data.Set (Set, member)
+import qualified Data.Set as Set (delete, empty, insert)
+import Data.Text (Text)
 import qualified Data (RW(..))
-import qualified Player (Key(..), Name, Session(..), Status(..))
+import qualified Game (Key, T(..))
+import qualified Player (Key, T(..))
+import qualified Session (Status(..), T(..))
 
-type Keys = Map Player.Name Player.Key
+type Names = Set Text
-type Names = Map Player.Key Player.Name
+type Players = Map Player.Key Player.T
-type Sessions = Map Player.Key Player.Session
+type Sessions = Map Player.Key Session.T
+type Games = Map Game.Key Game.T
 data T = T {
-      keys :: Keys
+      names :: Names
-    , names :: Names
+    , players :: Players
     , sessions :: Sessions
+    , games :: Games
   }
 
-instance Data.RW Keys T where
-  update f server@(T {keys}) = server {keys = f keys}
-
 instance Data.RW Names T where
-  update f server@(T {names}) = server {names = f names}
+  get = names
+  set names server = server {names}
+
+instance Data.RW Players T where
+  get = players
+  set players server = server {players}
 
 instance Data.RW Sessions T where
-  update f server@(T {sessions}) = server {sessions = f sessions}
+  get = sessions
+  set sessions server = server {sessions}
+
+instance Data.RW Games T where
+  get = games
+  set games server = server {games}
+
+newtype Player = Player (Text, Bool)
+instance ToJSON Player where
+  toJSON (Player (name, alone)) = object ["name" .= name, "alone" .= alone]
+  toEncoding (Player (name, alone)) = pairs ("name" .= name <> "alone" .= alone)
+
+export :: Sessions -> Player.Key -> Player.T -> Player
+export sessions key player = Player (Player.name player, alone)
+  where
+    alone =
+      case Session.status (sessions ! key) of
+        Session.LoggedIn True -> True
+        _ -> False
 
 instance ToJSON T where
-  toJSON = toJSON . names
+  toJSON (T {players, sessions}) = toJSON $ mapWithKey (export sessions) players
-  toEncoding = toEncoding . names
+  toEncoding (T {players, sessions}) = toEncoding $ mapWithKey (export sessions) players
 
 new :: T
 new = T {
-      keys = Map.empty
+      names = Set.empty
-    , names = Map.empty
+    , players = Map.empty
     , sessions = Map.empty
+    , games = Map.empty
   }
 
-join :: Player.Session -> T -> IO (T, Player.Key)
+register :: forall a b. (Enum a, Ord a, Data.RW (Map a b) T) => b -> T -> (T, a)
-join session server@(T {sessions}) =
+register x server =
-  return (Data.update (insert key session) server, key)
+  let key = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (Data.get server :: Map a b) in
-  where
+  (Data.update (insert key x) server, key)
-    key = Player.Key $ maybe 0 (\(Player.Key n, _) -> n+1) $ lookupMax sessions
+
+get :: forall a b. (Ord a, Data.RW (Map a b) T) => a -> T -> b
+get key server = (Data.get server :: Map a b) ! key
 
 disconnect :: Player.Key -> T -> T
 disconnect key =
   Data.update (delete key :: Sessions -> Sessions) . logOut key
 
-logIn :: Player.Name -> Player.Key -> T -> Either String T
+logIn :: Text -> Player.Key -> T -> Either String T
 logIn name key server =
-  Data.update (insert name key) .
+  Data.update (Set.insert name) .
-  Data.update (insert key name) .
+  Data.update (insert key $ Player.T {Player.name}) .
-  setStatus (Player.LoggedIn True) key <$>
+  setStatus (Session.LoggedIn True) key <$>
-  maybe (Right server) (\_-> Left "This name is already registered") (keys server !? name)
+  if name `member` names server
+    then Left "This name is already registered"
+    else Right server
 
 logOut :: Player.Key -> T -> T
 logOut key server =
   maybe
     server
-    (\name ->
+    (\player ->
-      Data.update (delete key :: Names -> Names) $
+      Data.update (delete key :: Players -> Players) $
-      setStatus (Player.LoggedIn False) key $
+      setStatus (Session.LoggedIn False) key $
-      Data.update (delete name :: Keys -> Keys) server)
+      Data.update (Set.delete $ Player.name player :: Names -> Names) server)
-    (names server !? key)
+    (players server !? key)
 
-setStatus :: Player.Status -> Player.Key -> T -> T
+setStatus :: Session.Status -> Player.Key -> T -> T
 setStatus status key =
   Data.update (adjust (Data.set status) key :: Sessions -> Sessions)

src/Session.hs

@@ -1,59 +1,41 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveGeneric #-}
 module Session (
-      App
+      Status(..)
     , T(..)
-    , connection
+    , open
-    , debug
-    , get
-    , current
-    , server
-    , try
-    , update
   ) where
 
-import Data.Map ((!))
-import Control.Concurrent (MVar, modifyMVar_, putMVar, readMVar, takeMVar)
-import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
 import Network.WebSockets (Connection)
-import qualified Player (Key, Session(..))
+import Data.Aeson (ToJSON(..), genericToEncoding)
-import qualified Server (T(..))
+import GHC.Generics (Generic)
+import qualified JSON (singleLCField)
+import qualified Data (RW(..))
+import qualified Player (Key)
+import qualified Game (Key)
+
+data Status =
+    LoggedIn Bool
+  | Answering Player.Key
+  | Waiting Player.Key
+  | Playing Game.Key
+  deriving (Show, Generic)
+
+instance ToJSON Status where
+  toEncoding = genericToEncoding JSON.singleLCField
 
 data T = T {
-      mServer :: MVar Server.T
+      connection :: Connection
-    , key :: Player.Key
+    , status :: Status
   }
 
-type App a = ReaderT T IO a
+instance Data.RW Status T where
+  get = status
+  set status session = session {status}
 
-server :: App Server.T
+open :: Connection -> T
-server = asks mServer >>= lift . readMVar
+open connection = T {
-
+      connection
-get :: Player.Key -> App Player.Session
+    , status = LoggedIn False
-get key =
+  }
-  (! key) . Server.sessions <$> server
-
-current :: App Player.Session
-current = do
-  asks key >>= get
-
-connection :: App Connection
-connection = Player.connection <$> current
-
-debug :: String -> App ()
-debug message =
-  show <$> asks key
-  >>= lift . putStrLn . (++ ' ':message)
-
-try :: (Server.T -> Either String Server.T) -> App (Maybe String)
-try f = do
-  T {mServer} <- ask
-  currentValue <- lift $ takeMVar mServer
-  lift $ case f currentValue of
-    Left message -> putMVar mServer currentValue >> return (Just message)
-    Right updated -> putMVar mServer updated >> return Nothing
-
-{- Not using the previous to minimize the duration mServer gets locked -}
-update :: (Server.T -> Server.T) -> App ()
-update f = do
-  T {mServer} <- ask
-  lift $ modifyMVar_ mServer (return . f)

www/connect.js

@@ -1,56 +0,0 @@
-window.addEventListener('load', function() {
-  var ws = new WebSocket('ws://' + window.location.hostname + '/play/');
-  var sessionKey = null;
-  var lib = Lib(ws);
-  var room = Room(document.getElementById('room'), lib);
-  var login = Login(document.getElementById('login'), lib);
-  var debug = document.getElementById('debug');
-  setTimeout(ping, 20000);
-
-  ws.addEventListener('message', function(event) {
-    var o = JSON.parse(event.data);
-    switch(o.tag) {
-      case "Welcome":
-        sessionKey = o.key;
-        room.populate(o.room, sessionKey);
-        break;
-      case "Pong":
-        setTimeout(ping, 10000);
-        break;
-      case "Relay":
-        relayedMessage(o)
-        break;
-      default:
-        debug.textContent = event.data;
-    }
-  });
-
-  function relayedMessage(o) {
-    switch(o.message.tag) {
-      case "LogIn":
-        room.enter(o.from, o.message.name);
-        if(o.from == sessionKey) {
-          login.on(o.from);
-        }
-        break;
-      case "LogOut":
-        room.leave(o.from);
-        if(o.from == sessionKey) {
-          login.off(o.from);
-        }
-        break;
-      case "Invitation":
-        var name = room.name(o.from);
-        var accept = false;
-        // invitations should come only from known players, in doubt say «no»
-        if(name) {
-          accept = confirm(name + " has invited you to a game");
-        }
-        lib.send({tag: "Answer", accept: accept});
-    }
-  }
-
-  function ping() {
-    lib.send({tag: "Ping"});
-  }
-});

www/dom.js

@@ -0,0 +1,11 @@
+function Dom() {
+	return {
+		clear: clear
+	}
+
+  function clear(elem) {
+    while(elem.firstChild) {
+      elem.removeChild(elem.firstChild);
+    }
+  }
+}

www/index.html

@@ -2,28 +2,39 @@
 <html>
   <head>
     <title>KoiKoi</title>
-    <script src="lib.js"></script>
+    <script src="dom.js"></script>
+    <script src="sort.js"></script>
+    <script src="session.js"></script>
     <script src="login.js"></script>
     <script src="room.js"></script>
-    <script src="connect.js"></script>
+    <script src="screen.js"></script>
+    <script src="messaging.js"></script>
+    <script src="main.js"></script>
     <link rel="stylesheet" href="skin.css" type="text/css"/>
   </head>
   <body>
-    <p>Hanafuda</p>
+    <div id="reception" class="on">
-    <form id="login">
+      <h1>Hanafuda</h1>
-      <p id="join">
+      <form id="login">
-        <label for="name">Name</label><input type="text" name="name"/>
+        <input type="submit" name="submitButton" hidden disabled/>
-        <input type="submit" name="join" value="Join"/>
+        <p id="join" class="on">
-      </p>
+          <label for="you">Pick a name you like</label><input type="text" name="you"/>
-      <p id="leave">
+          <input type="submit" name="join" value="Join" disabled/>
-        <input type="button" name="leave" value="Leave"/>
+        </p>
-      </p>
+        <p id="invite">
-    </form>
+          <label for="them">Start a game with</label><input type="text" name="them"/>
-    <form id="room" class="off">
+          <input type="submit" name="invite" value="Invite" disabled/>
-      <ul class="players">
+        </p>
-      </ul>
+        <ul class="players"></ul>
-      <input type="submit" name="invite" value="Invite to a game" disabled/>
+        <p id="leave">
-    </form>
+          <input type="button" name="leave" value="Leave"/>
+        </p>
+      </form>
+    </div>
+    <div id="game">
+      <ul id="river"></ul>
+      <ul id="hand"></ul>
+    </div>
     <p id="debug"></p>
   </body>
 </html>

www/login.js

@@ -1,23 +1,132 @@
-function Login(domElem, lib) {
+function Login(modules) {
-  domElem.addEventListener('submit', function(e) {
+  var root = document.getElementById('login');
+  var players = root.getElementsByClassName('players')[0];
+  var join = document.getElementById("join");
+  var invite = document.getElementById("invite");
+  var submit = root.submitButton;
+  var them = null;
+
+  root.addEventListener('submit', function(e) {
     e.preventDefault();
-    lib.send({tag: "LogIn", name: domElem.name.value})
+    if(modules.session.loggedIn()) {
+      modules.messaging.send({tag: "Invitation", to: them});
+    } else {
+      modules.messaging.send({tag: "LogIn", name: root.you.value});
+    }
   });
-  domElem.leave.addEventListener('click', function(e) {
+
+  root.leave.addEventListener('click', function(e) {
     e.preventDefault();
     lib.send({tag: "LogOut"})
   });
 
-  return {
+  root.you.addEventListener("input", function() {refreshPlayers(false);});
-    on: on,
+  root.them.addEventListener("input", function() {refreshPlayers(true);});
-    off: off
-  };
 
-  function on(name) {
+  modules.messaging.addEventListener(["Welcome"], function() {
-    domElem.className = "on";
+    refreshPlayers(modules.session.loggedIn());
+  });
+
+  modules.messaging.addEventListener(["Update"], function(o) {
+    refreshPlayers(modules.session.loggedIn());
+  });
+
+  modules.messaging.addEventListener(["Relay", "LogIn"], function() {
+    playersChanged();
+  });
+
+  modules.messaging.addEventListener(["Relay", "LogOut"], function() {
+    playersChanged();
+  });
+
+  modules.messaging.addEventListener(["Relay", "Invitation"], function(o) {
+    var name = modules.room.name(o.from);
+    var accept = false;
+    // invitations should come only from known players, in doubt say «no»
+    if(name) {
+      accept = confirm(name + " has invited you to a game");
+      if(accept) {
+        modules.screen.select("game");
+      }
+    }
+    modules.messaging.send({tag: "Answer", accept: accept});
+  });
+
+  modules.messaging.addEventListener(["Relay", "Answer"], function(o) {
+    if(o.message.accept) {
+      modules.screen.select("game");
+    }
+  });
+
+  return {};
+
+  function playersChanged() {
+    var loggedIn = modules.session.loggedIn();
+    setMode(loggedIn);
+    refreshPlayers(loggedIn);
   }
 
-  function off() {
+  function refreshPlayers(loggedIn) {
-    domElem.className = "";
+    modules.dom.clear(players);
+    if(loggedIn) {
+      refreshThem();
+    } else {
+      refreshYou();
+    }
+  }
+
+  function refreshYou() {
+    var nameTaken = false;
+    var name = root.you.value;
+    modules.room.filter(name).forEach(function(player) {
+      players.appendChild(player.dom);
+      nameTaken = nameTaken || name == player.name;
+    });
+    formDisable("join", name.length < 1 || nameTaken);
+  }
+
+  function refreshThem() {
+    them = null;
+    var name = root.them.value;
+    var filtered = modules.room.filter(name);
+    filtered.forEach(function(player) {
+      players.appendChild(player.dom);
+    });
+    var exact = filtered.find(exactMatch(name));
+    players.classList.remove("alone", "notFound");
+    if(exact != undefined) {
+      them = exact.key;
+    } else if(filtered.length == 1) {
+      them = filtered[0].key;
+    } else if(filtered.length == 0) {
+      players.classList.add(name.length > 0 ? "notFound" : "alone");
+    }
+    formDisable("invite", them == undefined);
+  }
+
+  function formDisable(name, disabled) {
+    [submit, root[name]].forEach(function(button) {
+      button.disabled = disabled;
+    });
+  }
+
+  function exactMatch(name) {
+    return function(player) {
+      return player.name === name;
+    };
+  }
+
+  function setMode(loggedIn) {
+    root.join.disabled = loggedIn;
+    root.invite.disabled = !loggedIn;
+    if(loggedIn) {
+      join.className = "";
+      invite.className = "on";
+      root.them.focus();
+    } else {
+      join.className = "on";
+      invite.className = "";
+      root.you.focus();
+    }
   }
 }

www/main.js

@@ -0,0 +1,11 @@
+window.addEventListener('load', function() {
+  var dom = Dom();
+  var sort = Sort();
+  var screen = Screen();
+  var messaging = Messaging();
+  var session = Session({messaging: messaging});
+  var room = Room({dom: dom, messaging: messaging, session: session, sort: sort});
+  var login = Login({dom: dom, messaging: messaging, room: room, screen: screen, session: session});
+
+  messaging.start();
+});

www/messaging.js

@@ -0,0 +1,62 @@
+function Messaging(screen) {
+  var ws = new WebSocket('ws://' + window.location.hostname + '/play/');
+  var keepAlivePeriod = 20000;
+  var routes = {callbacks: [], children: {}};
+
+  return {
+    addEventListener: addEventListener,
+    send: send,
+    start: start
+  }
+
+  function get(obj, path, write) {
+    write = write || false;
+    if(path.length < 1) {
+      return obj;
+    } else {
+      if(obj.children[path[0]] == undefined && write) {
+        obj.children[path[0]] = {callbacks: [], children: {}};
+      }
+      if(obj.children[path[0]] != undefined) {
+        return get(obj.children[path[0]], path.slice(1), write);
+      } else {
+        return null;
+      }
+    }
+  }
+
+  function addEventListener(path, callback) {
+    var route = get(routes, path, true);
+    route.callbacks.push(callback);
+  }
+
+  function messageListener(event) {
+    var o = JSON.parse(event.data);
+    var path = [];
+    var tmp = o;
+    while(tmp != undefined && tmp.tag != undefined) {
+      path.push(tmp.tag);
+      tmp = tmp.message;
+    }
+    var route = get(routes, path);
+    if(route != undefined && route.callbacks != undefined) {
+      route.callbacks.forEach(function(f) {f(o);});
+    } else {
+      debug.textContent = event.data;
+    }
+  };
+
+  function start() {
+    ping();
+    addEventListener(["Pong"], ping);
+    ws.addEventListener('message', messageListener);
+  }
+
+  function send(o) {
+    ws.send(JSON.stringify(o));
+  }
+
+  function ping() {
+    setTimeout(function() {send({tag: "Ping"});}, keepAlivePeriod);
+  }
+}

www/room.js

@@ -1,4 +1,14 @@
-function Room(domElem, lib) {
+function Room(modules) {
+
+  function Player(key, name, alone) {
+    this.key = key;
+    this.name = name;
+    this.alone = alone;
+    this.dom = document.createElement('li');
+    this.dom.textContent = name;
+    this.position = null;
+  }
+
   var players = {};
   var sortedKeys = [];
   var session = {
@@ -6,67 +16,61 @@ function Room(domElem, lib) {
     loggedIn: false,
     selected: null
   };
-  var playersList = domElem.getElementsByClassName('players')[0];
+
-  domElem.addEventListener('submit', function(e) {
+  modules.messaging.addEventListener(["Welcome"], function(o) {
-    e.preventDefault();
+    for(var key in o.room) {
-    lib.send({tag: "Invitation", to: session.selected})
+      enter(parseInt(key), o.room[key]);
+    }
   });
-  var compareKeysByLogin = lib.funMap(function(key) {return players[key].name;}, lib.defaultCompare);
+
+  modules.messaging.addEventListener(["Update"], function(o) {
+    o.alone.forEach(function(key) {players[key].alone = true;});
+    o.paired.forEach(function(key) {players[key].alone = false;});
+  });
+
+  modules.messaging.addEventListener(["Relay", "LogIn"], function(o) {
+    enter(o.from, o.message);
+  });
+
+  modules.messaging.addEventListener(["Relay", "LogOut"], function(o) {
+    leave(o.from);
+  });
+
+  var compareKeysByLogin = modules.sort.map(function(key) {return players[key].name;}, modules.sort.defaultCompare);
 
   return {
-    populate: populate,
+    filter: filter,
     enter: enter,
     leave: leave,
     name: name
   };
 
-  function Player(key, name) {
+  function filter(name) {
-    var player = {
+    if(modules.session.loggedIn()) {
-      name: name,
+      var keep = function(player) {
-      dom: document.createElement('li'),
+        return player.name.match(name) && !modules.session.is(player.key) && player.alone;
-      position: null
+      };
-    };
-    player.dom.textContent = name;
-    if(key != session.key) {
-      player.dom.addEventListener('click', function(e) {
-        e.preventDefault();
-        if(session.loggedIn) {
-          select(key);
-        }
-      });
     } else {
-      on();
+      var keep = function(player) {return player.name.match(name);};
-      player.dom.title = "Hey ! That's you !";
     }
-    return player;
+    return sortedKeys.reduce(function(accumulator, key) {
+      var player = players[key];
+      return keep(player) ? accumulator.concat(player) : accumulator;
+    }, []);
   }
 
-  function populate(playersHash, sessionKey) {
+  function enter(key, obj) {
-    session.key = sessionKey;
+    var name = obj.name || "anon";
-    lib.clearElement(playersList);
+    var alone = obj.alone != undefined ? obj.alone : true;
-    for(var key in playersHash) {
+    var player = new Player(key, name, alone);
-      enter(parseInt(key), playersHash[key] || "anon");
-    }
-  }
-
-  function enter(key, name) {
-    var player = Player(key, name);
     players[key] = player;
-    player.position = lib.insert(key, sortedKeys, compareKeysByLogin);
+    player.position = modules.sort.insert(key, sortedKeys, compareKeysByLogin);
-    beforePlayer = players[sortedKeys[player.position]];
-    playersList.insertBefore(player.dom, beforePlayer && beforePlayer.dom);
     sortedKeys.splice(player.position, 0, key);
   }
 
   function leave(key) {
     var player = players[key];
-    if(key === session.key) {
-      off();
-    } else if(key === session.selected) {
-      reset();
-    }
     if(player != undefined) {
-      playersList.removeChild(player.dom);
       sortedKeys.splice(player.position, 1);
       delete players[key];
     }
@@ -76,38 +80,4 @@ function Room(domElem, lib) {
     player = players[key];
     return player && player.name;
   }
-
-  function on() {
-    domElem.className = "";
-    session.loggedIn = true;
-  }
-
-  function off() {
-    domElem.className = "off";
-    session.loggedIn = false;
-    reset();
-  }
-
-  function select(key) {
-    if(key === session.selected) {
-      unselect(key);
-    } else {
-      reset();
-      players[key].dom.className = "selected";
-      session.selected = key;
-      domElem.invite.disabled = false;
-    }
-  }
-
-  function reset() {
-    if(session.selected) {
-      unselect(session.selected);
-    }
-  }
-
-  function unselect(key) {
-    players[key].dom.className = "";
-    session.selected = null;
-    domElem.invite.disabled = true;
-  }
 }

www/screen.js

@@ -0,0 +1,13 @@
+function Screen() {
+  var current = document.querySelector("body > div.on");
+
+  return {
+    select: select
+  };
+
+  function select(name) {
+    current.className = "";
+    current = document.getElementById(name);
+    current.className = "on";
+  }
+}

www/session.js

@@ -0,0 +1,27 @@
+function Session(modules) {
+  var key = null;
+  var name = null;
+
+  modules.messaging.addEventListener(["Welcome"], function(o) {
+    key = o.key;
+  });
+
+  modules.messaging.addEventListener(["Relay", "LogIn"], function(o) {
+    if(is(o.from)) {
+      name = o.message.name;
+    }
+  });
+
+  return {
+    is: is,
+    loggedIn: loggedIn
+  };
+
+  function is(sessionKey) {
+    return key == sessionKey;
+  }
+
+  function loggedIn() {
+    return name != undefined;
+  }
+}

www/skin.css

@@ -1,3 +1,19 @@
+body > div {
+  display: none;
+}
+
+body > div.on {
+  display: block;
+}
+
+#join, #invite {
+  display: none;
+}
+
+#join.on, #invite.on {
+  display: block;
+}
+
 #leave {
   display: none;
 }
@@ -10,19 +26,24 @@
   display: inline;
 }
 
-#room .players {
+#login .players {
   min-height: 4em;
   border: 1px solid #ccc;
   list-style: none;
   padding-left: 0;
-  cursor: pointer;
 }
 
-#room.off .players li {
+.players:empty::before {
-  color: #777;
+  display: block;
+  text-align: center;
+  margin: 1em;
+  color: #555;
 }
 
-#room .players .selected {
+.players.alone::before {
-  background: #92c8f6;
+  content: "No one to play with yet ! Wait a little";
-  color: #fff;
+}
+
+.players.notFound::before {
+  content: "No one by that name is awaiting an opponent";
 }

www/sort.js

@@ -1,18 +1,10 @@
-function Lib(ws) {
+function Sort() {
   return {
-    clearElement: clearElement,
     defaultCompare: defaultCompare,
-    funMap: funMap,
+    map: map,
     insert: insert,
-    send: send
   };
 
-  function clearElement(elem) {
-    while(elem.firstChild) {
-      elem.removeChild(elem.firstChild);
-    }
-  }
-
   function insert(obj, t, compare, min, max) {
     min = min == undefined ? 0 : min;
     max = max == undefined ? t.length : max;
@@ -38,14 +30,11 @@ function Lib(ws) {
     }
   }
 
-  function funMap(projector, f) {
+  function map(projector, f) {
     return function() {
       var args = Array.prototype.map.call(arguments, projector);
       return f.apply(null, args);
     }
   }
 
-  function send(o) {
-    ws.send(JSON.stringify(o));
-  }
 }