First draft, basic session handling

.gitignore

@@ -0,0 +1 @@
+/dist/*

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for hanafudapi
+
+## 0.1.0.0  -- 2018-03-17
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2018, Sasha
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Sasha nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

hanafudapi.cabal

@@ -0,0 +1,48 @@
+-- Initial hanafudapi.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                hanafudapi
+version:             0.1.0.0
+synopsis:            An API for the Haskell hanafuda library
+-- description:         
+homepage:            https://framagit.org/hanafuda
+license:             BSD3
+license-file:        LICENSE
+author:              Sasha
+maintainer:          sasha+frama@marvid.fr
+-- copyright:           
+category:            Web
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+source-repository head
+  type:              git
+  location:          https://framagit.org/hanafuda/api
+
+executable hanafudapi
+  main-is:             Main.hs
+  other-modules:       Config
+                     , Message
+                     , Game
+                     , JSON
+                     , Data
+                     , Player
+                     , Server
+                     , Session
+  -- other-extensions:    
+  build-depends:       base >=4.10 && <4.11
+                     , bytestring
+                     , containers
+                     , hanafuda
+                     , http-types
+                     , aeson
+                     , mtl
+                     , text
+                     , vector
+                     , wai
+                     , wai-websockets
+                     , warp
+                     , websockets
+  ghc-options:         -Wall -fno-warn-orphans
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/Config.hs

@@ -0,0 +1,6 @@
+module Config (
+    listenPort
+  ) where
+
+listenPort :: Int
+listenPort = 3000

src/Data.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Data (
+    RW(..)
+  ) where
+
+class RW a b where
+  update :: (a -> a) -> b -> b
+  set :: a -> b -> b
+  set = update . const
+

src/Game.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Game where
+
+import Hanafuda (Card(..))
+import Hanafuda.KoiKoi (Move(..))
+import Data.Aeson (FromJSON(..), ToJSON(..), genericToEncoding)
+import qualified JSON (singleLCField)
+import GHC.Generics
+
+deriving instance Generic Card
+deriving instance Generic Move
+
+instance FromJSON Card
+instance ToJSON Card
+
+instance FromJSON Move
+instance ToJSON Move where
+  toEncoding = genericToEncoding JSON.singleLCField

src/JSON.hs

@@ -0,0 +1,21 @@
+module JSON (
+      defaultOptions
+    , singleLCField
+  ) where
+
+import Data.Char (toLower)
+import Data.Aeson (
+      Options(..)
+    , SumEncoding(..)
+    , defaultOptions
+  )
+
+first :: (a -> a) -> [a] -> [a]
+first _ [] = []
+first f (x:xs) = f x:xs
+
+singleLCField :: Options
+singleLCField = defaultOptions {
+      constructorTagModifier = (toLower `first`)
+    , sumEncoding = ObjectWithSingleField
+  }

src/Main.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+module Main where
+
+import Network.Wai.Handler.Warp (run)
+import Network.HTTP.Types.Status (badRequest400)
+import Network.WebSockets (defaultConnectionOptions)
+import Network.Wai.Handler.WebSockets (websocketsOr)
+import Network.Wai (responseLBS)
+import qualified Config (listenPort)
+import qualified Player (Login(..), T(..))
+import qualified Server (logIn, logOut, disconnect)
+import qualified Session (App, debug, get, player, serve, update)
+import qualified Message (FromClient(..), T(..), broadcast, receive, relay, send)
+
+type Vertex = Session.App ()
+type Edges = Message.FromClient -> Vertex
+
+newVertex :: String -> Edges -> Vertex
+newVertex name = do
+  (Session.debug name >> catchPings >>=)
+  where
+    catchPings = Message.receive >>= pong
+    pong Message.Ping = (Message.send Message.Pong >> catchPings)
+    pong m = return m
+
+enter :: Vertex
+enter = do
+  Session.debug "Initial state"
+  Session.get id >>= (Message.send . Message.Welcome)
+  connected
+
+onErrorGoto :: Vertex -> String -> Session.App ()
+onErrorGoto vertex message = 
+  (Message.send $ Message.Error message) >> vertex
+
+connected  :: Vertex
+connected = newVertex "Connected" edges
+  where
+    edges logIn@(Message.LogIn login) =
+       Session.update (Server.logIn login)
+       >>= maybe
+        (Message.relay logIn Message.broadcast >> loggedIn)
+        (onErrorGoto connected)
+    edges _ = Session.debug "Invalid message" >> connected
+
+loggedIn :: Vertex
+loggedIn = newVertex "Logged in" edges
+  where
+    edges logOut@Message.LogOut = do
+      Message.relay logOut Message.broadcast
+      Session.update Server.logOut
+      >>= maybe
+        connected
+        (onErrorGoto loggedIn)
+    edges _ = loggedIn
+
+exit :: Vertex
+exit = do
+  leaving <- Player.login <$> Session.player
+  _ <- Session.update Server.disconnect -- ignoring never-occuring error
+  case leaving of
+    Player.Login from -> Message.broadcast $
+      Message.Relay {Message.from, Message.message = Message.LogOut}
+    _ -> return ()
+
+main :: IO ()
+main = do
+  app <- Session.serve enter exit
+  run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
+  where
+    blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")

src/Message.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Message (
+      FromClient(..)
+    , T(..)
+    , broadcast
+    , receive
+    , relay
+    , send
+  ) where
+
+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 Control.Monad.Reader (lift)
+import qualified Player (Login(..), Name, T(..))
+import qualified Server (T(..))
+import qualified Session (App, connection, debug, get, player)
+import qualified Hanafuda.KoiKoi as KoiKoi (Move(..))
+import GHC.Generics (Generic)
+import Game ()
+
+data FromClient =
+    Answer {accept :: Bool}
+  | Invitation {to :: Player.Name}
+  | LogIn {name :: Player.Name}
+  | LogOut
+  | Game {move :: KoiKoi.Move}
+  | Ping
+  deriving (Generic)
+
+instance ToJSON FromClient where
+  toEncoding = genericToEncoding defaultOptions
+instance FromJSON FromClient where
+  parseJSON = genericParseJSON defaultOptions
+
+data T =
+    Relay {from :: Player.Name, message :: FromClient}
+  | Welcome {room :: Server.T}
+  | Pong
+  | Error {error :: String}
+  deriving (Generic)
+
+instance ToJSON T where
+  toEncoding = genericToEncoding defaultOptions
+
+sendTo :: T -> Player.T -> Session.App ()
+sendTo obj player = do
+  Session.debug $ '(' : playerLogin ++ ") <" ++ (unpack encoded)
+  lift $ sendTextData (Player.connection player) $ encoded
+  where
+    encoded = encode $ obj
+    playerLogin = unpack $ encode $ Player.login player
+
+send :: T -> Session.App ()
+send obj =
+  (obj `sendTo`) =<< Session.player
+
+broadcast :: T -> Session.App ()
+broadcast obj =
+  Session.get Server.bySessionId
+  >>= mapM_ (obj `sendTo`)
+
+relay :: FromClient -> (T -> Session.App ()) -> Session.App ()
+relay message f =
+  Session.debug "Relaying"
+  >> Session.player >>= (ifLoggedIn . Player.login)
+  >> Session.debug "Relayed"
+  where
+    ifLoggedIn Player.Anonymous = return ()
+    ifLoggedIn (Player.Login from) = f $ Relay {from, message}
+
+receive :: Session.App FromClient
+receive = do
+  received <- ((lift . receiveData) =<< Session.connection)
+  Session.debug $ '>':(unpack received)
+  case eitherDecode' received of
+    Left errorMessage -> send (Message.Error errorMessage) >> receive
+    Right clientMessage -> return clientMessage

src/Player.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+module Player (
+      Login(..)
+    , Name(..)
+    , Status(..)
+    , T(..)
+    , new
+  ) where
+
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import Data.Aeson (FromJSON(..), ToJSON(..), (.=), Value(..), genericToEncoding, object, pairs)
+import qualified JSON (defaultOptions, singleLCField)
+import qualified Data (RW(..))
+import Network.WebSockets (Connection)
+import GHC.Generics
+
+newtype Name = Name Text deriving (Eq, Ord, Generic)
+data Login = Anonymous | Login Name
+
+data Status =
+    LoggedIn Bool
+  | Answering Name
+  | Waiting Name
+  deriving (Generic)
+
+data T = T {
+      connection :: Connection
+    , login :: Login
+    , status :: Status
+  }
+
+instance Data.RW Login T where
+  update f player@(T {login}) = player {login = f login}
+
+instance Data.RW Status T where
+  update f player@(T {status}) = player {status = f status}
+
+instance ToJSON Name where
+  toEncoding = genericToEncoding JSON.defaultOptions
+instance FromJSON Name
+
+instance ToJSON Login where
+  toJSON Anonymous = toJSON Null
+  toJSON (Login name) = toJSON name
+  toEncoding Anonymous = toEncoding Null
+  toEncoding (Login name) = toEncoding name
+
+instance FromJSON Login where
+  parseJSON Null = return Anonymous
+  parseJSON s = Login <$> parseJSON s
+
+instance ToJSON Status where
+  toEncoding = genericToEncoding JSON.singleLCField
+
+instance ToJSON T where
+  toJSON (T {login, status}) = object ["login" .= login, "status" .= status]
+  toEncoding (T {login, status}) = pairs (
+      "login" .= login <> "status" .= status
+    )
+
+new :: Connection -> T
+new connection = T {connection, login = Anonymous, status = LoggedIn False}

src/Server.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Server (
+      SessionId
+    , T(..)
+    , disconnect
+    , join
+    , logIn
+    , logOut
+    , new
+  ) where
+
+import Data.Vector (fromList)
+import Data.Aeson (ToJSON(..), Value(Array))
+import Data.Map ((!), (!?), Map, adjust, delete, elems, empty, insert, lookupMax)
+import qualified Data (RW(..))
+import qualified Player (Login(..), Name(..), T(..))
+
+newtype SessionId = SessionId Int deriving (Eq, Ord, Read, Show)
+type Players = Map SessionId Player.T
+type SessionIds = Map Player.Name SessionId
+data T = T {
+      byName :: SessionIds
+    , bySessionId :: Players
+  }
+
+instance Data.RW SessionIds T where
+  update f server@(T {byName}) = server {byName = f byName}
+
+instance Data.RW Players T where
+  update f server@(T {bySessionId}) = server {bySessionId = f bySessionId}
+
+loggedInPlayers :: T -> [Player.T]
+loggedInPlayers (T {byName, bySessionId}) =
+  [(bySessionId ! sessionId) | sessionId <- elems byName]
+
+instance ToJSON T where
+  toJSON = Array . fromList . (toJSON <$>) . loggedInPlayers
+  toEncoding = toEncoding . loggedInPlayers
+
+new :: T
+new = T {
+      byName = empty
+    , bySessionId = empty
+  }
+
+join :: Player.T -> T -> IO (T, SessionId)
+join player server@(T {bySessionId}) =
+  return (Data.update (insert sessionId player) server, sessionId)
+  where
+    sessionId = SessionId $ maybe 0 (\(SessionId n, _) -> n+1) $ lookupMax bySessionId
+
+disconnect :: SessionId -> T -> Either String T
+disconnect sessionId server =
+  Data.update (delete sessionId :: Players -> Players) <$> logOut sessionId server
+
+logIn :: Player.Name -> SessionId -> T -> Either String T
+logIn name sessionId server =
+  Data.update (adjust (Data.set (Player.Login name) :: Player.T -> Player.T) sessionId) <$>
+  Data.update (insert name sessionId) <$>
+  maybe (Right server) (\_ -> Left "This name is already registered") maybeName
+  where
+    maybeName = byName server !? name
+
+logOut :: SessionId -> T -> Either String T
+logOut sessionId server@(T {bySessionId}) =
+  Right $ Data.update (adjust (Data.set Player.Anonymous :: Player.T -> Player.T) sessionId) $
+  (case Player.login $ bySessionId ! sessionId of
+    (Player.Login name) -> Data.update (delete name :: SessionIds -> SessionIds) server
+    Player.Anonymous -> server)

src/Session.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Session (
+      App
+    , T(..)
+    , connection
+    , debug
+    , get
+    , player
+    , serve
+    , update
+  ) where
+
+import Data.Map ((!))
+import Control.Concurrent (MVar, newMVar, modifyMVar, putMVar, readMVar, takeMVar)
+import Control.Exception (finally)
+import Control.Monad.Reader (ReaderT(..), ask, asks, lift)
+import Network.WebSockets (Connection, ServerApp, acceptRequest)
+import qualified Player (T(..), new)
+import qualified Server (SessionId, T(..), join, new)
+
+data T = T {
+      server :: MVar Server.T
+    , key :: Server.SessionId
+  }
+
+type App a = ReaderT T IO a
+
+get :: (Server.T -> a) -> App a
+get f =
+  asks server
+  >>= lift . (f <$>) . readMVar
+
+player :: App Player.T
+player = do
+  sId <- asks key
+  get ((! sId) . Server.bySessionId)
+
+connection :: App Connection
+connection = Player.connection <$> player
+
+debug :: String -> App ()
+debug message =
+  show <$> asks Session.key
+  >>= lift . putStrLn . (++ ' ':message)
+
+update :: (Server.SessionId -> Server.T -> Either String Server.T) -> App (Maybe String)
+update f = do
+  T {server, key} <- ask
+  currentValue <- lift $ takeMVar server
+  lift $ case f key currentValue of
+    Left message -> putMVar server currentValue >> return (Just message)
+    Right updated -> putMVar server updated >> return Nothing
+
+serve :: App () -> App () -> IO ServerApp
+serve onEnter onExit = do
+  server <- newMVar Server.new
+  return $ \pending -> do
+    key <- acceptRequest pending
+                 >>= return . Player.new
+                 >>= modifyMVar server . Server.join
+    finally
+      (runReaderT onEnter $ T {server, key})
+      (runReaderT onExit $ T {server, key})
+

www/connect.js

@@ -0,0 +1,42 @@
+window.addEventListener('load', function() {
+	var ws = new WebSocket('ws://' + window.location.hostname + '/play/');
+	var lib = Lib(ws);
+  var room = Room(document.getElementById('players'), 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":
+        room.populate(o.room);
+        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);
+				login.onLogIn(o.from);
+        break;
+      case "LogOut":
+        room.leave(o.from);
+				login.onLogOut(o.from);
+        break;
+    }
+  }
+
+  function ping() {
+    lib.send({tag: "Ping"});
+  }
+});

www/index.html

@@ -0,0 +1,29 @@
+<!DOCTYPE HTML>
+<html>
+	<head>
+		<title>KoiKoi</title>
+		<script src="lib.js"></script>
+		<script src="login.js"></script>
+		<script src="room.js"></script>
+		<script src="connect.js"></script>
+		<link rel="stylesheet" href="skin.css" type="text/css"/>
+	</head>
+	<body>
+		<p>Hanafuda</p>
+    <form id="login">
+      <p id="join">
+        <label for="name">Name</label><input type="text" name="name"/>
+        <input type="submit" name="join" value="Join"/>
+      </p>
+      <p id="leave">
+        <input type="button" name="leave" value="Leave"/>
+      </p>
+    </form>
+    <form id="room">
+      <ul id="players">
+      </ul>
+      <input type="submit" name="invite" value="Invite to a game" disabled/>
+    </form>
+    <p id="debug"></p>
+	</body>
+</html>

www/lib.js

@@ -0,0 +1,27 @@
+function Lib(ws) {
+	return {
+		clearElement: clearElement,
+		insert: insert,
+		send: send
+	};
+
+  function clearElement(elem) {
+    while(elem.firstChild) {
+      elem.removeChild(elem.firstChild);
+    }
+  }
+
+	function insert(obj, t, min, max) {
+		min = min || 0;
+		max = max || t.length;
+		if(max - min < 1) {
+			return min;
+		}
+		var avg = Math.floor((max + min) / 2);
+		return (obj < t[avg]) ? insert(obj, t, min, avg) : insert(obj, t, avg+1, max);
+	}
+
+  function send(o) {
+    ws.send(JSON.stringify(o));
+  }
+}

www/login.js

@@ -0,0 +1,30 @@
+function Login(domElem, lib) {
+	var login = null;
+  domElem.addEventListener('submit', function(e) {
+    e.preventDefault();
+    lib.send({tag: "LogIn", name: domElem.name.value})
+  });
+  domElem.leave.addEventListener('click', function(e) {
+    e.preventDefault();
+    lib.send({tag: "LogOut"})
+  });
+
+	return {
+		onLogIn: onLogIn,
+		onLogOut: onLogOut
+	};
+
+	function onLogIn(name) {
+    if(name == domElem.name.value) {
+      domElem.className = "on";
+			login = name;
+    }
+	}
+
+	function onLogOut(name) {
+		if(name == login) {
+			login = null;
+      domElem.className = "";
+		}
+	}
+}

www/room.js

@@ -0,0 +1,40 @@
+function Room(domElem, lib) {
+	var players = {};
+	var logins = [];
+
+	return {
+		populate: populate,
+		enter: enter,
+		leave: leave
+	};
+
+	function Player(name) {
+		var player = {
+			dom: document.createElement('li'),
+			position: null
+		};
+    player.dom.textContent = name;
+		return player;
+	}
+
+  function populate(playersList) {
+    lib.clearElement(domElem);
+    for(var i = 0; i < playersList.length; i++) {
+			enter(playersList[i].login || "anon");
+    }
+  }
+
+  function enter(name) {
+		var player = Player(name);
+		players[name] = player;
+		player.position = lib.insert(name, logins);
+		beforePlayer = logins[player.position];
+		domElem.insertBefore(player.dom, beforePlayer && players[beforePlayer].dom);
+		logins.splice(player.position, 0, name);
+  }
+
+	function leave(name) {
+		domElem.removeChild(players[name].dom);
+		logins.splice(players[name].position, 1);
+	}
+}

www/skin.css

@@ -0,0 +1,19 @@
+#leave {
+  display: none;
+}
+
+#login.on #join {
+  display: none;
+}
+
+#login.on #leave {
+  display: inline;
+}
+
+#players {
+  min-height: 4em;
+  border: 1px solid #ccc;
+  list-style: none;
+  padding-left: 0;
+  cursor: pointer;
+}