commit fab330b71dcdd610164c96c077e65b2f36316d7d Author: Sasha Date: Wed Apr 11 13:25:24 2018 +0200 First draft, basic session handling diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b232802 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/dist/* diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..055f770 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for hanafudapi + +## 0.1.0.0 -- 2018-03-17 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..6687295 --- /dev/null +++ b/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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hanafudapi.cabal b/hanafudapi.cabal new file mode 100644 index 0000000..ba5c552 --- /dev/null +++ b/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 diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..6117553 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,6 @@ +module Config ( + listenPort + ) where + +listenPort :: Int +listenPort = 3000 diff --git a/src/Data.hs b/src/Data.hs new file mode 100644 index 0000000..cb9a9d8 --- /dev/null +++ b/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 + diff --git a/src/Game.hs b/src/Game.hs new file mode 100644 index 0000000..84fc916 --- /dev/null +++ b/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 diff --git a/src/JSON.hs b/src/JSON.hs new file mode 100644 index 0000000..d4668ac --- /dev/null +++ b/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 + } diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..eabe1b3 --- /dev/null +++ b/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") diff --git a/src/Message.hs b/src/Message.hs new file mode 100644 index 0000000..f85edf5 --- /dev/null +++ b/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 diff --git a/src/Player.hs b/src/Player.hs new file mode 100644 index 0000000..e0f873a --- /dev/null +++ b/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} diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 index 0000000..4519922 --- /dev/null +++ b/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) diff --git a/src/Session.hs b/src/Session.hs new file mode 100644 index 0000000..d142da5 --- /dev/null +++ b/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}) + diff --git a/www/connect.js b/www/connect.js new file mode 100644 index 0000000..41a666e --- /dev/null +++ b/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"}); + } +}); diff --git a/www/index.html b/www/index.html new file mode 100644 index 0000000..c0edf0a --- /dev/null +++ b/www/index.html @@ -0,0 +1,29 @@ + + + + KoiKoi + + + + + + + +

Hanafuda

+
+

+ + +

+

+ +

+
+
+ + +
+

+ + diff --git a/www/lib.js b/www/lib.js new file mode 100644 index 0000000..a8ef19f --- /dev/null +++ b/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)); + } +} diff --git a/www/login.js b/www/login.js new file mode 100644 index 0000000..dd96960 --- /dev/null +++ b/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 = ""; + } + } +} diff --git a/www/room.js b/www/room.js new file mode 100644 index 0000000..269a788 --- /dev/null +++ b/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); + } +} diff --git a/www/skin.css b/www/skin.css new file mode 100644 index 0000000..04ba119 --- /dev/null +++ b/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; +}