First draft, basic session handling

This commit is contained in:
Sasha 2018-04-11 13:25:24 +02:00
commit fab330b71d
20 changed files with 687 additions and 0 deletions

1
.gitignore vendored Normal file
View file

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

5
ChangeLog.md Normal file
View file

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

30
LICENSE Normal file
View file

@ -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.

2
Setup.hs Normal file
View file

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

48
hanafudapi.cabal Normal file
View file

@ -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

6
src/Config.hs Normal file
View file

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

10
src/Data.hs Normal file
View file

@ -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

19
src/Game.hs Normal file
View file

@ -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

21
src/JSON.hs Normal file
View file

@ -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
}

72
src/Main.hs Normal file
View file

@ -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")

80
src/Message.hs Normal file
View file

@ -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

70
src/Player.hs Normal file
View file

@ -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}

72
src/Server.hs Normal file
View file

@ -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)

64
src/Session.hs Normal file
View file

@ -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})

42
www/connect.js Normal file
View file

@ -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"});
}
});

29
www/index.html Normal file
View file

@ -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>

27
www/lib.js Normal file
View file

@ -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));
}
}

30
www/login.js Normal file
View file

@ -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 = "";
}
}
}

40
www/room.js Normal file
View file

@ -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);
}
}

19
www/skin.css Normal file
View file

@ -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;
}