Implement proper user renaming + broadcast new name upon receiving a Hello message in a connected state

This reverts commit 3bd2829cf2.

ChangeLog.md

@@ -1,4 +1,4 @@
-# Revision history for hanafudapi
+# Revision history for hanafuda-server
 
 ## 0.2.3.0  -- 2019-08-24
 

hanafuda-server.cabal

@@ -1,11 +1,11 @@
--- Initial hanafudapi.cabal generated by cabal init.  For further 
+-- Initial hanafuda-server.cabal generated by cabal init.  For further
 -- documentation, see http://haskell.org/cabal/users-guide/
 
-name:                hanafuda-webapp
+name:                hanafuda-server
 version:             0.2.3.0
 synopsis:            A webapp for the Haskell hanafuda library
 -- description:         
-homepage:            https://git.marvid.fr/hanafuda
+homepage:            https://git.marvid.fr/hanafuda/server
 license:             BSD3
 license-file:        LICENSE
 author:              Tissevert
@@ -17,15 +17,17 @@ extra-source-files:  ChangeLog.md
 cabal-version:       >=1.10
 source-repository head
   type:              git
-  location:          https://git.marvid.fr/hanafuda/webapp
+  location:          https://git.marvid.fr/hanafuda/server
 
 executable hanafudapi
   main-is:             Main.hs
   other-modules:       App
                      , Automaton
                      , Config
-                     , Messaging
                      , Game
+                     , Keys
+                     , Messaging
+                     , Player
                      , RW
                      , Server
                      , Session
@@ -33,12 +35,15 @@ executable hanafudapi
   build-depends:       base >=4.9 && <4.13
                      , bytestring
                      , containers >= 0.5.9
-                     , unordered-containers
+                     , directory
+                     , filepath
                      , hanafuda >= 0.3.3
-                     , hanafuda-APILanguage >= 0.1.0
+                     , hanafuda-protocol >= 0.1.0
                      , http-types
                      , aeson
                      , mtl
+                     , random
+                     , saltine
                      , text
                      , vector
                      , wai

src/App.hs

@@ -2,63 +2,51 @@
 module App (
       T
     , Context(..)
-    , connection
     , debug
+    , exec
     , get
-    , current
-    , server
-    , try
+    , player
+    , session
     , update
-    , update_
   ) where
 
-import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar)
+import Control.Concurrent (MVar, modifyMVar, readMVar)
 import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
-import Data.Map ((!))
-import Hanafuda.KoiKoi (PlayerID)
-import Network.WebSockets (Connection)
+import Data.Map ((!), (!?))
+import qualified Player (T)
 import qualified Server (T(..))
-import qualified Session (T(..))
+import qualified Session (ID, T(..))
 
 data Context = Context {
       mServer :: MVar Server.T
-    , playerID :: PlayerID
+    , sessionID :: Session.ID
   }
 
 type T a = ReaderT Context IO a
 
-server :: T Server.T
-server = asks mServer >>= lift . readMVar
+get :: (Server.T -> a) -> T a
+get projector =
+  lift . fmap projector . readMVar =<< asks mServer
 
-get :: PlayerID -> T Session.T
-get playerID =
-  (! playerID) . Server.sessions <$> server
+session :: T Session.T
+session = do
+  Context {sessionID} <- ask
+  get $ (! sessionID) . Server.sessions
 
-current :: T Session.T
-current = do
-  asks playerID >>= get
-
-connection :: T Connection
-connection = Session.connection <$> current
+player :: T (Maybe Player.T)
+player = do
+  Context {sessionID} <- ask
+  get $ (Session.player =<<) . (!? sessionID) . Server.sessions
 
 debug :: String -> T ()
 debug message =
-  show <$> asks playerID
+  show <$> asks sessionID
   >>= lift . putStrLn . (++ ' ':message)
 
-try :: (Server.T -> Either String Server.T) -> T (Maybe String)
-try f = do
+exec :: (Server.T -> IO (Server.T, a)) -> T a
+exec 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
+  lift $ modifyMVar mServer f
 
-{- 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
+update :: (Server.T -> Server.T) -> T ()
+update f = exec $ (\x -> return (x, ())) . f

src/Automaton.hs

@@ -1,110 +1,91 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Automaton (
-    start
+    loop
   ) where
 
-import qualified App (Context(..), T, current, debug, get, server, try, update_)
+import qualified App (Context(..), T, exec, get, player, update)
 import Control.Monad.Reader (asks)
-import Data.Map (Map, (!?))
-import qualified Game (new, play)
-import qualified Hanafuda.KoiKoi as KoiKoi (
-    Game, GameBlueprint(..), GameID, Step(..)
+import Data.Map ((!))
+import qualified Game (fromPublic, new, play, toPublic)
+import qualified Hanafuda.KoiKoi as KoiKoi (Game(..))
+import qualified Hanafuda.Message as Message (
+    FromClient(..), PublicGame(..), T(..)
   )
-import qualified Hanafuda.Message as Message (FromClient(..), T(..))
 import qualified Messaging (
-    broadcast, get, notifyPlayers, relay, send, sendTo, update
+    broadcast, get, notifyPlayers, relay, send, sendTo
   )
-import qualified RW (RW(..))
-import qualified Server (endGame, get, logIn, logOut, update, room)
-import qualified Session (Status(..), T(..), Update)
+import qualified Player (T(..))
+import qualified Server (T(..), logIn, register, room, update)
+import qualified Session (Status, T(..), setPlayer)
 
-receive :: Session.Status -> Message.FromClient -> App.T ()
+receive :: Message.FromClient -> Session.Status -> App.T ()
 
-receive (Session.LoggedIn False) logIn@(Message.LogIn login) =
-  asks App.playerID >>= App.try . (Server.logIn login)
-  >>= maybe
-   (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.LoggedIn True))
-   sendError
+receive (Message.Hello {Message.name}) Nothing = do
+  sessionID <- asks App.sessionID
+  playerID <- App.exec (Server.register [sessionID])
+  room <- App.get Server.room
+  Messaging.send $ Message.Welcome room playerID
+  App.update (Server.update sessionID $ Session.setPlayer playerID name)
+  Messaging.broadcast $ Message.LogIn playerID name
 
-receive (Session.LoggedIn True) logOut@Message.LogOut = do
-  Messaging.relay logOut Messaging.broadcast
-  asks App.playerID >>= App.update_ . Server.logOut
-  setSessionStatus (Session.LoggedIn False)
+receive (Message.Hello {Message.name}) (Just player) = do
+  sessionIDs <- (! playerID) <$> App.get Server.sessionIDsByPlayerID
+  App.update (\server -> foldr (flip Server.update setName) server sessionIDs)
+  Messaging.broadcast $ Message.LogIn playerID name
+  where
+    playerID = Player.playerID player
+    setName session = session {Session.player = Just $ player {Player.name}}
 
-receive (Session.LoggedIn True) invitation@(Message.Invitation {Message.to}) = do
-  session <- App.get to
-  case Session.status session of
-    Session.LoggedIn True -> do
-      from <- asks App.playerID
-      App.update_ (Server.update to (RW.set $ Session.Answering from :: Session.Update))
-      Messaging.broadcast $ Messaging.update {Message.paired = [from, to]}
-      (Messaging.relay invitation $ Messaging.sendTo [to])
-      setSessionStatus (Session.Waiting to)
-    _ -> sendError "They just left"
+receive (Message.Tadaima {Message.myID, Message.name}) Nothing = do
+  sessionID <- asks App.sessionID
+  Message.Okaeri <$> App.get Server.room >>= Messaging.send
+  App.update $ Server.logIn name myID sessionID
+  Messaging.broadcast $ Message.LogIn myID name
 
-receive (Session.Answering to) message@(Message.Answer {Message.accept}) = do
-  session <- App.get to
-  playerID <- asks App.playerID
-  case Session.status session of
-    Session.Waiting for | for == playerID -> do
-      Messaging.relay message $ Messaging.sendTo [to]
-      newStatus <-
-        if accept
-          then do
-            gameID <- Game.new (for, to)
-            game <- Server.get gameID <$> App.server
-            Messaging.notifyPlayers game []
-            return $ Session.Playing gameID
-          else do
-            Messaging.broadcast $ Messaging.update {Message.alone = [for, to]}
-            return $ Session.LoggedIn True
-      App.update_ $ Server.update to (RW.set newStatus :: Session.Update)
-      setSessionStatus newStatus
-    _ -> sendError "They're not waiting for your answer"
+receive (Message.Tadaima {}) (Just _) = sendError "You're already logged in"
 
-receive (Session.Playing gameID) played@(Message.Play {}) = do
-  playerID <- asks App.playerID
-  game <- Server.get gameID <$> App.server
-  (result, logs) <- Game.play playerID (Message.move played) game
-  case result of
-    Left message -> sendError message
-    Right newGame -> do
-      case KoiKoi.step newGame of
-        KoiKoi.Over -> do
-          App.debug $ "Game " ++ show gameID ++ " ended"
-          App.update_ $ Server.endGame gameID
-        _ -> App.update_ $ Server.update gameID (const newGame)
-      Messaging.notifyPlayers newGame logs
+receive invitation@(Message.Invitation {}) (Just _) = relay invitation
 
-receive (Session.Playing gameID) Message.Quit = do
-  games <- (RW.get <$> App.server :: App.T (Map KoiKoi.GameID KoiKoi.Game))
-  case games !? gameID of
-    Nothing -> do
-      playerID <- asks App.playerID
-      Messaging.broadcast $ Messaging.update {Message.alone = [playerID]}
-      setSessionStatus (Session.LoggedIn True)
-    _ -> sendError "Game is still running"
+receive answer@(Message.Answer {Message.accept, Message.to}) (Just player) =
+  if accept
+  then do
+    publicGames <- Game.new (Player.playerID player, to)
+    Messaging.relay answer (Messaging.sendTo [to])
+    Messaging.notifyPlayers (publicGames, [])
+  else Messaging.relay answer (Messaging.sendTo [to])
 
-receive state _ = sendError $ "Invalid message in state " ++ show state
+receive (Message.Play {Message.move, Message.onGame}) (Just player) =
+  Game.play (Player.playerID player) move onGame
+  >>= either sendError Messaging.notifyPlayers
+
+receive sync@(Message.Sync {}) (Just _) = relay sync
+receive yield@(Message.Yield {}) (Just _) = relay yield
+
+receive (Message.Share {Message.gameSave}) (Just player) =
+  either sendError share =<< Game.fromPublic gameSave
+  where
+    logs = Message.logs gameSave
+    share game =
+      let recipientID = KoiKoi.nextPlayer game ! (Player.playerID player) in
+      Game.toPublic recipientID game logs
+      >>= Messaging.sendTo [recipientID] . Message.Game
+
+receive message state =
+  sendError $ "Invalid message " ++ show message ++ " in " ++ showState
+  where
+    showState =
+      case state of
+        Nothing -> "disconnected state"
+        Just _ -> "connected state"
+
+relay :: Message.FromClient -> App.T ()
+relay message = Messaging.relay message (Messaging.sendTo [Message.to message])
 
 sendError :: String -> App.T ()
 sendError = Messaging.send . Message.Error
 
-setSessionStatus :: Session.Status -> App.T ()
-setSessionStatus newStatus = do
-  playerID <- asks App.playerID
-  App.update_ $ Server.update playerID $ (RW.set newStatus :: Session.Update)
-  App.debug $ show newStatus
-
 loop :: App.T ()
 loop = do
   message <- Messaging.get
-  status <- Session.status <$> App.current
-  status `receive` message
-  loop
-
-start :: App.T ()
-start = do
-  App.debug "Initial state"
-  Message.Welcome . Server.room <$> App.server <*> asks App.playerID >>= Messaging.send
+  receive message =<< App.player
   loop

src/Config.hs

@@ -1,6 +1,10 @@
 module Config (
-    listenPort
+      libDir
+    , listenPort
   ) where
 
+libDir :: FilePath
+libDir = "/var/lib/hanafuda-server"
+
 listenPort :: Int
 listenPort = 3000

src/Game.hs

@@ -1,40 +1,154 @@
+{-# LANGUAGE NamedFieldPuns #-}
 module Game (
-      export
+      fromPublic
     , new
     , play
+    , toPublic
   ) where
 
-import qualified App (T, update)
-import Control.Monad.Except (runExceptT, throwError)
+import qualified App (T, get)
+import Control.Monad.Except (runExceptT)
 import Control.Monad.Reader (lift)
 import Control.Monad.Writer (runWriterT)
-import Data.Map (mapWithKey)
-import qualified Hanafuda (empty)
-import Hanafuda.KoiKoi (Game, GameBlueprint(..), GameID, Mode(..), PlayerID)
+import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
+import Crypto.Saltine.Core.SecretBox (newNonce, secretbox, secretboxOpen)
+import Crypto.Saltine.Core.Sign (signDetached, signVerifyDetached)
+import Data.Aeson (ToJSON, eitherDecode', encode)
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy (fromStrict, toStrict)
+import Data.Map ((!), Map, mapWithKey)
+import qualified Hanafuda (Pack)
+import Hanafuda.KoiKoi (Game, Mode(..), Player, PlayerID, Players)
 import qualified Hanafuda.KoiKoi as KoiKoi (
-    Action, Move(..), play, new
+    Action, Game(..), Move(..), play, new
   )
-import Hanafuda.Message (PublicGame)
-import qualified Hanafuda.Player (Player(..), Players(..))
-import qualified Server (register)
+import Hanafuda.Message (
+      Coordinates(..), PrivateState(..), PublicGame(..), PublicPlayer(..)
+    , PublicState(..)
+  )
+import qualified Hanafuda.Player as Player (Player(..), Players(..), get)
+import Keys (T(..))
+import qualified Keys (public, secret)
+import qualified Server (T(..))
 
-new :: (PlayerID, PlayerID) -> App.T GameID
-new (for, to) =
-  Server.register <$> (lift $ KoiKoi.new (for, to) WholeYear) >>= App.update
+new :: (PlayerID, PlayerID) -> App.T Game
+new (for, to) = lift $ KoiKoi.new (for, to) WholeYear
 
-export :: PlayerID -> Game -> PublicGame
-export playerID game = game {
-      deck = length $ deck game
-    , players = Hanafuda.Player.Players $ mapWithKey maskOpponentsHand unfiltered
+exportPlayers :: Game -> Map PlayerID Player
+exportPlayers game =
+  let (Player.Players players) = KoiKoi.players game in
+  players
+
+getCoordinates :: Game -> Coordinates
+getCoordinates game = Coordinates {
+      gameID = KoiKoi.gameID game
+    , month = KoiKoi.month game
+    , turn = 24 - length (KoiKoi.deck game)
+  }
+
+privateState :: Coordinates -> Game -> PrivateState
+privateState link game = PrivateState {
+      link
+    , hands = Player.hand <$> players
+    , deck = KoiKoi.deck game
   }
   where
-    Hanafuda.Player.Players unfiltered = Hanafuda.KoiKoi.players game
-    maskOpponentsHand k player
-      | k == playerID = player
-      | otherwise = player {Hanafuda.Player.hand = Hanafuda.empty}
+    Player.Players players = KoiKoi.players game
 
-play :: PlayerID -> KoiKoi.Move -> Game -> App.T (Either String Game, [KoiKoi.Action])
-play playerID move game = lift . runWriterT . runExceptT $
-  if playing game == playerID
-  then KoiKoi.play move game
-  else throwError "Not your turn"
+getHand :: PlayerID -> Players -> Hanafuda.Pack
+getHand playerID = Player.hand . (Player.get playerID)
+
+publicPlayer :: Player -> PublicPlayer
+publicPlayer player = PublicPlayer {
+      meld = Player.meld player
+    , yakus = Player.yakus player
+  }
+
+privatePlayer :: Map PlayerID PublicPlayer -> PlayerID -> Hanafuda.Pack -> Player
+privatePlayer publicPlayers playerID hand = Player.Player {
+      Player.hand
+    , Player.meld = meld (publicPlayers ! playerID)
+    , Player.yakus = yakus (publicPlayers ! playerID)
+  }
+
+publicState :: Coordinates -> Game -> PublicState
+publicState coordinates game = PublicState {
+      coordinates
+    , mode = KoiKoi.mode game
+    , scores = KoiKoi.scores game
+    , nextPlayer = KoiKoi.nextPlayer game
+    , players = publicPlayer <$> exportPlayers game
+    , playing = KoiKoi.playing game
+    , winning = KoiKoi.winning game
+    , oyake = KoiKoi.oyake game
+    , river = KoiKoi.river game
+    , step = KoiKoi.step game
+    , trick = KoiKoi.trick game
+    , rounds = KoiKoi.rounds game
+  }
+
+toPublic :: PlayerID -> Game -> [KoiKoi.Action] -> App.T PublicGame
+toPublic playerID game logs = do
+  Keys.T {encrypt, sign} <- App.get Server.keys
+  n <- lift newNonce
+  return $ PublicGame {
+        nonce = Saltine.encode n
+      , logs
+      , playerHand = getHand playerID (KoiKoi.players game)
+      , private = secretbox encrypt n $ toJSON private
+      , public
+      , publicSignature = signDetached (Keys.secret sign) $ toJSON public
+    }
+  where
+    shared = getCoordinates game
+    public = publicState shared game
+    private = privateState shared game
+
+toJSON :: ToJSON a => a -> ByteString
+toJSON = toStrict . encode
+
+merge :: PublicState -> PrivateState -> Game
+merge public private = KoiKoi.Game {
+        KoiKoi.gameID = gameID $ coordinates public
+      , KoiKoi.mode = mode public
+      , KoiKoi.scores = scores public
+      , KoiKoi.month = month $ coordinates public
+      , KoiKoi.nextPlayer = nextPlayer public
+      , KoiKoi.players = Player.Players $
+          mapWithKey (privatePlayer $ players public) (hands private)
+      , KoiKoi.playing = playing public
+      , KoiKoi.winning = winning public
+      , KoiKoi.oyake = oyake public
+      , KoiKoi.deck = deck private
+      , KoiKoi.river = river public
+      , KoiKoi.step = step public
+      , KoiKoi.trick = trick public
+      , KoiKoi.rounds = rounds public
+    }
+
+fromPublic :: PublicGame -> App.T (Either String Game)
+fromPublic PublicGame {nonce, private, public, publicSignature} =
+  App.get Server.keys >>= \(Keys.T {encrypt, sign}) -> return $ do
+    check (signVerifyDetached (Keys.public sign) publicSignature (toJSON public))
+      `orDie` "The game state has been tampered with"
+    n <- Saltine.decode nonce `orDie` "Could not decode nonce"
+    decrypted <- secretboxOpen encrypt n private
+                  `orDie` "Could not decrypt private state"
+    decoded <- eitherDecode' (fromStrict decrypted)
+    check (link decoded == coordinates public)
+      `orDie` "Private and public parts do not match"
+    return $ merge public decoded
+  where
+    orDie :: Maybe a -> String -> Either String a
+    orDie m errorMessage = maybe (Left errorMessage) Right m
+    check :: Bool -> Maybe ()
+    check test = if test then Just () else Nothing
+
+play :: PlayerID -> KoiKoi.Move -> PublicGame -> App.T (Either String (Game, [KoiKoi.Action]))
+play playerID move publicGame
+  | playing (public publicGame) == playerID = do
+      result <- fromPublic publicGame
+      case result of
+        Left errorMessage -> return $ Left errorMessage
+        Right game -> lift . runExceptT . runWriterT $ KoiKoi.play move game
+  | otherwise = return $ Left "Not your turn"

src/Keys.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Keys (
+      T(..)
+    , getKeys
+    , public
+    , secret
+  ) where
+
+import Config (libDir)
+import Control.Monad.State (MonadState(..), StateT(..), evalStateT, lift)
+import Crypto.Saltine.Class (IsEncoding(..))
+import qualified Crypto.Saltine.Core.SecretBox as Encrypt (Key, newKey)
+import qualified Crypto.Saltine.Core.Sign as Sign (
+    Keypair, PublicKey, SecretKey, newKeypair
+  )
+import qualified Data.ByteString as BS (
+    ByteString, length, readFile, singleton, splitAt, uncons, writeFile
+  )
+import System.Directory (createDirectoryIfMissing, doesFileExist)
+import System.Exit (die)
+import System.FilePath ((</>))
+
+data T = T {
+      encrypt :: Encrypt.Key
+    , sign :: Sign.Keypair
+  }
+
+serialize :: T -> BS.ByteString
+serialize (T {encrypt, sign = (secretKey, publicKey)}) =
+  mconcat [encodeKey encrypt, encodeKey secretKey, encodeKey publicKey]
+  where
+    encodeKey key =
+      let encodedKey = encode key in
+      (BS.singleton . toEnum $ BS.length encodedKey) <> encodedKey
+
+unserialize :: BS.ByteString -> Maybe T
+unserialize = evalStateT $ T <$> decodeKey <*> ((,) <$> decodeKey <*> decodeKey)
+  where
+    decodeKey :: IsEncoding a => StateT BS.ByteString Maybe a
+    decodeKey = do
+      keyLength <- fromEnum <$> StateT BS.uncons
+      lift . decode =<< state (BS.splitAt keyLength)
+
+getKeys :: IO T
+getKeys = do
+  fileExists <- doesFileExist keyRing
+  if fileExists
+  then BS.readFile keyRing >>= tryUnserialize
+  else do
+    newT <- T <$> Encrypt.newKey <*> Sign.newKeypair
+    createDirectoryIfMissing True libDir
+    BS.writeFile keyRing $ serialize newT
+    return newT
+  where
+    keyRing = libDir </> "keys"
+    tryUnserialize = maybe (die "Could not unserialize key") return . unserialize
+
+public :: Sign.Keypair -> Sign.PublicKey
+public = snd
+
+secret :: Sign.Keypair -> Sign.SecretKey
+secret = fst

src/Main.hs

@@ -2,41 +2,45 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Main where
 
-import qualified App (Context(..), T, update_)
-import qualified Automaton (start)
+import qualified App (Context(..), T, exec)
+import qualified Automaton (loop)
 import qualified Config (listenPort)
 import Control.Concurrent (newMVar, modifyMVar)
 import Control.Exception (finally)
 import Control.Monad.Reader (ReaderT(..), asks)
-import qualified Hanafuda.Message as Message (FromClient(..))
-import Messaging (broadcast, relay)
+import Crypto.Saltine (sodiumInit)
+import qualified Hanafuda.Message as Message (T(..))
+import Messaging (broadcast)
 import Network.HTTP.Types.Status (badRequest400)
 import Network.Wai (responseLBS)
 import Network.Wai.Handler.Warp (run)
 import Network.Wai.Handler.WebSockets (websocketsOr)
 import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions)
-import qualified Server (disconnect, new, register)
+import qualified Server (close, new, register)
 import qualified Session (open)
 
 exit :: App.T ()
 exit = do
-  asks App.playerID >>= App.update_ . Server.disconnect
-  relay Message.LogOut broadcast
+  mPlayerID <- asks App.sessionID >>= App.exec . Server.close
+  case mPlayerID of
+    Nothing -> return ()
+    Just playerID -> Messaging.broadcast $ Message.LogOut playerID
 
 serverApp :: App.T () -> App.T () -> IO ServerApp
 serverApp onEnter onExit = do
-  mServer <- newMVar Server.new
+  mServer <- newMVar =<< Server.new
   return $ \pending -> do
     session <- Session.open <$> acceptRequest pending
-    playerID <- modifyMVar mServer (return . Server.register session)
-    let app = App.Context {App.mServer, App.playerID}
+    sessionID <- modifyMVar mServer (Server.register session)
+    let app = App.Context {App.mServer, App.sessionID}
     finally
       (runReaderT onEnter app)
       (runReaderT onExit app)
 
 main :: IO ()
 main = do
-  app <- serverApp Automaton.start exit
+  sodiumInit
+  app <- serverApp Automaton.loop exit
   run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
   where
     blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")

src/Messaging.hs

@@ -10,51 +10,62 @@ module Messaging (
     , relay
     , send
     , sendTo
-    , update
   ) where
 
-import qualified App (Context(..), T, connection, debug, server)
-import Control.Monad.Reader (asks, lift)
+import qualified App (T, debug, get, player, session)
+import Control.Monad.Reader (lift)
 import Data.Aeson (eitherDecode', encode)
 import Data.ByteString.Lazy.Char8 (unpack)
 import Data.Foldable (forM_)
 import Data.List (intercalate)
-import Data.Map (keys)
-import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game, GameBlueprint(..), PlayerID)
+import Data.Map (elems, keys)
+import Data.Maybe (maybeToList)
+import qualified Data.Set as Set (fromList, member)
+import qualified Game (toPublic)
+import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), PlayerID)
 import Hanafuda.Message (FromClient(..), T(..))
 import qualified Hanafuda.Message as Message (T)
 import Network.WebSockets (receiveData, sendTextData)
-import qualified Game (export)
-import qualified Server (T(..), get)
+import Player (playerID, showDebug)
+import qualified Server (sessionsWhere)
 import qualified Session (T(..))
 
+sendToSessions :: [Session.T] -> Message.T -> App.T ()
+sendToSessions sessions obj = do
+  App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
+  lift . mapM_ (flip sendTextData encoded) $ Session.connection <$> sessions
+  where
+    encoded = encode $ obj
+    recipients = fmap showDebug . maybeToList . Session.player =<< sessions
+
 sendTo :: [KoiKoi.PlayerID] -> Message.T -> App.T ()
 sendTo playerIDs obj = do
-  sessions <- getSessions <$> App.server
-  App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded)
-  lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded
+  sessions <- App.get $ Server.sessionsWhere selectedPlayer
+  sendToSessions (foldl (++) [] sessions) obj
   where
-    encoded = encode $ obj
-    getSessions server = (\playerID -> Server.get playerID server) <$> playerIDs
-    recipients = show <$> playerIDs
+    selectedPlayer playerID _ = Set.member playerID $ Set.fromList playerIDs
 
 send :: Message.T -> App.T ()
 send obj = do
-  playerID <- asks App.playerID
-  sendTo [playerID] obj
+  currentSession <- App.session
+  sendToSessions [currentSession] obj
 
 broadcast :: Message.T -> App.T ()
-broadcast obj =
-  App.server >>= flip sendTo obj . keys . Server.sessions
+broadcast obj = do
+  App.get (concat . elems . allSessions) >>= flip sendToSessions obj
+  where
+    allSessions = Server.sessionsWhere (\_ _ -> True)
 
 relay :: FromClient -> (Message.T -> App.T ()) -> App.T ()
 relay message f = do
   App.debug "Relaying"
-  (\from -> f $ Relay {from, message}) =<< asks App.playerID
+  maybe (return ()) doRelay =<< App.player
+  where
+    doRelay player = f $ Relay {from = playerID player, message}
 
 receive :: App.T FromClient
 receive = do
-  received <- ((lift . receiveData) =<< App.connection)
+  received <- ((lift . receiveData . Session.connection) =<< App.session)
   App.debug $ '>':(unpack received)
   case eitherDecode' received of
     Left errorMessage -> send (Error errorMessage) >> receive
@@ -67,10 +78,7 @@ get =
     pong Ping = send Pong >> get
     pong m = return m
 
-update :: T
-update = Update {alone = [], paired = []}
-
-notifyPlayers :: KoiKoi.Game -> [KoiKoi.Action] -> App.T ()
-notifyPlayers game logs =
-  forM_ (keys $ KoiKoi.scores game) $ \k ->
-    sendTo [k] $ Game {game = Game.export k game, logs}
+notifyPlayers :: (KoiKoi.Game, [KoiKoi.Action]) -> App.T ()
+notifyPlayers (game, logs) =
+  forM_ (keys $ KoiKoi.nextPlayer game) $ \k ->
+    sendTo [k] . Game =<< Game.toPublic k game logs

src/Player.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Player (
+      T(..)
+    , showDebug
+  ) where
+
+import Data.Text (Text)
+import Hanafuda.KoiKoi (PlayerID)
+import Text.Printf (printf)
+
+data T = T {
+      playerID :: PlayerID
+    , name :: Text
+  } deriving (Show)
+
+showDebug :: T -> String
+showDebug (T {playerID, name}) = printf "%s (%s)" name (show playerID)

src/Server.hs

@@ -5,108 +5,113 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Server (
       T(..)
-    , disconnect
-    , endGame
+    , close
     , get
     , logIn
-    , logOut
     , new
     , register
     , room
+    , select
+    , sessionsWhere
     , update
   ) where
 
-import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax, mapWithKey)
-import qualified Data.Map as Map (empty)
-import Data.Set (Set, member)
-import qualified Data.Set as Set (delete, empty, insert)
+import Data.Map (Map, (!), (!?), adjust, delete, insert, mapMaybe)
+import qualified Data.Map as Map (empty, foldlWithKey, lookup)
 import Data.Text (Text)
-import Hanafuda.KoiKoi (Game, GameID, PlayerID)
-import Hanafuda.Message (PlayerStatus(..), Room)
+import Hanafuda.KoiKoi (PlayerID)
+import Hanafuda.Message (Room)
+import Keys (getKeys)
+import qualified Keys (T)
+import qualified Player (T(..))
 import qualified RW (RW(..))
-import qualified Session (Status(..), T(..), Update)
+import qualified Session (ID, T(..), setPlayer)
+import System.Random (Random(..))
 
-type Names = Set Text
-type Players = Map PlayerID Text
-type Sessions = Map PlayerID Session.T
-type Games = Map GameID Game
+type SessionIDs = Map PlayerID [Session.ID]
+type Sessions = Map Session.ID Session.T
 data T = T {
-      names :: Names
-    , players :: Players
+      keys :: Keys.T
+    , sessionIDsByPlayerID :: SessionIDs
     , sessions :: Sessions
-    , games :: Games
   }
 
-instance RW.RW Names T where
-  get = names
-  set names server = server {names}
-
-instance RW.RW Players T where
-  get = players
-  set players server = server {players}
+instance RW.RW SessionIDs T where
+  get = sessionIDsByPlayerID
+  set sessionIDsByPlayerID server = server {sessionIDsByPlayerID}
 
 instance RW.RW Sessions T where
   get = sessions
   set sessions server = server {sessions}
 
-instance RW.RW Games T where
-  get = games
-  set games server = server {games}
-
-export :: Sessions -> PlayerID -> Text -> PlayerStatus
-export sessions playerID playerName = PlayerStatus (playerName, alone)
-  where
-    alone =
-      case Session.status (sessions ! playerID) of
-        Session.LoggedIn True -> True
-        _ -> False
-
-room :: T -> Room
-room (T {players, sessions}) = mapWithKey (export sessions) players
-
-new :: T
-new = T {
-      names = Set.empty
-    , players = Map.empty
+new :: IO T
+new = getKeys >>= \keys -> return $ T {
+      keys
+    , sessionIDsByPlayerID = Map.empty
     , sessions = Map.empty
-    , games = Map.empty
   }
 
-register :: forall a b. (Enum a, Ord a, RW.RW (Map a b) T) => b -> T -> (T, a)
-register x server =
-  let playerID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (RW.get server :: Map a b) in
-  (RW.update (insert playerID x) server, playerID)
+room :: T -> Room
+room = mapMaybe keepName . select (\_ -> Session.player)
+  where
+    keepName [] = Nothing
+    keepName (player:_) = Just $ Player.name player
+
+push :: Ord k => k -> v -> Map k [v] -> Map k [v]
+push key value m =
+  (maybe (insert key [value]) (insert key . (value:)) $ Map.lookup key m) m
+
+select :: (PlayerID -> Session.T -> Maybe a) -> T -> Map PlayerID [a]
+select selector (T {sessionIDsByPlayerID, sessions}) =
+  Map.foldlWithKey (\accumulator playerID sessionIDs ->
+      foldl (\acc ->
+          maybe acc (\v -> push playerID v acc) . selected playerID
+        ) accumulator sessionIDs
+    ) Map.empty sessionIDsByPlayerID
+  where
+    selected playerID sessionID =
+      Map.lookup sessionID sessions >>= selector playerID
+
+sessionsWhere :: (PlayerID -> Session.T -> Bool) -> T -> Map PlayerID [Session.T]
+sessionsWhere predicate = select selectorOfPredicate where
+  selectorOfPredicate playerID session =
+    if predicate playerID session then Just session else Nothing
+
+register :: forall a b. (Random a, Ord a, RW.RW (Map a b) T) => b -> T -> IO (T, a)
+register x server = do
+  newID <- randomIO
+  return (RW.update (insert newID x) server, newID)
 
 get :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> T -> b
-get playerID server = (RW.get server :: Map a b) ! playerID
+get keyID server = (RW.get server :: Map a b) ! keyID
 
 update :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> (b -> b) -> T -> T
-update playerID updator =
-  RW.update (adjust updator playerID :: Map a b -> Map a b)
+update keyID updator =
+  RW.update (adjust updator keyID :: Map a b -> Map a b)
 
-disconnect :: PlayerID -> T -> T
-disconnect playerID =
-  RW.update (delete playerID :: Sessions -> Sessions) . logOut playerID
+logIn :: Text -> PlayerID -> Session.ID -> T -> T
+logIn name playerID sessionID =
+  RW.update (push playerID sessionID) .
+  update sessionID (Session.setPlayer playerID name)
 
-endGame :: GameID -> T -> T
-endGame playerID =
-  RW.update (delete playerID :: Games -> Games)
+close :: Monad m => Session.ID -> T -> m (T, Maybe PlayerID)
+close sessionID server =
+  return . performUpdates $ popSession sessionID server
+  where
+    performUpdates (updateSessionIDs, mPlayerID) = (
+            RW.update (delete sessionID :: Sessions -> Sessions)
+          . RW.update (updateSessionIDs :: SessionIDs -> SessionIDs) $ server
+        , mPlayerID
+      )
 
-logIn :: Text -> PlayerID -> T -> Either String T
-logIn name playerID server =
-  RW.update (Set.insert name) .
-  RW.update (insert playerID name) .
-  update playerID (RW.set $ Session.LoggedIn True :: Session.Update) <$>
-  if name `member` names server
-    then Left "This name is already registered"
-    else Right server
-
-logOut :: PlayerID -> T -> T
-logOut playerID server =
-  maybe
-    server
-    (\playerName ->
-      RW.update (delete playerID :: Players -> Players) $
-      update playerID (RW.set $ Session.LoggedIn False :: Session.Update) $
-      RW.update (Set.delete playerName :: Names -> Names) server)
-    (players server !? playerID)
+popSession :: Session.ID -> T -> (SessionIDs -> SessionIDs, Maybe PlayerID)
+popSession sessionID (T {sessions, sessionIDsByPlayerID}) =
+  case findPlayerID of
+    Nothing -> (id, Nothing)
+    Just (playerID, [_]) -> (delete playerID, Just playerID)
+    Just (playerID, _) -> (purgeSession playerID, Nothing)
+  where
+    findPlayerID = do
+      playerID <- fmap Player.playerID . Session.player =<< (sessions !? sessionID)
+      (,) playerID <$> (sessionIDsByPlayerID !? playerID)
+    purgeSession = adjust (filter (/= sessionID))

src/Session.hs

@@ -1,35 +1,36 @@
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 module Session (
-      Status(..)
+      ID
+    , Status
     , T(..)
     , Update
     , open
+    , setPlayer
   ) where
 
-import Hanafuda.KoiKoi (GameID, PlayerID)
+import Data.Text (Text)
+import qualified Hanafuda.ID as Hanafuda (ID, IDType(..), Prefix(..))
+import Hanafuda.KoiKoi (PlayerID)
 import Network.WebSockets (Connection)
-import qualified RW (RW(..))
-
-data Status =
-    LoggedIn Bool
-  | Answering PlayerID
-  | Waiting PlayerID
-  | Playing GameID
-  deriving (Show)
+import qualified Player (T(..))
 
+type ID = Hanafuda.ID T
+instance Hanafuda.IDType T where
+  prefix = Hanafuda.Prefix "Session"
+type Status = Maybe Player.T
 data T = T {
       connection :: Connection
-    , status :: Status
+    , player :: Status
   }
 type Update = T -> T
 
-instance RW.RW Status T where
-  get = status
-  set status session = session {status}
+setPlayer :: PlayerID -> Text -> Session.Update
+setPlayer playerID name session = session {
+    player = Just $ Player.T {Player.playerID, Player.name}
+  }
 
 open :: Connection -> T
 open connection = T {
       connection
-    , status = LoggedIn False
+    , player = Nothing
   }

www/fun.js

@@ -1,64 +0,0 @@
-function Fun() {
-  return {
-    defaultCompare: defaultCompare,
-    insert: insert,
-    map: map,
-    mapFilter: mapFilter,
-    isSet: isSet,
-    of: of,
-    proj: proj
-  };
-
-  function insert(obj, t, compare, min, max) {
-    min = min == undefined ? 0 : min;
-    max = max == undefined ? t.length : max;
-    compare = compare == undefined ? defaultCompare : compare;
-    if(max - min < 1) {
-      return min;
-    }
-    var avg = Math.floor((max + min) / 2);
-    if (compare(obj, t[avg]) < 0) {
-      return insert(obj, t, compare, min, avg);
-    } else {
-      return insert(obj, t, compare, avg+1, max);
-    }
-  }
-
-  function defaultCompare(a, b) {
-    if(a < b) {
-      return -1;
-    } else if(a > b) {
-      return 1;
-    } else {
-      return 0;
-    }
-  }
-
-  function map(mapper, f) {
-    return function() {
-      var args = Array.prototype.map.call(arguments, mapper);
-      return f.apply(null, args);
-    }
-  }
-
-  function of(o) {
-    return function(key) {return o[key];};
-  }
-
-  function proj(key) {
-    return function(o) {return o[key];};
-  }
-
-  function mapFilter(mapper, predicate) {
-    return function(array) {
-      return array.reduce(function(accumulator, elem) {
-        var v = mapper(elem);
-        return predicate(v) ? accumulator.concat(v) : accumulator;
-      }, []);
-    };
-  }
-
-  function isSet(x) {
-    return x != undefined;
-  }
-}

www/index.html

@@ -3,45 +3,52 @@
   <head>
     <meta charset="utf-8">
     <title>KoiKoi</title>
-    <script src="UnitJS/async.js"></script>
-    <script src="UnitJS/dom.js"></script>
+    <script src="lib/unit.js"></script>
     <script src="translations.js"></script>
     <script src="i18n.js"></script>
-    <script src="fun.js"></script>
     <script src="screen.js"></script>
+    <script src="save.js"></script>
     <script src="messaging.js"></script>
+    <script src="ui.js"></script>
     <script src="session.js"></script>
     <script src="room.js"></script>
     <script src="statusHandler.js"></script>
-    <script src="login.js"></script>
     <script src="hanafuda.js"></script>
-    <script src="game.js"></script>
+    <script src="screen/game.js"></script>
+    <script src="screen/hall.js"></script>
+    <script src="screen/login.js"></script>
     <script src="main.js"></script>
     <link rel="stylesheet" href="screen.css" type="text/css"/>
-    <link rel="stylesheet" href="login.css" type="text/css"/>
-    <link rel="stylesheet" href="game.css" type="text/css"/>
+    <link rel="stylesheet" href="screen/hall.css" type="text/css"/>
+    <link rel="stylesheet" href="screen/game.css" type="text/css"/>
   </head>
   <body>
     <div id="reception" class="on">
-      <h1>Hanafuda</h1>
+      <h1>Hanafuda - KoiKoi</h1>
       <form id="login">
         <input type="submit" name="submitButton" hidden disabled/>
-        <p id="join" class="on">
+        <p id="join">
           <label for="you"></label><input type="text" name="you"/>
           <input type="submit" name="join" disabled/>
         </p>
+      </form>
+    </div>
+    <div id="hall">
+      <form id="room">
+        <input type="submit" name="submitButton" hidden disabled/>
         <p id="invite">
           <label for="them"></label><input type="text" name="them"/>
           <input type="submit" name="invite" disabled/>
         </p>
-        <div id="players">
+        <div class="listSelector" id="players">
           <span class="message"></span>
-          <ul class="list"></ul>
+          <ul></ul>
         </div>
-        <p id="leave">
-          <input type="button" name="leave"/>
-        </p>
       </form>
+      <div class="listSelector" id="games">
+        <span class="message"></span>
+        <ul></ul>
+      </div>
     </div>
     <div id="game">
       <div id="them">

www/login.css

@@ -1,41 +0,0 @@
-#join, #invite {
-  display: none;
-}
-
-#join.on, #invite.on {
-  display: block;
-}
-
-#leave {
-  display: none;
-}
-
-#login.on #join {
-  display: none;
-}
-
-#login.on #leave {
-  display: inline;
-}
-
-#players {
-  min-height: 4em;
-  border: 1px solid #ccc;
-}
-
-#players .message {
-  display: block;
-  text-align: center;
-  margin: 1em;
-  color: #555;
-}
-
-#players .message:empty {
-  display: none;
-}
-
-#players .list {
-  list-style: none;
-  margin: 0;
-  padding-left: 0;
-}

www/login.js

@@ -1,148 +0,0 @@
-function Login(modules) {
-  var root = document.getElementById('login');
-  var playersMessage = root.getElementsByClassName('message')[0];
-  var players = root.getElementsByClassName('list')[0];
-  var join = document.getElementById("join");
-  var invite = document.getElementById("invite");
-  var submit = root.submitButton;
-  var them = null;
-  var invitationAnswers = [{
-    label: 'accept',
-    action: function() {
-      modules.messaging.send({tag: "Answer", accept: true});
-      modules.screen.select("game");
-    }
-  }, {
-    label: 'decline',
-    action: function() {
-      modules.messaging.send({tag: "Answer", accept: false});
-    }
-  }];
-
-  root.addEventListener('submit', function(e) {
-    e.preventDefault();
-    if(modules.session.loggedIn()) {
-      modules.messaging.send({tag: "Invitation", to: them});
-    } else {
-      modules.messaging.send({tag: "LogIn", name: root.you.value});
-    }
-  });
-
-  root.leave.addEventListener('click', function(e) {
-    e.preventDefault();
-    lib.send({tag: "LogOut"})
-  });
-
-  root.you.addEventListener("input", function() {refreshPlayers(false);});
-  root.them.addEventListener("input", function() {refreshPlayers(true);});
-
-  modules.messaging.addEventListener(["Welcome"], function() {
-    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);
-    // invitations should come only from known players, in doubt say «no»
-    if(name) {
-      modules.statusHandler.set("🎴");
-      modules.screen.dialog({
-        text: modules.i18n.get('invited')(name),
-        answers: invitationAnswers
-      });
-    } else {
-      modules.messaging.send({tag: "Answer", accept: false});
-    }
-  });
-
-  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 refreshPlayers(loggedIn) {
-    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));
-    playersMessage.textContent = '';
-    if(exact != undefined) {
-      them = exact.key;
-    } else if(filtered.length == 1) {
-      them = filtered[0].key;
-    } else if(filtered.length == 0) {
-      playersMessage.textContent = modules.i18n.get(
-        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

@@ -1,23 +1,23 @@
 window.addEventListener('load', function() {
-  var dom = Dom();
-  var async = Async();
+  var dom = unitJS.Dom();
+  var async = unitJS.Async();
+  var fun = unitJS.Fun();
   var translations = Translations();
   var i18n = I18n({translations: translations});
-  var fun = Fun();
+  var save = Save();
   var screen = Screen({dom: dom, i18n: i18n});
   var messaging = Messaging({screen: screen});
-  var session = Session({messaging: messaging});
-  var room = Room({dom: dom, messaging: messaging, session: session, fun: fun});
+  var ui = Ui({messaging: messaging});
+  var session = Session({messaging: messaging, save: save});
+  var room = Room({dom: dom, session: session, fun: fun});
   var statusHandler = StatusHandler();
-  var login = Login({dom: dom, i18n: i18n, messaging: messaging, room: room, screen: screen, session: session, statusHandler: statusHandler});
+  var login = Screen.Login({i18n: i18n, messaging: messaging, save: save, screen: screen, session: session, ui: ui});
+  var hall = Screen.Hall({dom: dom, i18n: i18n, messaging: messaging, room: room, save: save, screen: screen, session: session, statusHandler: statusHandler, ui: ui});
   var hanafuda = Hanafuda({fun: fun});
-  var game = Game({async: async, dom: dom, i18n: i18n, fun: fun, hanafuda: hanafuda, messaging: messaging, room: room, screen: screen, session: session, statusHandler: statusHandler});
+  var game = Screen.Game({async: async, dom: dom, i18n: i18n, fun: fun, hanafuda: hanafuda, messaging: messaging, room: room, screen: screen, session: session, statusHandler: statusHandler});
 
   var domElems = {
-    join: document.getElementById('login').join,
-    invite: document.getElementById('login').invite,
-    leave: document.getElementById('login').leave,
-    pickName: document.getElementById('join').getElementsByTagName('label')[0],
+    invite: document.getElementById('room').invite,
     startGameWith: document.getElementById('invite').getElementsByTagName('label')[0]
   };
   for(var key in domElems) {
@@ -26,6 +26,4 @@ window.addEventListener('load', function() {
       default: domElems[key].textContent = i18n.get(key);
     }
   }
-
-  messaging.start();
 });

www/messaging.js

@@ -1,15 +1,25 @@
 function Messaging(modules) {
-  var ws = new WebSocket(window.location.origin.replace(/^http/, 'ws') + '/play/');
+  var wsLocation = window.location.origin.replace(/^http/, 'ws') + '/play/';
+  var ws;
   var debug = getParameters().debug;
   var doLog = debug != undefined && debug.match(/^(?:1|t(?:rue)?|v(?:rai)?)$/i);
-  var keepAlivePeriod = 20000;
+  var on = false;
+  var s = 1000; /* ms */
+  var keepAlivePeriod = 20;
+  var reconnectDelay = 1;
   var routes = {callbacks: [], children: {}};
+  var wsHandlers = {
+    open: [function() {on = true; reconnectDelay = 1}, ping],
+    close: [function() {on = false;}, reconnect]
+  };
+
+  init();
 
   return {
     addEventListener: addEventListener,
-    send: send,
-    start: start
-  }
+    isOn: isOn,
+    send: send
+  };
 
   function get(obj, path, write) {
     write = write || false;
@@ -37,8 +47,16 @@ function Messaging(modules) {
   }
 
   function addEventListener(path, callback) {
-    var route = get(routes, path, true);
-    route.callbacks.push(callback);
+    if(Array.isArray(path)) {
+      var route = get(routes, path, true);
+      route.callbacks.push(callback);
+    } else {
+      if(wsHandlers[path] != undefined) {
+        wsHandlers[path].push(callback);
+      } else {
+        log('Unsupported websocket event "' + path + '"');
+      }
+    }
   }
 
   function messageListener(event) {
@@ -59,26 +77,51 @@ function Messaging(modules) {
     log(o);
   };
 
-  function log(message) {
-    if(doLog) {
-      console.log(message);
-    }
-  }
-
-  function start() {
-    ws.addEventListener('message', messageListener);
-    ws.addEventListener('open', ping);
-    addEventListener(["Pong"], ping);
-    addEventListener(["Error"], function(o) {modules.screen.error(o.error);});
-  }
-
   function send(o) {
     ws.send(JSON.stringify(o));
     o.direction = 'client > server';
     log(o);
   }
 
+  function log(message) {
+    if(doLog) {
+      console.log(message);
+    }
+  }
+
+  function init() {
+    connect();
+    addEventListener(["Pong"], ping);
+    addEventListener(["Error"], function(o) {modules.screen.error(o.error);});
+  }
+
+  function connect() {
+    ws = new WebSocket(window.location.origin.replace(/^http/, 'ws') + '/play/');
+    ws.addEventListener('message', messageListener);
+    ws.addEventListener('open', function(e) {
+      wsHandlers.open.forEach(function(handler) {handler(e);});
+    });
+    ws.addEventListener('close', function(e) {
+      wsHandlers.close.forEach(function(handler) {handler(e);});
+    });
+  }
+
+  function reconnect() {
+    setTimeout(connect, reconnectDelay * s);
+    if(reconnectDelay < 16) {
+      reconnectDelay *= 2;
+    }
+  }
+
+  function isOn() {
+    return on;
+  }
+
   function ping() {
-    setTimeout(function() {send({tag: "Ping"});}, keepAlivePeriod);
+    setTimeout(function() {
+      if(isOn()) {
+        send({tag: "Ping"});
+      }
+    }, keepAlivePeriod * s);
   }
 }

www/room.js

@@ -1,9 +1,8 @@
 function Room(modules) {
 
-  function Player(key, name, alone) {
+  function Player(key, name) {
     this.key = key;
     this.name = name;
-    this.alone = alone;
     this.dom = modules.dom.make('li', {textContent: name});
     this.position = null;
   }
@@ -16,38 +15,20 @@ function Room(modules) {
     selected: null
   };
 
-  modules.messaging.addEventListener(["Welcome"], function(o) {
-    for(var key in o.room) {
-      enter(parseInt(key), o.room[key]);
-    }
-  });
-
-  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.fun.map(function(key) {return players[key].name;}, modules.fun.defaultCompare);
 
   return {
     filter: filter,
     enter: enter,
     leave: leave,
-    name: name
+    name: name,
+    populate: populate
   };
 
   function filter(name) {
-    if(modules.session.loggedIn()) {
+    if(modules.session.isLoggedIn()) {
       var keep = function(player) {
-        return player.name.match(name) && !modules.session.is(player.key) && player.alone;
+        return player.name.match(name) && !modules.session.is(player.key);
       };
     } else {
       var keep = function(player) {return player.name.match(name);};
@@ -55,13 +36,20 @@ function Room(modules) {
     return modules.fun.mapFilter(modules.fun.of(players), keep)(sortedKeys);
   }
 
-  function enter(key, obj) {
-    var name = obj.name || "anon";
-    var alone = obj.alone != undefined ? obj.alone : true;
-    var player = new Player(key, name, alone);
-    players[key] = player;
-    player.position = modules.fun.insert(key, sortedKeys, compareKeysByLogin);
-    sortedKeys.splice(player.position, 0, key);
+  function enter(key, name) {
+    if(!modules.session.is(key)) {
+      name = name || "anon";
+      var player = new Player(key, name);
+      players[key] = player;
+      player.position = modules.fun.insert(key, sortedKeys, compareKeysByLogin);
+      sortedKeys.splice(player.position, 0, key);
+    }
+  }
+
+  function populate(o) {
+    for(var key in o.room) {
+      enter(key, o.room[key]);
+    }
   }
 
   function leave(key) {

www/save.js

@@ -0,0 +1,48 @@
+function Save(modules) {
+  var save = JSON.parse(localStorage.getItem('save')) || {};
+
+  return {
+    get: get,
+    set: set
+  };
+
+  function move(coordinates) {
+    if(coordinates.path.length == 1) {
+      return coordinates;
+    } else {
+      var newFocus = coordinates.focus[coordinates.path[0]];
+      if (newFocus != undefined) {
+        var newCoordinates = {path: coordinates.path.slice(1), focus: newFocus};
+        return move(newCoordinates);
+      } else {
+        return coordinates;
+      }
+    }
+  }
+
+  function get(key) {
+    if(key != undefined) {
+      var outputCoordinates = move({path: key.split('.'), focus: save});
+      if(outputCoordinates.focus != undefined && outputCoordinates.path.length == 1) {
+        return outputCoordinates.focus[outputCoordinates.path[0]]
+      } else {
+        return null;
+      }
+    }
+  }
+
+  function set(key, value) {
+    if(key != undefined) {
+      var outputCoordinates = move({path: key.split('.'), focus: save});
+      while(outputCoordinates.path.length > 1) {
+        outputCoordinates.focus[outputCoordinates.path[0]] = {};
+        outputCoordinates.focus = outputCoordinates.focus[outputCoordinates.path[0]];
+        outputCoordinates.path = outputCoordinates.path.slice(1);
+      }
+      outputCoordinates.focus[outputCoordinates.path[0]] = value;
+    } else {
+      save = value;
+    }
+    localStorage.setItem('save', JSON.stringify(save));
+  }
+}

www/screen/game.css

@@ -111,39 +111,39 @@
   margin: 0;
 }
 
-#rest.init, #rest.count24 {
+#rest.init, #rest.turn0 {
   box-shadow: 2px 3px 0 0 #555, 4px 6px 0 0 #555, 6px 9px 0 0 #555;
 }
 
-#rest.count22 {
+#rest.turn2 {
   box-shadow: 2px 3px 0 0 #555, 4px 6px 0 0 #555, 5.5px 8.3px 0 0 #555;
 }
 
-#rest.count20 {
+#rest.turn4 {
   box-shadow: 2px 3px 0 0 #555, 4px 6px 0 0 #555, 5px 7.5px 0 0 #555;
 }
 
-#rest.count18 {
+#rest.turn6 {
   box-shadow: 2px 3px 0 0 #555, 4px 6px 0 0 #555, 4.5px 6.8px 0 0 #555;
 }
 
-#rest.count16 {
+#rest.turn8 {
   box-shadow: 2px 3px 0 0 #555, 4px 6px 0 0 #555;
 }
 
-#rest.count14 {
+#rest.turn10 {
   box-shadow: 2px 3px 0 0 #555, 3.5px 5.3px 0 0 #555;
 }
 
-#rest.count12 {
+#rest.turn12 {
   box-shadow: 2px 3px 0 0 #555, 3px 4.5px 0 0 #555;
 }
 
-#rest.count10 {
+#rest.turn14 {
   box-shadow: 2px 3px 0 0 #555, 2.5px 3.8px 0 0 #555;
 }
 
-#rest.count8 {
+#rest.turn16 {
   box-shadow: 2px 3px 0 0 #555;
 }
 

www/screen/game.js

@@ -1,8 +1,9 @@
-function Game(modules) {
+Screen.Game = function(modules) {
   var deck = document.getElementById("deck");
   var rest = document.getElementById("rest");
   var status = {
     dom: document.getElementById("status"),
+    game: null,
     playing: false,
     step: null,
     month: null
@@ -53,7 +54,7 @@ function Game(modules) {
 	}
 
 	function handleGameMessage(o) {
-		if(o.game.deck == 24) { // deck is full, means new round
+		if(o.state.public.turns == 0) {
 			if(o.logs.length > 0) { // but still some logs, from the previous round
 				return modules.async.sequence(applyDiff(o), setGame(o)); // so play the diff, then set the new round
 			} else {
@@ -66,13 +67,13 @@ function Game(modules) {
 
 	function setGame(o) {
 		return function(f) {
-			setStatus(o.game);
-			setCaptures(o.game);
+			setStatus(o.state);
+			setCaptures(o.state);
 			[
-				[sets.river, o.game.river, RiverCard],
-				[sets.you.hand, o.game.players[modules.session.getKey()].hand, HandCard]
+				[sets.river, o.state.public.river, RiverCard],
+				[sets.you.hand, o.state.playerHand, HandCard]
 			].forEach(function(args) {setCardSet.apply(null, args)});
-			setTheirCards(o.game);
+			setTheirCards(o.state);
 			handleStep(o)(f);
 		};
 	}
@@ -96,10 +97,10 @@ function Game(modules) {
 
 	function handleTurnedCard(o, f) {
 		if(status.step == "Turned") {
-			setTurned(o.game.step.contents);
+			setTurned(o.state.public.step.contents);
 		} else {
-			if(status.step == "ToPlay" && o.game.playing == o.game.oyake) {
-				rest.className = ["card", "count" + o.game.deck].join(' ');
+			if(status.step == "ToPlay" && o.state.public.playing == o.state.public.oyake) {
+				rest.className = ["card", "turn" + o.state.public.turns].join(' ');
 			}
 			if(deck.lastChild.id != "rest") {
 				deck.removeChild(deck.lastChild);
@@ -120,7 +121,7 @@ function Game(modules) {
 
 	function theyScored(o, f) {
 		modules.screen.dialog({
-			text: modules.i18n.get('theyScored')(modules.room.name(o.game.playing)),
+			text: modules.i18n.get('theyScored')(modules.room.name(o.state.public.playing)),
 			answers: [
 				{label: 'ok', action: f}
 			]
@@ -129,10 +130,10 @@ function Game(modules) {
 
 	function gameEnd(o, f) {
 		var winner, maxScore;
-		for(var key in o.game.scores) {
-			if(maxScore == undefined || o.game.scores[key] > maxScore) {
+		for(var key in o.state.public.scores) {
+			if(maxScore == undefined || o.state.public.scores[key] > maxScore) {
 				winner = key;
-				maxScore = o.game.scores[key];
+				maxScore = o.state.public.scores[key];
 			}
 		}
 		modules.screen.dialog({
@@ -151,7 +152,7 @@ function Game(modules) {
 	function applyDiff(o) {
 		return modules.async.sequence.apply(null,
 			o.logs.map(animate).concat(
-				modules.async.apply(setStatus, o.game),
+				modules.async.apply(setStatus, o.state),
 				handleStep(o)
 			)
 		);
@@ -233,48 +234,50 @@ function Game(modules) {
   function play(move) {
     modules.messaging.send({
       tag: "Play",
-      move: move
+      move: move,
+      onGame: status.game
     });
   }
 
   function matchingInRiver(card) {
     return modules.fun.mapFilter(
       modules.fun.of(sets.river.card),
-      modules.fun.isSet
+      modules.fun.defined
     )(modules.hanafuda.sameMonth(card).map(modules.fun.proj('name')));
   }
 
   function setStatus(game) {
     modules.dom.clear(status.dom);
-    status.step = game.step.tag;
-    if(game.month != status.month) {
-      status.month = game.month;
+    status.game = game;
+    status.step = game.public.step.tag;
+    if(game.public.month != status.month) {
+      status.month = game.public.month;
     }
     status.dom.appendChild(
       modules.dom.make('li', {textContent: modules.i18n.get('monthFlower')(modules.i18n.get(status.month))})
     );
     var turn = null;
-    status.playing = modules.session.is(game.playing);
+    status.playing = modules.session.is(game.public.playing);
     if(status.playing) {
       sets.you.hand.dom.classList.toggle("yourTurn", status.step == "ToPlay");
       turn = modules.i18n.get("yourTurn");
     } else {
       sets.you.hand.dom.classList.remove("yourTurn");
-      turn = modules.i18n.get('playing')(modules.room.name(game.playing));
+      turn = modules.i18n.get('playing')(modules.room.name(game.public.playing));
     }
     status.dom.appendChild(modules.dom.make('li', {textContent: turn}));
   }
 
   function setCaptures(game) {
-    for(var key in game.players) {
+    for(var key in game.public.players) {
       var elem = document.getElementById(modules.session.is(key) ? "you" : "them");
-      elem.getElementsByClassName('score')[0].textContent = game.scores[key] + " pts";
+      elem.getElementsByClassName('score')[0].textContent = game.public.scores[key] + " pts";
       var byClass = {}
       Object.values(modules.hanafuda.Family).forEach(function(family) {
         byClass[family.class] = elem.getElementsByClassName(family.class)[0];
         modules.dom.clear(byClass[family.class]);
       });
-      game.players[key].meld.forEach(function(cardName) {
+      game.public.players[key].meld.forEach(function(cardName) {
         var card = new Card(cardName);
         byClass[card.value.family.class].appendChild(card.dom);
       });
@@ -294,7 +297,7 @@ function Game(modules) {
 
   function setTheirCards(game) {
     var turnsTheyPlayed = Math.floor(
-      (24 - game.deck + (modules.session.is(game.oyake) ? 0 : 1)) / 2
+      (game.public.turns + (modules.session.is(game.public.oyake) ? 0 : 1)) / 2
     );
     modules.dom.clear(sets.them.hand.dom);
     for(var i = 0; i < 8 - turnsTheyPlayed; i++) {

www/screen/hall.css

@@ -0,0 +1,21 @@
+.listSelector {
+  min-height: 4em;
+  border: 1px solid #ccc;
+}
+
+.listSelector .message {
+  display: block;
+  text-align: center;
+  margin: 1em;
+  color: #555;
+}
+
+.listSelector .message:empty {
+  display: none;
+}
+
+.listSelector ul {
+  list-style: none;
+  margin: 0;
+  padding-left: 0;
+}

www/screen/hall.js

@@ -0,0 +1,127 @@
+Screen.Hall = function(modules) {
+  var form = modules.ui.connectedForm('room');
+  var players = listSelector('players');
+  var games = listSelector('games');
+  var them = null;
+  var invitationAnswers = [{
+    label: 'accept',
+    action: function() {
+      modules.messaging.send({tag: "Answer", accept: true});
+      modules.screen.select("game");
+    }
+  }, {
+    label: 'decline',
+    action: function() {
+      modules.messaging.send({tag: "Answer", accept: false});
+    }
+  }];
+
+  init();
+
+  return {};
+
+  function listSelector(id) {
+    var root = document.getElementById(id);
+    return {
+      root: root,
+      message: root.getElementsByClassName('message')[0],
+      list: root.getElementsByClassName('list')[0]
+    }
+  }
+
+  function init() {
+    initDOMEvents();
+    initMessageHandlers();
+  }
+
+  function initDOMEvents() {
+    form.addEventListener('submit', function(e) {
+      e.preventDefault();
+      modules.messaging.send({tag: "Invitation", to: them});
+    });
+
+    form.them.addEventListener("input", function() {refreshPlayers();});
+  }
+
+  function initMessageHandlers() {
+    modules.messaging.addEventListener(["Okaeri"], function(o) {
+      modules.room.populate(o);
+      refreshPlayers();
+      refreshGames();
+    });
+
+    modules.messaging.addEventListener(["Welcome"], function(o) {
+      modules.room.populate(o);
+      refreshPlayers();
+      refreshGames();
+    });
+
+    modules.messaging.addEventListener(["LogIn"], function(o) {
+      modules.room.enter(o.from, o.as);
+      refreshPlayers();
+    });
+
+    modules.messaging.addEventListener(["LogOut"], function(o) {
+      modules.room.leave(o.from);
+      refreshPlayers();
+    });
+
+    modules.messaging.addEventListener(["Relay", "Invitation"], function(o) {
+      console.log("Received an invitation, should be added to games list");
+      console.log(o);
+      /*
+      var name = modules.room.name(o.from);
+      // invitations should come only from known players, in doubt say «no»
+      if(name) {
+        modules.statusHandler.set("🎴");
+        modules.screen.dialog({
+          text: modules.i18n.get('invited')(name),
+          answers: invitationAnswers
+        });
+      } else {
+        modules.messaging.send({tag: "Answer", accept: false});
+      }
+      */
+    });
+
+    modules.messaging.addEventListener(["Relay", "Answer"], function(o) {
+      if(o.message.accept) {
+        modules.screen.select("game");
+      }
+    });
+  }
+
+  function refreshPlayers() {
+    modules.dom.clear(players.list);
+    players.message.textContent = '';
+    var name = form.them.value;
+    them = null;
+    var filtered = modules.room.filter(name);
+    filtered.forEach(function(player) {
+      players.list.appendChild(player.dom);
+    });
+    var exact = filtered.find(exactMatch(name));
+    if(exact != undefined) {
+      them = exact.key;
+    } else if(filtered.length == 1) {
+      them = filtered[0].key;
+    } else if(filtered.length == 0) {
+      players.message.textContent = modules.i18n.get(
+        name.length > 0 ? "notFound" : "alone"
+      );
+    }
+    modules.ui.enableForm('room', them != undefined);
+  }
+
+  function refreshGames() {
+    modules.dom.clear(games.list);
+    games.message.textContent = modules.i18n.get('noGames');
+  }
+
+  function exactMatch(name) {
+    return function(player) {
+      return player.name === name;
+    };
+  }
+
+}

www/screen/login.js

@@ -0,0 +1,38 @@
+Screen.Login = function(modules) {
+  var form = modules.ui.connectedForm('login');
+  init();
+
+  return {};
+
+  function init() {
+    initDOM();
+    initMessageHandlers();
+    var name = modules.save.get('player.name');
+    if(name != undefined && name.length > 0) {
+      form.you.value = name;
+      modules.ui.enableForm('login', true);
+    }
+  }
+
+  function initDOM() {
+    form.getElementsByTagName('label')[0].textContent = modules.i18n.get('pickName');
+    form.join.value = modules.i18n.get('join');
+    form.addEventListener('submit', function(e) {
+      e.preventDefault();
+      modules.session.start(form.you.value);
+    });
+    form.you.addEventListener("input", validate);
+  }
+
+  function initMessageHandlers() {
+    modules.messaging.addEventListener(["LogIn"], function(o) {
+      if(modules.session.is(o.from)) {
+        modules.screen.select('hall');
+      }
+    });
+  }
+
+  function validate(e) {
+    modules.ui.enableForm('login', e.target.value != "")
+  }
+}

www/session.js

@@ -1,32 +1,48 @@
 function Session(modules) {
   var key = null;
+	var playerKey = null;
   var name = null;
+  var loggedIn = false;
 
   modules.messaging.addEventListener(["Welcome"], function(o) {
-    key = o.key;
+    playerKey = o.key;
+    modules.save.set('player.id', o.key);
   });
 
-  modules.messaging.addEventListener(["Relay", "LogIn"], function(o) {
+  modules.messaging.addEventListener(["LogIn"], function(o) {
     if(is(o.from)) {
-      name = o.message.name;
+      name = o.as;
+      loggedIn = true;
     }
   });
 
   return {
     is: is,
     getKey: getKey,
-    loggedIn: loggedIn
+    isLoggedIn: isLoggedIn,
+    start: start
   };
 
-  function is(sessionKey) {
-    return key == sessionKey;
+  function is(somePlayerKey) {
+    return playerKey == somePlayerKey;
   }
 
   function getKey() {
     return key;
   }
 
-  function loggedIn() {
-    return name != undefined;
+  function isLoggedIn() {
+    return loggedIn;
+  }
+
+  function start(name) {
+    var myID = modules.save.get('player.id');
+    if(myID != undefined) {
+      modules.messaging.send({tag: 'Tadaima', myID: myID, name: name});
+			playerKey = myID;
+    } else {
+      modules.messaging.send({tag: 'Hello', name: name});
+    }
+    modules.save.set('player.name', name);
   }
 }

www/translations.js

@@ -29,6 +29,7 @@ function Translations() {
 			monthFlower: function(flower) {
 				return "This month's flower is the " + flower;
 			},
+			noGames: "No games being played",
 			notFound: "No one goes by that name",
 			pickName: "Pick a name you like",
 			playing: function(name) {
@@ -72,6 +73,7 @@ function Translations() {
 			monthFlower: function(flower) {
 				return "C'est le mois des " + flower;
 			},
+			noGames: "Aucune partie en cours",
 			notFound: "Personne ne s'appelle comme ça",
 			pickName: "Choisissez votre nom",
 			playing: function(name) {

www/ui.js

@@ -0,0 +1,38 @@
+function Ui(modules) {
+	var connectedForms = {};
+
+	modules.messaging.addEventListener('open', refreshForms);
+	modules.messaging.addEventListener('close', refreshForms);
+
+	return {
+		connectedForm: connectedForm,
+		enableForm: enableForm
+	};
+
+	function connectedForm(formId) {
+		var root = document.getElementById(formId);
+		connectedForms[formId] = {
+			root: root,
+			submits: root.querySelectorAll('[type=submit]'),
+			enabled: false
+		};
+		return root;
+	}
+
+	function enableForm(formId, enabled) {
+		connectedForms[formId].enabled = enabled || undefined == enabled;
+		refreshForm(connectedForms[formId]);
+	}
+
+	function refreshForms() {
+		for(var key in connectedForms) {
+			refreshForm(connectedForms[key]);
+		}
+	}
+
+	function refreshForm(form) {
+		form.submits.forEach(function(button) {
+			button.disabled = !(modules.messaging.isOn() && form.enabled);
+		});
+	}
+}