diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Alexander Vieth + +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 Alexander Vieth 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/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,114 @@ +{-| +Module : +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import qualified Data.Map as M +import Data.AtLeast +import Data.TypeNat.Vect +import Data.Monoid +import Data.Hourglass +import System.Hourglass +import Rest.Api +import Rest.Driver.Wai +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Handler.WarpTLS +import Options.Applicative +import Diplomacy.Game +import Types.GameState +import Types.ServerOptions as Options +import Types.Credentials +import Types.Server +import Types.GameId +import Router +import qualified Resources.Advance as Advance + +main :: IO () +main = do + opts <- execParser (info Options.parser mempty) + let username = adminUsername opts + let password = adminPassword opts + let cert = certificateFile opts + let key = Options.keyFile opts + let port = Options.port opts + initialState <- serverState username password + tvar <- newTVarIO initialState + let app = waiApp tvar + let daemon = advanceDaemon tvar + async daemon + --x <- mkJsApi (ModuleName "diplomacy") True (mkVersion 1 0 0) (router) + --putStrLn x + putStrLn ("Starting secure server on port " ++ show port) + runTLS (tlsSettings cert key) (setPort port defaultSettings) app + putStrLn "Goodbye" + +waiApp :: TVar ServerState -> Application +waiApp tvar = + let runner :: forall a . Server a -> IO a + runner = runDiplomacyServer tvar + in apiToApplication runner api + +-- To be run in a separate thread; this IO will periodically check every game +-- and advance it if it's started and hasn't been advanced for longer than its +-- period. +-- +-- TODO this should get its own module. That would allow us to trim many +-- imports in this Main file. +advanceDaemon :: TVar ServerState -> IO () +advanceDaemon tvar = do + -- We check every second. + threadDelay oneSecond + advanceGamesIO tvar + advanceDaemon tvar + where + -- threadDelay uses microseconds. + oneSecond = 1000000 + advanceGamesIO :: TVar ServerState -> IO () + advanceGamesIO tvar = do + t <- timeCurrent + gameIds <- atomically $ do + state <- readTVar tvar + let (advancedGameIds, newState) = advanceState t state + writeTVar tvar newState + return advancedGameIds + return () + advanceState :: Elapsed -> ServerState -> ([GameId], ServerState) + advanceState t state = + let (gameIds, nextGames) = M.foldWithKey (advanceGameFold t) ([], M.empty) (games state) + in (gameIds, state { games = nextGames }) + advanceGameFold + :: Elapsed + -> GameId + -> (Password, GameState) + -> ([GameId], M.Map GameId (Password, GameState)) + -> ([GameId], M.Map GameId (Password, GameState)) + advanceGameFold t gameId (pwd, gameState) (ids, out) = case gameState of + GameStarted m (AtLeast (VCons (SomeGame game) VNil) rest) duration duration' elapsed paused -> + let Elapsed t' = t - elapsed + (observedDuration, _) = fromSeconds t' + thresholdDuration = case game of + TypicalGame _ _ _ _ _ -> duration + RetreatGame _ _ _ _ _ _ _ -> duration' + AdjustGame _ _ _ _ _ -> duration' + in if not paused && observedDuration > thresholdDuration + then let nextGame = Advance.advance (SomeGame game) + in (gameId : ids, M.insert gameId (pwd, GameStarted m (AtLeast (VCons nextGame VNil) ((SomeGame game) : rest)) duration duration' t False) out) + else (ids, M.insert gameId (pwd, GameStarted m (AtLeast (VCons (SomeGame game) VNil) rest) duration duration' elapsed paused) out) + _ -> (ids, M.insert gameId (pwd, gameState) out) + +api = [(mkVersion 1 0 0, Some1 router)] + + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +# diplomacy-server + +Play the board game +[Diplomacy](https://en.wikipedia.org/wiki/Diplomacy_%28game%29) over HTTP. +Players may participate via their own private devices, so long as they have +network capabilities and a good web browser. + +## Quick start + +Start by installing the program. + +```bash` +git clone git@github.com:avieth/diplomacy-server.git +cd diplomacy-server +cabal install +``` + +In order to get up and running you need a public/private key pair and +certificate, because the web +server uses secure HTTP. Here's how to create a key pair and self-sign a +certificate using OpenSSL. +Note that your browser will warn of an untrusted certificate when you connect +to the server. + +```bash +openssl req -x509 -newkey rsa:2048 -keyout server.key -out server.pem -days 365 -nodes +``` + +When running the server, the key and certificate file locations can be +specified using `-k` and `-c` respectively; the defaults are `./server.key` and +`./server.pem`. When running the server you must also give a username and +password for the administrator. These credentials allows you to create, start, +advance, pause, and destroy games. + +```bash +./Main -u -p +``` + +The default port is `4347`, but this can be changed using `--port`. With +the server running, navigate to `https://:4347/v1.0.0/diplomacy` to +begin playing via the simple but effective web client. The workflow is as +follows: + +1. Administartor creates a game, choosing a password for it. +2. Players join the game using the administartor's chosen password. +3. Adminstrator starts the game. +4. Players use their own devices (smartphones, laptops) to view game state and + issue orders. + +The game will advance automatically unless the adminstrator pauses the game. +In this case, the game will advance only when the adminstrator explicitly +advances it, at which point the automatic advance feature kicks in again. +This is useful for putting a game on indefinite hiatus. + +## The simple client + +The file `client.html` is a barebones, not-so-user-friendly interface for +players and administrators (game-masters, if you will). It *should* provide +all necessary functionality to play a complete match, and *should* work +properly on all smartphones and personal computers with up-to-date web browsers. + +To input typical and retreat phase orders using this client, one must type the +order object as it would be written in a pen-and-paper game; the map is not +interactive, but this would be a nice improvement. + +A better HTML/JavaScript client, or even native iOS and Android clients, +would be *very* nice to have. Ideally, we could use the definitions of the +[diplomacy](https://github.com/avieth/diplomacy) Haskell library to produce +these clients. This way, we don't need to reproduce the basic definitions like +those related to provinces and their adjacency, and we could also use order +validation definitions to give helpful feedback when the user attempts to input +a new order (highlighting valid move targets or support subjects, for instance). + +## A note on REST + +This program uses the rest package, but it doesn't give a RESTful API; the +server *is* stateful. This package was chosen because it was relatively +quick and easy. It ought to be swapped out for something which + +1. Does not claim to be RESTful. +2. Allows us to easily reuse handlers for HTTP and Email input. diff --git a/Resources/Advance.hs b/Resources/Advance.hs new file mode 100644 --- /dev/null +++ b/Resources/Advance.hs @@ -0,0 +1,152 @@ +{-| +Module : Resources.Advance +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} + +module Resources.Advance ( + + resource + , advance + + ) where + +import GHC.Generics +import Data.Typeable +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import Control.Monad.State.Class as SC +import qualified Data.Map as M +import Data.AtLeast +import Data.TypeNat.Vect +import Data.Aeson +import Data.JSON.Schema +import Rest +import Rest.Resource as R +import Diplomacy.Game +import Diplomacy.SupplyCentreDeficit +import Types.Server +import Types.GameId +import Types.Credentials +import Types.GameState + +resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void +resource = mkResourceId + { R.name = "advance" + , R.schema = singleton () $ unnamedSingle (const ()) + , R.update = Just update + } + where + + update :: Handler (ReaderT GameId Server) + update = secureHandler $ mkInputHandler (jsonO . jsonE . jsonI) $ doUpdate + + doUpdate :: AdvanceInput -> ExceptT (Reason AdvanceError) (ReaderT GameId Server) AdvanceOutput + doUpdate input = withAdminCredentials creds advanceGame + where + AdvanceInput creds = input + + advanceGame :: ExceptT (Reason AdvanceError) (ReaderT GameId Server) AdvanceOutput + advanceGame = do + gameId <- lift ask + modifyGameState gameId modifier + return GameAdvanced + + modifier :: GameState -> ExceptT (Reason AdvanceError) (ReaderT GameId Server) GameState + modifier gameState = case gameState of + GameNotStarted _ _ _ -> throwE (domainReason AdvanceGameNotStarted) + GameStarted m (AtLeast (VCons someGame VNil) rest) duration duration' elapsed _ -> do + state <- SC.get + let nextGame = advance someGame + return (GameStarted m (AtLeast (VCons nextGame VNil) (someGame : rest)) duration duration' (currentTime state) False) + +-- | Advance a game, resolving and then continuing, so that we also go from +-- Unresolved to Unresolved. Retreat and Adjust phases in which there is +-- nothing to do are skipped, but they are not forgotten! They're given +-- in the return value. +advance :: SomeGame -> SomeGame +advance (SomeGame game) = SomeGame (continue (resolve game)) +{- +advance (SomeGame game) = case game of + TypicalGame TypicalRoundOne Unresolved _ _ _ -> + let resolved = resolve game + continued = continue resolved + in case M.size (gameDislodged continued) of + -- Automatically skip retreat phases where nobody is + -- dislodged. + 0 -> advance (SomeGame continued) + _ -> AtLeast (VCons (SomeGame continued) VNil) [] + TypicalGame TypicalRoundTwo Unresolved _ _ _ -> + let resolved = resolve game + continued = continue resolved + in case M.size (gameDislodged continued) of + -- Automatically skip retreat phases where nobody is + -- dislodged. + 0 -> advance (SomeGame continued) + _ -> SomeGame continued + RetreatGame RetreatRoundOne Unresolved _ _ _ _ _ -> + let resolved = resolve game + continued = continue resolved + in SomeGame continued + RetreatGame RetreatRoundTwo Unresolved _ _ _ _ _ -> + let resolved = resolve game + continued = continue resolved + occupation = gameOccupation continued + control = gameControl continued + deficits = fmap (\greatPower -> supplyCentreDeficit greatPower occupation control) [minBound..maxBound] + in if all (== 0) deficits + -- Automatically skip adjust phases where nobody has a deficit, + -- positive or negative. + -- TODO must also check that, in case there's a negative + -- deficit, this great power actually has a place to build. + -- Really, we ought to use the order synthesizers to see whether + -- any player actually has a choice. That goes for typical + -- phase as well; it's rare, but it could happen, maybe? + -- No, that would cause infinite loop behaviour in advance. + then advance (SomeGame continued) + else SomeGame continued + AdjustGame _ Unresolved _ _ _ -> + let resolved = resolve game + continued = continue resolved + in SomeGame continued +-} + +data AdvanceError = AdvanceGameNotStarted + +instance ToResponseCode AdvanceError where + toResponseCode _ = 403 + +deriving instance Generic AdvanceError +deriving instance Typeable AdvanceError +instance FromJSON AdvanceError +instance ToJSON AdvanceError +instance JSONSchema AdvanceError where + schema = gSchema + +newtype AdvanceInput = AdvanceInput Credentials + +deriving instance Generic AdvanceInput +deriving instance Typeable AdvanceInput +instance FromJSON AdvanceInput +instance ToJSON AdvanceInput +instance JSONSchema AdvanceInput where + schema = gSchema + +data AdvanceOutput = GameAdvanced + +deriving instance Generic AdvanceOutput +deriving instance Typeable AdvanceOutput +instance FromJSON AdvanceOutput +instance ToJSON AdvanceOutput +instance JSONSchema AdvanceOutput where + schema = gSchema diff --git a/Resources/Client.hs b/Resources/Client.hs new file mode 100644 --- /dev/null +++ b/Resources/Client.hs @@ -0,0 +1,56 @@ +{-| +Module : Resources.Client +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RankNTypes #-} + +module Resources.Client ( + + resource + + ) where + +import Control.Monad.Trans.Class +import Control.Monad.Trans.State as S +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import qualified Data.Map as M +import Data.Hourglass +import Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Rest +import Rest.Resource as R +import Types.Server +import Types.GameId +import Types.Credentials +import Types.GameState +import Resources.Game.Create as Create +import Resources.Game.Remove as Remove + +resource :: Resource Server Server () Void Void +resource = (mkResource enter) + { R.name = "diplomacy" + , R.schema = Rest.singleton () (named []) + , R.get = Just get + } + where + + enter :: forall b . () -> Server b -> Server b + enter _ = id + + get :: Handler Server + get = secureHandler $ mkConstHandler (jsonE . fileO) $ doGet + + doGet :: ExceptT (Reason Void) Server (BL.ByteString, String, Bool) + doGet = do + state <- lift S.get + return $ (clientHtml state, "client.html", False) diff --git a/Resources/Game.hs b/Resources/Game.hs new file mode 100644 --- /dev/null +++ b/Resources/Game.hs @@ -0,0 +1,113 @@ +{-| +Module : Resources.Game +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Resources.Game ( + + resource + + ) where + +import Control.Monad.Trans.Class +import Control.Monad.Trans.State as S +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import qualified Data.Map as M +import Data.Hourglass +import Rest +import Rest.Resource as R +import Rest.Dictionary.Types +import Types.Server +import Types.GameId +import Types.Credentials +import Types.GameState +import Resources.Game.Create as Create +import Resources.Game.Remove as Remove +import Diplomacy.Game +import Diplomacy.Turn + +-- | The game resource will use a string identifier to pick out a game, and +-- give methods +-- GET : all info about the game state +-- GET : listing of the games +-- CREATE : make a new game +-- DELETE : destroy a game +-- TBD parameterize on the great power who's asking?! +-- Admin | Player GreatPower +-- Admin | Player String? Use player names rather than their power? +resource :: Resource Server (ReaderT GameId Server) GameId () Void +resource = mkResourceReader + { R.name = "game" + , R.schema = withListing () $ unnamedSingle GameId + --, R.schema = withListing () $ named [("id", singleBy GameId)] + -- We use update (PUT) where we really ought to use get (GET) because + -- there is a lot of resistance against including bodies in GET requests, + -- so much so that the W3C XMLHttpRequest NEVER includes a body in a + -- GET request. + , R.update = Just get + -- TODO TBD listing doesn't work; unsupported route. Why?!? + , R.list = const listing + , R.create = Just create + , R.remove = Just remove + } + where + + get :: Handler (ReaderT GameId Server) + get = secureHandler $ mkHandler (jsonO . jsonE . jsonI) handler + + handler :: Env h p Credentials -> ExceptT (Reason Void) (ReaderT GameId Server) (Maybe GameData) + handler env = + let credentials = input env + in lift ask >>= \gameId -> doGet credentials gameId + + doGet + :: Credentials + -> GameId + -> ExceptT (Reason Void) (ReaderT GameId Server) (Maybe GameData) + doGet credentials gameId = withUserCredentialsForGame credentials gameId f + where + f gameStateView = return $ do + metadata <- gameStateViewMetadata gameStateView + let turn = metadataTurn metadata + let round = metadataRound metadata + gameStateViewData turn round gameStateView + + listing :: ListHandler Server + listing = mkListing (stringO) $ \_ -> lift doListing + doListing :: Server [String] + doListing = listGames >>= return . fmap show + + create :: Handler Server + create = secureHandler $ mkInputHandler (jsonO . jsonE . jsonI) $ doCreate + doCreate :: CreateGameInput -> ExceptT (Reason Void) Server CreateGameOutput + doCreate input = withAdminCredentials creds (lift (createGame gameId password duration duration')) + where + creds = Create.credentials input + gameId = Create.gameId input + password = Create.gamePassword input + duration = maybe (makeDuration 15) makeDuration (Create.gameDuration input) + duration' = maybe (makeDuration 5) makeDuration (Create.gameSecondDuration input) + makeDuration x = Duration (fromIntegral 0) (fromIntegral x) (fromIntegral 0) (fromIntegral 0) + + remove :: Handler (ReaderT GameId Server) + remove = secureHandler $ mkIdHandler (jsonO . jsonE . jsonI) $ \credentials gameId -> doRemove (RemoveGameInput gameId credentials) + doRemove :: RemoveGameInput -> ExceptT (Reason Void) (ReaderT GameId Server) RemoveGameOutput + doRemove input = withAdminCredentials creds (removeGame gameId) + where + creds = Remove.credentials input + gameId = Remove.gameId input + +listGames :: Server [GameId] +listGames = do + state <- S.get + return $ M.keys (games state) diff --git a/Resources/Game/Create.hs b/Resources/Game/Create.hs new file mode 100644 --- /dev/null +++ b/Resources/Game/Create.hs @@ -0,0 +1,76 @@ +{-| +Module : Resources.Game.Create +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Resources.Game.Create ( + + CreateGameInput(..) + , CreateGameOutput(..) + , createGame + + ) where + +import GHC.Generics +import Control.Monad.Trans.State as S +import Data.Typeable +import qualified Data.Map as M +import Data.Aeson +import Data.JSON.Schema +import Data.Hourglass +import Types.GameId +import Types.Server +import Types.Credentials +import Types.GameState + +data CreateGameInput = CreateGameInput { + gameId :: GameId + , gamePassword :: Password + -- ^ A password for the game, to share with the people who you wish to + -- allow to join. + , credentials :: Credentials + -- ^ Administrator credentials + , gameDuration :: Maybe Int + -- ^ Duration of typical phases. + , gameSecondDuration :: Maybe Int + -- ^ Duration of adjust and retreat phases. + } + +deriving instance Generic CreateGameInput +deriving instance Typeable CreateGameInput +instance FromJSON CreateGameInput +instance ToJSON CreateGameInput +instance JSONSchema CreateGameInput where + schema = gSchema + +data CreateGameOutput where + GameCreated :: CreateGameOutput + NameAlreadyTaken :: CreateGameOutput + +deriving instance Generic CreateGameOutput +deriving instance Typeable CreateGameOutput +instance FromJSON CreateGameOutput +instance ToJSON CreateGameOutput +instance JSONSchema CreateGameOutput where + schema = gSchema + +createGame :: GameId -> Password -> Duration -> Duration -> Server CreateGameOutput +createGame gameId password duration duration' = do + state <- S.get + case M.member gameId (games state) of + True -> return $ NameAlreadyTaken + False -> do + let gameState = GameNotStarted M.empty duration duration' + let nextState = state { games = M.insert gameId (password, gameState) (games state) } + S.put nextState + return GameCreated diff --git a/Resources/Game/Remove.hs b/Resources/Game/Remove.hs new file mode 100644 --- /dev/null +++ b/Resources/Game/Remove.hs @@ -0,0 +1,70 @@ +{-| +Module : Resources.Game.Remove +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} + +module Resources.Game.Remove ( + + RemoveGameInput(..) + , RemoveGameOutput(..) + , removeGame + + ) where + +import GHC.Generics +import Control.Monad.State.Class as SC +import Control.Monad.Trans.Except +import Data.Typeable +import qualified Data.Map as M +import Data.Aeson +import Data.JSON.Schema +import Rest +import Types.GameId +import Types.Server +import Types.Credentials + +data RemoveGameInput = RemoveGameInput { + gameId :: GameId + , credentials :: Credentials + } + +deriving instance Generic RemoveGameInput +deriving instance Typeable RemoveGameInput +instance FromJSON RemoveGameInput +instance ToJSON RemoveGameInput +instance JSONSchema RemoveGameInput where + schema = gSchema + +data RemoveGameOutput where + GameRemoved :: RemoveGameOutput + +deriving instance Generic RemoveGameOutput +deriving instance Typeable RemoveGameOutput +instance FromJSON RemoveGameOutput +instance ToJSON RemoveGameOutput +instance JSONSchema RemoveGameOutput where + schema = gSchema + +removeGame + :: MonadState ServerState m + => GameId + -> ExceptT (Reason Void) m RemoveGameOutput +removeGame gameId = do + state <- SC.get + case M.member gameId (games state) of + False -> throwE NotFound + True -> do + let nextState = state { games = M.delete gameId (games state) } + SC.put nextState + return GameRemoved diff --git a/Resources/Join.hs b/Resources/Join.hs new file mode 100644 --- /dev/null +++ b/Resources/Join.hs @@ -0,0 +1,123 @@ +{-| +Module : Resources.Join +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Resources.Join ( + + resource + + ) where + +import GHC.Generics +import Control.Monad.State.Class as SC +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import Data.Typeable +import qualified Data.Map as M +import Data.Functor.Constant as FC +import Data.Aeson +import Data.JSON.Schema +import Rest +import Rest.Resource as R +import Types.GameId +import Types.UserData hiding (password) +import Types.Credentials hiding (password) +import qualified Types.Credentials as Credentials +import Types.GameState +import Types.Server + +-- | Use this resource to join a game. +-- +-- PUT : ask to join the game, passing the game password and your +-- credentials in the request body. +-- +resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void +resource = mkResourceId + { R.name = "join" + , R.schema = singleton () $ unnamedSingle (const ()) + , R.update = Just update + } + where + update :: Handler (ReaderT GameId Server) + update = secureHandler $ mkInputHandler (jsonO . jsonE . jsonI) $ doUpdate + doUpdate :: JoinGameInput -> ExceptT (Reason JoinGameError) (ReaderT GameId Server) JoinGameOutput + doUpdate input = do + gameId <- lift ask + state <- SC.get + case M.lookup gameId (games state) of + Nothing -> throwE NotFound + Just (pwd', gameState) -> case pwd' == pwd of + False -> throwE NotAllowed + True -> case registerUser creds gameState of + Left e -> throwE (domainReason e) + Right nextGameState -> do + SC.put (state { games = M.alter (const (Just (pwd', nextGameState))) gameId (games state) }) + return Joined + where + creds = credentials input + pwd = password input + +registerUser :: Credentials -> GameState -> Either JoinGameError GameState +registerUser credentials gameState = case gameState of + GameNotStarted map duration duration' -> case M.lookup uname map of + Nothing -> + if M.size map == 7 + then Left GameFull + else Right (GameNotStarted (M.insert uname userData map) duration duration') + where + userData = UserData pwd (FC.Constant ()) + Just _ -> Left UsernameTaken + GameStarted _ _ _ _ _ _ -> Left GameAlreadyStarted + where + uname = Credentials.username credentials + pwd = Credentials.password credentials + +data JoinGameInput = JoinGameInput { + password :: Password + -- ^ Password for the game. + , credentials :: Credentials + -- ^ Credentials of the user who wishes to join. + } + +deriving instance Generic JoinGameInput +deriving instance Typeable JoinGameInput +instance FromJSON JoinGameInput +instance ToJSON JoinGameInput +instance JSONSchema JoinGameInput where + schema = gSchema + +data JoinGameOutput = Joined + +deriving instance Generic JoinGameOutput +deriving instance Typeable JoinGameOutput +instance FromJSON JoinGameOutput +instance ToJSON JoinGameOutput +instance JSONSchema JoinGameOutput where + schema = gSchema + +data JoinGameError + = UsernameTaken + | GameAlreadyStarted + | GameFull + deriving (Show, Generic, Typeable) + +instance JSONSchema JoinGameError where + schema = gSchema + +instance ToJSON JoinGameError + +instance ToResponseCode JoinGameError where + toResponseCode UsernameTaken = 403 + toResponseCode GameAlreadyStarted = 403 + toResponseCode GameFull = 403 diff --git a/Resources/Metadata.hs b/Resources/Metadata.hs new file mode 100644 --- /dev/null +++ b/Resources/Metadata.hs @@ -0,0 +1,48 @@ +{-| +Module : Resources.Metadata +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Resources.Metadata ( + + resource + + ) where + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import Rest +import Rest.Resource as R +import Types.Server +import Types.GameState +import Types.GameId +import Types.Credentials + +resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void +resource = mkResourceId + { R.name = "metadata" + , R.schema = singleton () $ unnamedSingle (const ()) + , R.update = Just get + } + where + get :: Handler (ReaderT GameId Server) + get = secureHandler $ mkHandler (jsonO . jsonE . jsonI) handler + + handler :: Env h p Credentials -> ExceptT (Reason Void) (ReaderT GameId Server) (Maybe GameMetadata) + handler env = + let credentials = input env + in lift ask >>= \gameId -> doGet credentials gameId + + doGet + :: Credentials + -> GameId + -> ExceptT (Reason Void) (ReaderT GameId Server) (Maybe GameMetadata) + doGet credentials gameId = withUserCredentialsForGame credentials gameId (return . gameStateViewMetadata) diff --git a/Resources/Order.hs b/Resources/Order.hs new file mode 100644 --- /dev/null +++ b/Resources/Order.hs @@ -0,0 +1,200 @@ +{-| +Module : Resources.Order +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Resources.Order ( + + resource + + ) where + +import GHC.Generics +import Control.Applicative +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import Data.Typeable +import Data.AtLeast +import Data.TypeNat.Vect +import Data.Aeson +import Data.JSON.Schema +import qualified Data.Map as M +import qualified Data.Set as S +import Rest +import Rest.Resource as R +import qualified Diplomacy.Phase as Phase +import Diplomacy.Game as Game +import Diplomacy.Aligned +import qualified Diplomacy.GreatPower as DGP +import Diplomacy.Zone +import Diplomacy.Unit +import Diplomacy.Subject +import qualified Diplomacy.OrderObject as DOO +import qualified Diplomacy.Order as DO +import Types.Order +import Types.Credentials +import Types.GreatPower +import Types.GameId +import Types.Server +import Types.GameState + +-- | The order resource will give methods +-- PUT : ask to issue an order +resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void +resource = mkResourceId + { R.name = "order" + , R.schema = singleton () $ unnamedSingle (const ()) + , R.update = Just update + } + where + + update :: Handler (ReaderT GameId Server) + update = secureHandler $ mkInputHandler (jsonO . jsonE . jsonI) $ doUpdate + + doUpdate :: IssueOrdersInput -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) IssueOrdersOutput + doUpdate input = do + gameId <- lift ask + withUserCredentialsForGame creds gameId (issueOrders gameId) + where + + creds = credentials input + issuedOrders = orders input + + issueOrders + :: GameId + -> GameStateView + -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) IssueOrdersOutput + issueOrders gameId gameStateView = do + checkAuthorization gameStateView + (output, nextGame) <- issueOrders' gameStateView + modifyGameState gameId (return . modifier nextGame) + return output + + modifier :: SomeGame -> GameState -> GameState + modifier (SomeGame x) state = case state of + GameNotStarted y duration duration' -> GameNotStarted y duration duration' -- Impossible; should not have this case... + GameStarted m (AtLeast _ rest) duration duration' elapsed paused -> + GameStarted m (AtLeast (VCons (SomeGame x) VNil) rest) duration duration' elapsed paused + + checkAuthorization :: GameStateView -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) () + checkAuthorization gameStateView = case gameStateView of + GameNotStartedView -> return () + GameStartedView greatPowers _ _ _ _ _ -> + if issuedOrdersGreatPowers issuedOrders `S.isSubsetOf` (S.map GreatPower greatPowers) + then return () + else throwE NotAllowed + + issueOrders' :: GameStateView -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) (IssueOrdersOutput, SomeGame) + issueOrders' gameStateView = case gameStateView of + GameNotStartedView -> throwE (domainReason IssueOrdersGameNotStarted) + GameStartedView _ (AtLeast (VCons (SomeGame someGame) VNil) _) _ _ _ _ -> case (someGame, issuedOrders) of + (TypicalGame TypicalRoundOne Unresolved x y z, Typical os) -> issueOrders'' os someGame + (RetreatGame RetreatRoundOne Unresolved _ _ _ _ _, Retreat os) -> issueOrders'' os someGame + (TypicalGame TypicalRoundTwo Unresolved x y z, Typical os) -> issueOrders'' os someGame + (RetreatGame RetreatRoundTwo Unresolved _ _ _ _ _, Retreat os) -> issueOrders'' os someGame + (AdjustGame AdjustRound Unresolved _ _ _, Adjust os) -> issueOrders'' os someGame + _ -> throwE (domainReason (IssueOrdersWrongPhase)) + + issueOrders'' + :: forall round . + [(GreatPower, SomeOrder (RoundPhase round))] + -> Game round RoundUnresolved + -> ExceptT (Reason IssueOrdersError) (ReaderT GameId Server) (IssueOrdersOutput, SomeGame) + issueOrders'' orders game = return $ case game of + TypicalGame TypicalRoundOne _ _ _ _ -> (IssueOrdersOutputTypical, SomeGame . snd $ Game.issueOrders ordersMap game) + TypicalGame TypicalRoundTwo _ _ _ _ -> (IssueOrdersOutputTypical, SomeGame . snd $ Game.issueOrders ordersMap game) + RetreatGame RetreatRoundOne _ _ _ _ _ _ -> (IssueOrdersOutputRetreat, SomeGame . snd $ Game.issueOrders ordersMap game) + RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> (IssueOrdersOutputRetreat, SomeGame . snd $ Game.issueOrders ordersMap game) + AdjustGame AdjustRound _ _ _ _ -> (IssueOrdersOutputAdjust, SomeGame . snd $ Game.issueOrders ordersMap game) + where + ordersMap :: M.Map Zone (Aligned Unit, DOO.SomeOrderObject (RoundPhase round)) + ordersMap = foldr insertOrder M.empty orders + insertOrder + :: (GreatPower, SomeOrder (RoundPhase round)) + -> M.Map Zone (Aligned Unit, DOO.SomeOrderObject (RoundPhase round)) + -> M.Map Zone (Aligned Unit, DOO.SomeOrderObject (RoundPhase round)) + insertOrder (greatPower, order) = case order of + SomeOrder (DO.SomeOrder (DO.Order (subject, object))) -> + M.insert (Zone (subjectProvinceTarget subject)) (align (subjectUnit subject) (outGreatPower greatPower), DOO.SomeOrderObject object) + +-- Order inputs look something like this: +-- +-- [["England", "F Spa NC - Mid"], ["France", "A Mar - Spa"]] +-- +-- It's important that we accept orders for multiple great powers, since one +-- player may control more than one great power. +data IssuedOrders where + Typical :: [(GreatPower, SomeOrder Phase.Typical)] -> IssuedOrders + Retreat :: [(GreatPower, SomeOrder Phase.Retreat)] -> IssuedOrders + Adjust :: [(GreatPower, SomeOrder Phase.Adjust)] -> IssuedOrders + +deriving instance Generic IssuedOrders +deriving instance Typeable IssuedOrders +instance FromJSON IssuedOrders +instance ToJSON IssuedOrders +instance JSONSchema IssuedOrders where + schema = gSchema + +-- | The set of all GreatPowers for which at least one order is relevant. +issuedOrdersGreatPowers :: IssuedOrders -> S.Set GreatPower +issuedOrdersGreatPowers orders = case orders of + Typical os -> foldr (S.insert . fst) S.empty os + Retreat os -> foldr (S.insert . fst) S.empty os + Adjust os -> foldr (S.insert . fst) S.empty os + +data IssueOrdersInput = IssueOrdersInput { + credentials :: Credentials + , orders :: IssuedOrders + } + +deriving instance Generic IssueOrdersInput +deriving instance Typeable IssueOrdersInput +instance FromJSON IssueOrdersInput +instance ToJSON IssueOrdersInput +instance JSONSchema IssueOrdersInput where + schema = gSchema + +-- | TODO throw in the sets of validity criterion, indexed by the relevant +-- order: [["France", "A Mar - Spa SC"], ["MoveUnitCanOccupy"]] +-- And of course, for the adjust phase, take the other set indexed by the +-- relevant great power. +data IssueOrdersOutput where + IssueOrdersOutputTypical :: IssueOrdersOutput + IssueOrdersOutputRetreat :: IssueOrdersOutput + IssueOrdersOutputAdjust :: IssueOrdersOutput + +deriving instance Generic IssueOrdersOutput +deriving instance Typeable IssueOrdersOutput +instance FromJSON IssueOrdersOutput +instance ToJSON IssueOrdersOutput +instance JSONSchema IssueOrdersOutput where + schema = gSchema + +-- | We do not consider invalid orders to be an error. If invalid orders +-- are given, the response will reflect it. +data IssueOrdersError + = IssueOrdersGameNotStarted + | IssueOrdersWrongPhase + +instance ToResponseCode IssueOrdersError where + toResponseCode _ = 403 + +deriving instance Generic IssueOrdersError +deriving instance Typeable IssueOrdersError +instance FromJSON IssueOrdersError +instance ToJSON IssueOrdersError +instance JSONSchema IssueOrdersError where + schema = gSchema diff --git a/Resources/Pause.hs b/Resources/Pause.hs new file mode 100644 --- /dev/null +++ b/Resources/Pause.hs @@ -0,0 +1,97 @@ +{-| +Module : Resources.Paused +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} + +module Resources.Pause ( + + resource + + ) where + +import GHC.Generics +import Data.Typeable +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import Control.Monad.State.Class as SC +import qualified Data.Map as M +import Data.AtLeast +import Data.TypeNat.Vect +import Data.Aeson +import Data.JSON.Schema +import Rest +import Rest.Resource as R +import Diplomacy.Game +import Types.Server +import Types.GameId +import Types.Credentials +import Types.GameState + +resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void +resource = mkResourceId + { R.name = "pause" + , R.schema = singleton () $ unnamedSingle (const ()) + , R.update = Just update + } + where + + update :: Handler (ReaderT GameId Server) + update = secureHandler $ mkInputHandler (jsonO . jsonE . jsonI) $ doUpdate + + doUpdate :: PauseInput -> ExceptT (Reason PauseError) (ReaderT GameId Server) PauseOutput + doUpdate input = withAdminCredentials creds pauseGame + where + PauseInput creds = input + + pauseGame :: ExceptT (Reason PauseError) (ReaderT GameId Server) PauseOutput + pauseGame = do + gameId <- lift ask + modifyGameState gameId modifier + return GamePaused + + modifier :: GameState -> ExceptT (Reason PauseError) (ReaderT GameId Server) GameState + modifier gameState = case gameState of + GameNotStarted _ _ _ -> throwE (domainReason PauseGameNotStarted) + GameStarted m games duration duration' elapsed _ -> + return (GameStarted m games duration duration' elapsed True) + +data PauseError = PauseGameNotStarted + +instance ToResponseCode PauseError where + toResponseCode _ = 403 + +deriving instance Generic PauseError +deriving instance Typeable PauseError +instance FromJSON PauseError +instance ToJSON PauseError +instance JSONSchema PauseError where + schema = gSchema + +newtype PauseInput = PauseInput Credentials + +deriving instance Generic PauseInput +deriving instance Typeable PauseInput +instance FromJSON PauseInput +instance ToJSON PauseInput +instance JSONSchema PauseInput where + schema = gSchema + +data PauseOutput = GamePaused + +deriving instance Generic PauseOutput +deriving instance Typeable PauseOutput +instance FromJSON PauseOutput +instance ToJSON PauseOutput +instance JSONSchema PauseOutput where + schema = gSchema diff --git a/Resources/Resolution.hs b/Resources/Resolution.hs new file mode 100644 --- /dev/null +++ b/Resources/Resolution.hs @@ -0,0 +1,98 @@ +{-| +Module : Resources.Resolution +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Resources.Resolution ( + + resource + + ) where + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import Rest +import Rest.Resource as R +import Rest.Dictionary.Types +import Types.Server +import Types.GameState +import Types.GameId +import Types.Credentials +import Diplomacy.Game +import Diplomacy.Turn + +resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void +resource = mkResourceId + { R.name = "resolution" + , R.schema = singleton () $ unnamedSingle (const ()) + , R.update = Just get + } + where + get :: Handler (ReaderT GameId Server) + get = secureHandler $ mkHandler (addPar roundParam . mkPar turnParam . jsonO . jsonE . jsonI) handler + + turnParam :: Param (Maybe Turn) + turnParam = Param ["turn"] $ \xs -> case xs of + (Just x : _) -> case reads x :: [(Int, String)] of + [(i, [])] -> case turnFromInt i of + Just t -> Right (Just t) + _ -> Left (ParseError "Could not parse turn") + _ -> Left (ParseError "Could not parse turn") + [Nothing] -> Right Nothing + _ -> Left (ParseError "Could not parse turn") + + roundParam :: Param (Maybe Round) + roundParam = Param ["round"] $ \xs -> case xs of + (Just x : _) -> case reads x :: [(Int, String)] of + [(i, [])] -> let min = minBound :: Round + max = maxBound :: Round + in if i >= fromEnum min && i <= fromEnum max + then Right (Just (toEnum i)) + else Left (ParseError "Could not parse round") + _ -> Left (ParseError "Could not parse round") + [Nothing] -> Right Nothing + _ -> Left (ParseError "Could not parse round") + + + handler :: Env h (Maybe Round, Maybe Turn) Credentials -> ExceptT (Reason Void) (ReaderT GameId Server) (Maybe GameResolution) + handler env = + let credentials = input env + (maybeRound, maybeTurn) = param env + in lift ask >>= \gameId -> doGet credentials gameId maybeTurn maybeRound + + doGet + :: Credentials + -> GameId + -> Maybe Turn + -> Maybe Round + -> ExceptT (Reason Void) (ReaderT GameId Server) (Maybe GameResolution) + doGet credentials gameId maybeTurn maybeRound = withUserCredentialsForGame credentials gameId f + where + f gameStateView = return $ do + metadata <- gameStateViewMetadata gameStateView + let turn' = maybe (metadataTurn metadata) id maybeTurn + -- Prevent giving the resolution of the latest (currently ongoing) + -- round! This would allow any player to see the orders of other + -- players. + let (turn, round) = case maybeRound of + Just x -> (turn', x) + Nothing -> if metadataRound metadata /= RoundOne + then (turn', prevRound (metadataRound metadata)) + else case prevTurn turn' of + -- In this case we're at turn 0 round 0; we + -- give the current turn and round and the + -- upcoming guard will fail. + Nothing -> (turn', metadataRound metadata) + Just t -> (t, prevRound (metadataRound metadata)) + guard (turn <= metadataTurn metadata) + guard (turn < metadataTurn metadata || round < metadataRound metadata) + gameStateViewResolution turn round gameStateView diff --git a/Resources/Start.hs b/Resources/Start.hs new file mode 100644 --- /dev/null +++ b/Resources/Start.hs @@ -0,0 +1,147 @@ +{-| +Module : Resources.Start +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} + +module Resources.Start ( + + resource + + ) where + +import GHC.Generics +import Control.Monad.Trans.Class +import Control.Monad.State.Class as SC +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import Data.Typeable +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Stream as Stream +import Data.AtLeast +import Data.TypeNat.Vect +import Data.Aeson +import Data.JSON.Schema +import Data.Functor.Identity +import Data.Functor.Constant +import Data.List (sortBy, (\\)) +import Data.Hourglass +import Rest +import Rest.Resource as R +import Diplomacy.GreatPower +import Diplomacy.Game +import Types.Server +import Types.GameId +import Types.GameState +import Types.UserData as UD +import Types.Credentials as Credentials + +-- | Use this resource to start a game. +-- +-- PUT : ask to start the game, passing the administrator credentials +-- in the request body. +-- +resource :: Resource (ReaderT GameId Server) (ReaderT GameId Server) () Void Void +resource = mkResourceId + { R.name = "start" + , R.schema = singleton () $ unnamedSingle (const ()) + , R.update = Just update + } + where + + update :: Handler (ReaderT GameId Server) + update = secureHandler $ mkInputHandler (jsonO . jsonE . jsonI) $ doUpdate + + doUpdate :: StartGameInput -> ExceptT (Reason StartGameError) (ReaderT GameId Server) StartGameOutput + doUpdate input = withAdminCredentials creds startGame + where + + StartGameInput creds = input + + startGame :: ExceptT (Reason StartGameError) (ReaderT GameId Server) StartGameOutput + startGame = do + state <- SC.get + gameId <- lift ask + let ds = randomDoubles state + let t = currentTime state + case M.lookup gameId (games state) of + Nothing -> throwE NotFound + Just (password, gameState) -> do + case startGameState t ds gameState of + Left e -> throwE (domainReason e) + Right gs -> do + SC.put (state { games = M.alter (const (Just (password, gs))) gameId (games state) }) + return Started + +-- | We assume the GameState has at most 7 registered users. +-- This is always true if the GameState is modified by registerUser only. +-- TODO should enforce this at the type level, but it's not so fragile so +-- whatever. +startGameState :: Elapsed -> Stream.Stream Double -> GameState -> Either StartGameError GameState +startGameState t randomDoubles game = case game of + GameNotStarted map duration duration' -> + if notEnoughPlayers + then Left NotEnoughPlayers + else if tooManyPlayers + then Left TooManyPlayers + else Right (GameStarted map' (AtLeast (VCons (SomeGame newGame) VNil) []) duration duration' t False) + where + registered :: [(Username, Password)] + registered = fmap (\(x, y) -> (x, UD.password y)) (M.toList map) + registeredRandomOrder :: [(Username, Password)] + registeredRandomOrder = fmap fst (sortBy (\(_, x) (_, y) -> x `compare` y) (Prelude.zip registered (Stream.toList randomDoubles))) + controlUnits :: [S.Set GreatPower] + controlUnits = case length registered of + 7 -> fmap S.singleton [minBound..maxBound] + 6 -> fmap S.singleton ([minBound..maxBound] \\ [Italy]) + 5 -> fmap S.singleton ([minBound..maxBound] \\ [Germany, Italy]) + 4 -> [S.singleton England, S.fromList [Austria, France], S.fromList [Germany, Turkey], S.fromList [Italy, Russia]] + 3 -> [S.fromList [England, Germany, Austria], S.fromList [Russia, Italy], S.fromList [France, Turkey]] + _ -> [] + notEnoughPlayers = length registered < 3 + tooManyPlayers = length registered > 7 + -- We randomly assign each player to a control unit. + assignments :: [((Username, Password), S.Set GreatPower)] + assignments = Prelude.zip registeredRandomOrder controlUnits + makeUserData :: ((Username, Password), S.Set GreatPower) -> (Username, UserData S.Set) + makeUserData ((u, p), s) = (u, UserData p s) + map' = M.fromList (fmap makeUserData assignments) + GameStarted _ _ _ _ _ _ -> Left GameAlreadyStarted + +newtype StartGameInput = StartGameInput Credentials + +deriving instance Generic StartGameInput +deriving instance Typeable StartGameInput +instance FromJSON StartGameInput +instance ToJSON StartGameInput +instance JSONSchema StartGameInput where + schema = gSchema + +data StartGameOutput = Started + +deriving instance Generic StartGameOutput +deriving instance Typeable StartGameOutput +instance FromJSON StartGameOutput +instance ToJSON StartGameOutput +instance JSONSchema StartGameOutput where + schema = gSchema + +data StartGameError = GameAlreadyStarted | NotEnoughPlayers | TooManyPlayers + +deriving instance Generic StartGameError +deriving instance Typeable StartGameError +instance ToJSON StartGameError +instance JSONSchema StartGameError where + schema = gSchema + +instance ToResponseCode StartGameError where + toResponseCode _ = 403 diff --git a/Router.hs b/Router.hs new file mode 100644 --- /dev/null +++ b/Router.hs @@ -0,0 +1,79 @@ +{-| +Module : +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Router ( + + router + + ) where + +import Control.Monad.Trans.Reader +import Rest +import Rest.Api +import Rest.Resource as R +import Resources.Game as Game +import Resources.Join as Join +import Resources.Start as Start +import Resources.Order as Order +import Resources.Advance as Advance +import Resources.Pause as Pause +import Resources.Metadata as Metadata +import Resources.Resolution as Resolution +import Resources.Client as Client +import Types.GameId +import Types.Server + +router :: Router Server Server +router = root -/ client --/ game ---/ gameJoin + ---/ gameStart + ---/ gameOrder + ---/ gameAdvance + ---/ gamePause + ---/ gameMetadata + ---/ gameResolution + --/ admin + +game :: Router (Server) (ReaderT GameId Server) +game = route Game.resource + +gameJoin :: Router (ReaderT GameId Server) (ReaderT GameId Server) +gameJoin = route Join.resource + +gameStart :: Router (ReaderT GameId Server) (ReaderT GameId Server) +gameStart = route Start.resource + +gameOrder :: Router (ReaderT GameId Server) (ReaderT GameId Server) +gameOrder = route Order.resource + +gameAdvance :: Router (ReaderT GameId Server) (ReaderT GameId Server) +gameAdvance = route Advance.resource + +gamePause :: Router (ReaderT GameId Server) (ReaderT GameId Server) +gamePause = route Pause.resource + +gameMetadata :: Router (ReaderT GameId Server) (ReaderT GameId Server) +gameMetadata = route Metadata.resource + +gameResolution :: Router (ReaderT GameId Server) (ReaderT GameId Server) +gameResolution = route Resolution.resource + +client :: Router Server Server +client = route Client.resource + +admin :: Router (Server) (ReaderT GameId Server) +admin = route adminResource + +adminResource :: Resource Server (ReaderT GameId Server) GameId Void Void +adminResource = mkResourceReader + { R.name = "admin" + , R.schema = noListing $ unnamedSingle GameId + } diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Types/Credentials.hs b/Types/Credentials.hs new file mode 100644 --- /dev/null +++ b/Types/Credentials.hs @@ -0,0 +1,41 @@ +{-| +Module : Types.Credentials +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} + +module Types.Credentials ( + + Username + , Password + , Credentials(..) + + ) where + +import GHC.Generics +import Data.Typeable +import Data.Aeson +import Data.JSON.Schema + +type Username = String +type Password = String + +data Credentials = Credentials { + username :: Username + , password :: Password + } + deriving (Eq, Generic, Typeable) + +instance FromJSON Credentials +instance ToJSON Credentials +instance JSONSchema Credentials where + schema = gSchema diff --git a/Types/GameId.hs b/Types/GameId.hs new file mode 100644 --- /dev/null +++ b/Types/GameId.hs @@ -0,0 +1,31 @@ +{-| +Module : Types.GameId +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Types.GameId ( + + GameId(..) + + ) where + +import GHC.Generics +import Data.Typeable +import Data.Aeson +import Data.JSON.Schema + +newtype GameId = GameId String + deriving (Eq, Ord, Show, Generic) + +instance FromJSON GameId +instance ToJSON GameId +instance JSONSchema GameId where + schema = gSchema diff --git a/Types/GameState.hs b/Types/GameState.hs new file mode 100644 --- /dev/null +++ b/Types/GameState.hs @@ -0,0 +1,389 @@ +{-| +Module : Types.GameState +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Types.GameState ( + + SomeGame(..) + , GameState(..) + , GameStateView(..) + , GameMetadata(..) + , GameData(..) + , GameResolution(..) + + , gameStateMatchCredentials + , gameStateViewMetadata + , gameStateViewData + , gameStateViewResolution + + ) where + +import GHC.Generics +import Control.DeepSeq +import Control.Monad +import Control.Applicative +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T +import Data.AtLeast +import Data.TypeNat.Nat +import Data.Functor.Identity +import Data.Functor.Constant +import Data.Hourglass +import Data.Aeson +import Data.JSON.Schema as Schema +import Diplomacy.Game +import Diplomacy.Turn +import Diplomacy.Province +import Diplomacy.Zone +import Diplomacy.Aligned +import Diplomacy.Phase +import qualified Diplomacy.Order as DO +import qualified Diplomacy.OrderObject as DOO +import Diplomacy.OrderResolution +import qualified Diplomacy.Unit as DU +import qualified Diplomacy.GreatPower as DGP +import Diplomacy.Control +import Diplomacy.Occupation +import Types.Credentials as Cred +import Types.UserData as UD +import Types.Credentials (Username) +import Types.GreatPower +import Types.Unit +import Types.Order + +data SomeGame where + SomeGame :: Game round RoundUnresolved -> SomeGame + +data GameState where + + GameNotStarted + :: M.Map Username (UserData (Constant ())) + -> Duration + -> Duration + -> GameState + + GameStarted + :: M.Map Username (UserData S.Set) + -- ^ we use Set rather than Identity, because one player can control + -- more than one great power! + -> AtLeast One SomeGame + -- ^ All (unresolved) game states seen so far. First entry is the + -- latest, and other entires retain the orders which were present + -- when the game was advanced. + -> Duration + -- ^ Period of this game; after this duration, the game advances to the + -- next round if it's in typical phase. + -> Duration + -- ^ Second period of this game; after this duration, the game advances + -- to the next round if it's in adjust or retreat phase. + -> Elapsed + -- ^ Unix epoch time when this game was last advanced or when it was + -- started. + -> Bool + -- ^ True iff the game is paused, meaning it should not advance + -- automatically after a set amount of time. + -> GameState + +deriving instance Generic GameState +instance NFData GameState + +-- | The game state viewed as a certain player, who controls a set of +-- GreatPowers. +data GameStateView where + GameNotStartedView :: GameStateView + GameStartedView + :: S.Set DGP.GreatPower + -> AtLeast One SomeGame + -> Duration + -> Duration + -> Elapsed + -> Bool + -> GameStateView + +gameStateViewMetadata :: GameStateView -> Maybe GameMetadata +gameStateViewMetadata view = case view of + GameNotStartedView -> Nothing + GameStartedView greatPowers games duration secondDuration elapsed paused -> Just $ GameMetadata { + metadataGreatPowers = S.map GreatPower greatPowers + , metadataTurn = turn + , metadataRound = round + , metadataDuration = duration + , metadataSecondDuration = secondDuration + , metadataElapsed = elapsed + , metadataPaused = paused + } + where + game = Data.AtLeast.head games + turn = case game of + SomeGame game -> gameTurn game + round = case game of + SomeGame game -> gameRound game + +-- | Number of places from the back of a list of SomeGame at which the game +-- for this turn and round is found. +gameIndex :: Turn -> Round -> Int +gameIndex turn round = roundToInt round + 5*(turnToInt turn) + +findGame :: Turn -> Round -> AtLeast One SomeGame -> Maybe SomeGame +findGame turn round games = + let gamesList = Data.AtLeast.toList games + index = gameIndex turn round + in findGame' index (reverse gamesList) + where + findGame' :: Int -> [SomeGame] -> Maybe SomeGame + findGame' n games = case games of + [] -> Nothing + (x : xs) -> if n == 0 then Just x else findGame' (n-1) xs + +-- Careful! This will give the resolved orders for any turn/round pair found, +-- even if it's the latest (ongoing) game! The client-facing code must be +-- careful not to fulfill a user's request for the resolutions of the latest +-- round. +gameStateViewResolution :: Turn -> Round -> GameStateView -> Maybe GameResolution +gameStateViewResolution turn round view = case view of + GameNotStartedView -> Nothing + GameStartedView _ games _ _ _ _ -> case findGame turn round games of + Nothing -> Nothing + Just (SomeGame game) -> Just $ case resolve game of + TypicalGame _ _ _ zonedResolvedOrders control -> GameResolutionTypical (M.map mapper zonedResolvedOrders) (M.map GreatPower control) + RetreatGame _ _ _ _ zonedResolvedOrders occupation control -> GameResolutionRetreat (M.map mapper zonedResolvedOrders) (M.map (fmap Unit) occupation) (M.map GreatPower control) + AdjustGame _ _ _ zonedResolvedOrders control -> GameResolutionAdjust (M.map mapper zonedResolvedOrders) (M.map GreatPower control) + where + mapper + :: (Aligned DU.Unit, SomeResolved DOO.OrderObject phase) + -> (Aligned Unit, SomeOrderObject phase, Bool) + mapper (aunit, SomeResolved (object, res)) = (align unit greatPower, someObject, bool) + where + greatPower = alignedGreatPower aunit + unit = Unit (alignedThing aunit) + someObject = SomeOrderObject (DOO.SomeOrderObject object) + bool = case res of + Nothing -> True + _ -> False + +gameStateViewData :: Turn -> Round -> GameStateView -> Maybe GameData +gameStateViewData turn round view = case view of + GameNotStartedView -> Nothing + GameStartedView greatPowers games _ _ _ _ -> case findGame turn round games of + Nothing -> Nothing + Just (SomeGame game) -> Just $ case game of + TypicalGame _ _ _ zonedOrders control -> GameDataTypical (M.map (mapper greatPowers) zonedOrders) (M.map GreatPower control) + RetreatGame _ _ _ _ zonedOrders occupation control -> GameDataRetreat (M.map (mapper greatPowers) zonedOrders) (M.map (fmap Unit) occupation) (M.map GreatPower control) + AdjustGame _ _ _ zonedOrders control -> GameDataAdjust (M.map (mapper greatPowers) zonedOrders) (M.map GreatPower control) + where + mapper + :: S.Set DGP.GreatPower + -> (Aligned DU.Unit, DOO.SomeOrderObject phase) + -> (Aligned Unit, Maybe (SomeOrderObject phase)) + mapper greatPowers (aunit, someOrderObject) = (align unit greatPower, maybeSomeOrderObject) + where + greatPower = alignedGreatPower aunit + unit = Unit (alignedThing aunit) + maybeSomeOrderObject = case S.member greatPower greatPowers of + True -> Just (SomeOrderObject someOrderObject) + False -> Nothing + +data GameMetadata = GameMetadata { + metadataGreatPowers :: S.Set GreatPower + , metadataTurn :: Turn + , metadataRound :: Round + , metadataDuration :: Duration + , metadataSecondDuration :: Duration + , metadataElapsed :: Elapsed + , metadataPaused :: Bool + } + +instance ToJSON GameMetadata where + toJSON metadata = object [ + "greatPowers" .= greatPowers + , "turn" .= turn + , "round" .= round + , "duration" .= duration + , "secondDuration" .= secondDuration + , "elapsed" .= secondsElapsed + , "paused" .= paused + ] + where + greatPowers = metadataGreatPowers metadata + turn = turnToInt (metadataTurn metadata) + round = roundToInt (metadataRound metadata) + -- We only show the duration up to the minute. + -- These (hours and minutes) are Int64. Can't be bothered to + -- import that so I can write the type signature. + Hours hours = durationHours (metadataDuration metadata) + Minutes minutes = durationMinutes (metadataDuration metadata) + Hours secondHours = durationHours (metadataSecondDuration metadata) + Minutes secondMinutes = durationMinutes (metadataSecondDuration metadata) + -- seconds is an Int64 giving unix time when the game was last + -- advanced (or started, in case it's round 1 turn 1). + Elapsed (Seconds secondsElapsed) = metadataElapsed metadata + duration = object [ + "hours" .= hours + , "minutes" .= minutes + ] + secondDuration = object [ + "hours" .= secondHours + , "minutes" .= secondMinutes + ] + paused = metadataPaused metadata + +instance JSONSchema GameMetadata where + schema _ = Schema.Object [ + greatPowersField + , turnField + , roundField + , durationField + , secondDurationField + , elapsedField + , pausedField + ] + where + greatPowersField = Field "greatPowers" True (Schema.Array (LengthBound (Just 1) (Just 7)) True (Value unboundedLength)) + turnField = Field "turn" True (Schema.Number (Bound (Just 0) Nothing)) + roundField = Field "round" True (Schema.Number (Bound (Just 0) (Just 4))) + durationField = Field "duration" True (Schema.Object [hoursField, minutesField]) + secondDurationField = Field "secondDuration" True (Schema.Object [hoursField, minutesField]) + elapsedField = Field "elapsed" True (Schema.Number (Bound (Just 0) Nothing)) + pausedField = Field "paused" True Boolean + hoursField = Field "hours" True (Schema.Number (Bound (Just 0) Nothing)) + minutesField = Field "minutes" True (Schema.Number (Bound (Just 0) (Just 59))) + +-- For now we give only a Bool to indicate success or failure (true for +-- success). In the future we should give the reason. This is not super easy +-- to do because we use GADTs with phase and order type parameters, so we +-- can't just derive generic JSON instances. +data GameResolution where + GameResolutionTypical + :: M.Map Zone (Aligned Unit, SomeOrderObject Typical, Bool) + -> M.Map Province GreatPower + -> GameResolution + GameResolutionRetreat + :: M.Map Zone (Aligned Unit, SomeOrderObject Retreat, Bool) + -> M.Map Zone (Aligned Unit) + -> M.Map Province GreatPower + -> GameResolution + GameResolutionAdjust + :: M.Map Zone (Aligned Unit, SomeOrderObject Adjust, Bool) + -> M.Map Province GreatPower + -> GameResolution + +instance ToJSON GameResolution where + toJSON gameResolution = case gameResolution of + GameResolutionTypical zonedResolvedOrders control -> object [ + "resolved" .= zonedResolvedOrders + , "control" .= control + ] + GameResolutionRetreat zonedResolvedOrders occupation control -> object [ + "resolved" .= zonedResolvedOrders + , "occupation" .= occupation + , "control" .= control + ] + GameResolutionAdjust zonedResolvedOrders control -> object [ + "resolved" .= zonedResolvedOrders + , "control" .= control + ] + +instance JSONSchema GameResolution where + schema _ = Schema.Object [] + +data GameData where + GameDataTypical + :: M.Map Zone (Aligned Unit, Maybe (SomeOrderObject Typical)) + -> M.Map Province GreatPower + -> GameData + GameDataRetreat + :: M.Map Zone (Aligned Unit, Maybe (SomeOrderObject Retreat)) + -> M.Map Zone (Aligned Unit) + -> M.Map Province GreatPower + -> GameData + GameDataAdjust + :: M.Map Zone (Aligned Unit, Maybe (SomeOrderObject Adjust)) + -> M.Map Province GreatPower + -> GameData + +instance ToJSON GameData where + toJSON gameData = case gameData of + GameDataTypical zonedOrders control -> object [ + "occupation" .= zonedOrders + , "control" .= control + ] + GameDataRetreat zonedOrders occupation control -> object [ + "dislodgement" .= zonedOrders + , "occupation" .= occupation + , "control" .= control + ] + GameDataAdjust zonedOrders control -> object [ + "occupation" .= zonedOrders + , "control" .= control + ] + +instance JSONSchema GameData where + schema _ = Schema.Object [] + +instance ToJSON t => ToJSON (M.Map Zone t) where + toJSON map = toJSON textKeyedMap + where + textKeyedMap :: M.Map T.Text t + textKeyedMap = M.foldWithKey (\z x -> M.insert (zoneToText z) x) M.empty map + zoneToText :: Zone -> T.Text + zoneToText = printProvinceTarget . zoneProvinceTarget + +instance ToJSON t => ToJSON (M.Map Province t) where + toJSON map = toJSON textKeyedMap + where + textKeyedMap :: M.Map T.Text t + textKeyedMap = M.foldWithKey(\p x -> M.insert (printProvince p) x) M.empty map + +instance ToJSON (Aligned Unit) where + toJSON aunit = toJSON (greatPower, unit) + where + greatPower = GreatPower (alignedGreatPower aunit) + unit = alignedThing aunit + +instance ToJSON (Aligned Unit, Maybe (SomeOrderObject phase)) where + toJSON (aunit, maybeObject) = toJSON (greatPower, unit, maybeObject) + where + greatPower = GreatPower (alignedGreatPower aunit) + unit = alignedThing aunit + +instance ToJSON (Aligned Unit, SomeOrderObject phase, Bool) where + toJSON (aunit, object, bool) = toJSON (greatPower, unit, object, bool) + where + greatPower = GreatPower (alignedGreatPower aunit) + unit = alignedThing aunit + +-- | Get a GameStateView for given Credentials, i.e. the set of GreatPowers +-- that this user controls, along with a SomeGame if the game is started, +-- no information if the game is not started, or Nothing in case the +-- Credentials do not match anyone. +gameStateMatchCredentials :: Credentials -> GameState -> Maybe GameStateView +gameStateMatchCredentials creds gameState = case gameState of + GameNotStarted map _ _ -> case M.lookup uname map of + Nothing -> Nothing + Just ud -> case pwd == UD.password ud of + False -> Nothing + True -> Just GameNotStartedView + GameStarted map someGames duration duration' elapsed paused -> case M.lookup uname map of + Nothing -> Nothing + Just ud -> case pwd == UD.password ud of + False -> Nothing + True -> Just (GameStartedView (UD.greatPower ud) someGames duration duration' elapsed paused) + where + uname = Cred.username creds + pwd = Cred.password creds diff --git a/Types/GreatPower.hs b/Types/GreatPower.hs new file mode 100644 --- /dev/null +++ b/Types/GreatPower.hs @@ -0,0 +1,47 @@ +{-| +Module : Types.GreatPower +Description : Wrapper for Diplomacy.GreatPower to make it JSON-able +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Types.GreatPower ( + + GreatPower(..) + + , outGreatPower + + ) where + +import GHC.Generics +import Control.Applicative +import Data.String (fromString) +import Data.Typeable +import qualified Data.Text as T +import Data.Aeson +import Data.JSON.Schema +import qualified Diplomacy.GreatPower as D + +newtype GreatPower = GreatPower D.GreatPower + deriving (Eq, Ord, Show, Generic, Typeable) + +outGreatPower :: GreatPower -> D.GreatPower +outGreatPower (GreatPower x) = x + +instance ToJSON GreatPower where + toJSON (GreatPower p) = String . fromString . show $ p + +instance FromJSON GreatPower where + parseJSON (String txt) = case reads (T.unpack txt) of + (greatPower, _) : _ -> return (GreatPower greatPower) + _ -> empty + parseJSON _ = empty + +instance JSONSchema GreatPower where + schema _ = Value (LengthBound Nothing Nothing) diff --git a/Types/Order.hs b/Types/Order.hs new file mode 100644 --- /dev/null +++ b/Types/Order.hs @@ -0,0 +1,243 @@ +{-| +Module : Types.Order +Description : Wrapper for Diplomacy.Order making to JSON-able. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Types.Order ( + + SomeOrder(..) + , SomeOrderObject(..) + + , parseSomeOrderTypical + , parseSomeOrderRetreat + , parseSomeOrderAdjust + + , printSomeOrder + , printObject + + ) where + +import Control.Applicative +import qualified Data.Text as T +import Data.Aeson +import Data.Aeson.Parser +import Data.JSON.Schema +import Text.Parsec hiding ((<|>)) +import Text.Parsec.Text +import Diplomacy.Phase +import Diplomacy.OrderType +import Diplomacy.Order hiding (Order(..), SomeOrder(..)) +import qualified Diplomacy.Order as DO +import qualified Diplomacy.OrderObject as DOO +import Diplomacy.Subject +import Diplomacy.Province +import Diplomacy.Unit + +newtype SomeOrderObject (phase :: Phase) = SomeOrderObject { + outSomeOrderObject :: DOO.SomeOrderObject phase + } + +deriving instance Show (SomeOrderObject phase) + +instance JSONSchema (SomeOrderObject phase) where + schema _ = Value (LengthBound Nothing Nothing) + +instance ToJSON (SomeOrderObject phase) where + toJSON (SomeOrderObject (DOO.SomeOrderObject object)) = String (printObject object) + +instance FromJSON (SomeOrderObject Typical) where + parseJSON (String txt) = case parse parseObjectTypical "" txt of + Left _ -> empty + Right x -> return (SomeOrderObject x) + parseJSON _ = empty + +instance FromJSON (SomeOrderObject Retreat) where + parseJSON (String txt) = case parse parseObjectRetreat "" txt of + Left _ -> empty + Right x -> return (SomeOrderObject x) + parseJSON _ = empty + +instance FromJSON (SomeOrderObject Adjust) where + parseJSON (String txt) = case parse parseObjectAdjust "" txt of + Left _ -> empty + Right x -> return (SomeOrderObject x) + parseJSON _ = empty + +newtype SomeOrder (phase :: Phase) = SomeOrder { + outSomeOrder :: DO.SomeOrder phase + } + +deriving instance Show (SomeOrder phase) +deriving instance Eq (SomeOrder phase) +deriving instance Ord (SomeOrder phase) + +instance JSONSchema (SomeOrder phase) where + schema _ = Value (LengthBound Nothing Nothing) + +instance ToJSON (SomeOrder phase) where + toJSON = String . printSomeOrder + +instance FromJSON (SomeOrder Typical) where + parseJSON (String txt) = case parse parseSomeOrderTypical "" txt of + Left _ -> empty + Right x -> return x + parseJSON _ = empty + +instance FromJSON (SomeOrder Retreat) where + parseJSON (String txt) = case parse parseSomeOrderRetreat "" txt of + Left _ -> empty + Right x -> return x + parseJSON _ = empty + +instance FromJSON (SomeOrder Adjust) where + parseJSON (String txt) = case parse parseSomeOrderAdjust "" txt of + Left _ -> empty + Right x -> return x + parseJSON _ = empty + +printSomeOrder :: SomeOrder phase -> T.Text +printSomeOrder (SomeOrder (DO.SomeOrder order)) = T.concat [ + printSubject (orderSubject order) + , " " + , printObject (orderObject order) + ] + +printSubject :: Subject -> T.Text +printSubject (unit, pt) = T.concat [ + printUnit unit + , " " + , printProvinceTarget pt + ] + +printObject :: DOO.OrderObject phase order -> T.Text +printObject object = case object of + DOO.MoveObject pt -> T.concat ["- ", printProvinceTarget pt] + DOO.SupportObject subj pt -> + if subjectProvinceTarget subj == pt + then T.concat ["S ", printSubject subj] + else T.concat ["S ", printSubject subj, " - ", printProvinceTarget pt] + DOO.ConvoyObject subj pt -> + T.concat ["C ", printSubject subj, " - ", printProvinceTarget pt] + DOO.SurrenderObject -> "Surrender" + DOO.WithdrawObject pt -> + T.concat ["- ", printProvinceTarget pt] + DOO.DisbandObject -> "Disband" + DOO.BuildObject -> "Build" + DOO.ContinueObject -> "Continue" + +parseSomeOrderTypical :: Parser (SomeOrder Typical) +parseSomeOrderTypical = do + subject <- parseSubject + spaces + DOO.SomeOrderObject object <- parseObjectTypical + return $ SomeOrder (DO.SomeOrder (DO.Order (subject, object))) + +parseSomeOrderRetreat :: Parser (SomeOrder Retreat) +parseSomeOrderRetreat = do + subject <- parseSubject + spaces + DOO.SomeOrderObject object <- parseObjectRetreat + return $ SomeOrder (DO.SomeOrder (DO.Order (subject, object))) + +parseSomeOrderAdjust :: Parser (SomeOrder Adjust) +parseSomeOrderAdjust = do + subject <- parseSubject + spaces + DOO.SomeOrderObject object <- parseObjectAdjust + return $ SomeOrder (DO.SomeOrder (DO.Order (subject, object))) + +parseSubject :: Parser Subject +parseSubject = do + unit <- parseUnit + spaces + pt <- parseProvinceTarget + return (unit, pt) + +parseObjectTypical :: Parser (DOO.SomeOrderObject Typical) +parseObjectTypical = + (DOO.SomeOrderObject <$> try parseMove) + <|> (DOO.SomeOrderObject <$> try parseSupport) + <|> (DOO.SomeOrderObject <$> try parseConvoy) + +parseObjectRetreat :: Parser (DOO.SomeOrderObject Retreat) +parseObjectRetreat = + (DOO.SomeOrderObject <$> try parseSurrender) + <|> (DOO.SomeOrderObject <$> try parseWithdraw) + +parseObjectAdjust :: Parser (DOO.SomeOrderObject Adjust) +parseObjectAdjust = + (DOO.SomeOrderObject <$> try parseDisband) + <|> (DOO.SomeOrderObject <$> try parseBuild) + <|> (DOO.SomeOrderObject <$> try parseContinue) + +parseMove :: Parser (DOO.OrderObject Typical Move) +parseMove = do + char '-' + spaces + pt <- parseProvinceTarget + return $ DOO.MoveObject pt + +parseSupport :: Parser (DOO.OrderObject Typical Support) +parseSupport = do + char 'S' + spaces + subject <- parseSubject + target <- Text.Parsec.option (subjectProvinceTarget subject) (try rest) + return $ DOO.SupportObject subject target + where + rest = do + spaces + char '-' + spaces + parseProvinceTarget + +parseConvoy :: Parser (DOO.OrderObject Typical Convoy) +parseConvoy = do + char 'C' + spaces + subject <- parseSubject + spaces + char '-' + spaces + target <- parseProvinceTarget + return $ DOO.ConvoyObject subject target + +parseSurrender :: Parser (DOO.OrderObject Retreat Surrender) +parseSurrender = do + string "Surrender" + return $ DOO.SurrenderObject + +parseWithdraw :: Parser (DOO.OrderObject Retreat Withdraw) +parseWithdraw = do + char '-' + spaces + pt <- parseProvinceTarget + return $ DOO.WithdrawObject pt + +parseDisband :: Parser (DOO.OrderObject Adjust Disband) +parseDisband = do + string "Disband" + return $ DOO.DisbandObject + +parseBuild :: Parser (DOO.OrderObject Adjust Build) +parseBuild = do + string "Build" + return $ DOO.BuildObject + +parseContinue :: Parser (DOO.OrderObject Adjust Continue) +parseContinue = do + string "Continue" + return $ DOO.ContinueObject diff --git a/Types/Server.hs b/Types/Server.hs new file mode 100644 --- /dev/null +++ b/Types/Server.hs @@ -0,0 +1,122 @@ +{-| +Module : +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Types.Server ( + + ServerState(..) + , Server + + , withAdminCredentials + , withUserCredentialsForGame + , modifyGameState + + , serverState + , runDiplomacyServer + + ) where + +import Control.DeepSeq +import Control.Monad.Trans.Except +import Control.Monad.Trans.State as S +import Control.Monad.State.Class as SC +import Control.Concurrent.STM +import Control.Concurrent.STM.TVar +import Data.Stream as Stream +import Data.ByteString as BS +import Data.ByteString.Lazy as BL +import qualified Data.Map as M +import Data.Functor.Identity +import Data.Hourglass +import System.Hourglass +import System.Random +import Rest.Error +import Types.GameId +import Types.Credentials +import Types.GameState + +data ServerState = ServerState { + adminCredentials :: Credentials + , games :: M.Map GameId (Password, GameState) + , currentTime :: Elapsed + , randomDoubles :: Stream.Stream Double + , clientHtml :: BL.ByteString + } + +type Server = StateT ServerState Identity + +withAdminCredentials + :: MonadState ServerState m + => Credentials + -> ExceptT (Reason e) m t + -> ExceptT (Reason e) m t +withAdminCredentials creds term = do + state <- SC.get + if adminCredentials state == creds + then term + else throwE AuthenticationFailed + +withUserCredentialsForGame + :: MonadState ServerState m + => Credentials + -> GameId + -> (GameStateView -> ExceptT (Reason e) m t) + -> ExceptT (Reason e) m t +withUserCredentialsForGame creds gameId term = do + state <- SC.get + let game = M.lookup gameId (games state) + case game of + Nothing -> throwE NotFound + Just (_, gameState) -> case gameStateMatchCredentials creds gameState of + Nothing -> throwE AuthenticationFailed + Just gameStateView -> term gameStateView + +modifyGameState + :: MonadState ServerState m + => GameId + -> (GameState -> ExceptT (Reason e) m GameState) + -> ExceptT (Reason e) m () +modifyGameState gameId f = do + state <- SC.get + let game = M.lookup gameId (games state) + case game of + Nothing -> throwE NotFound + Just (password, gameState) -> do + modified <- f gameState + SC.put (state { games = M.alter (const (Just (password, force modified))) gameId (games state) }) + return () + +serverState :: Username -> Password -> IO ServerState +serverState adminUsername adminPassword = do + let games = M.empty + g <- getStdGen + let ds = unfold random g :: Stream.Stream Double + t <- timeCurrent + bs <- BL.readFile "client.html" + return $ ServerState (Credentials adminUsername adminPassword) games t ds bs + +runDiplomacyServer :: TVar ServerState -> (forall a . Server a -> IO a) +runDiplomacyServer tvar m = do + -- Always refurnish the state with random doubles. + g <- getStdGen + let ds = unfold random g :: Stream.Stream Double + t <- timeCurrent + bs <- BL.readFile "client.html" + atomically $ do + state <- readTVar tvar + -- It's important to update the time and random doubles before we + -- run the term @m@. + let state' = state { currentTime = t, randomDoubles = ds, clientHtml = bs } + let (x, nextState) = runIdentity (runStateT m state') + writeTVar tvar nextState + return x diff --git a/Types/ServerOptions.hs b/Types/ServerOptions.hs new file mode 100644 --- /dev/null +++ b/Types/ServerOptions.hs @@ -0,0 +1,49 @@ +{-| +Module : +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Types.ServerOptions ( + + ServerOptions(..) + , parser + + ) where + +import System.FilePath +import Types.Credentials +import Options.Applicative +import Options.Applicative.Builder + +data ServerOptions = ServerOptions { + adminUsername :: Username + , adminPassword :: Password + , certificateFile :: FilePath + , keyFile :: FilePath + , port :: Int + } + deriving (Show) + +parser :: Parser ServerOptions +parser = + ServerOptions + <$> adminUsernameParser + <*> adminPasswordParser + <*> certificateFileParser + <*> keyFileParser + <*> port + where + adminUsernameParser = strOption (long "username" <> short 'u' <> help "Username for administration") + adminPasswordParser = strOption (long "password" <> short 'p' <> help "Password for administration") + certificateFileParser = strOption (long "certificate" <> short 'c' <> value "certificate.pem" <> help "Certificate for TLS") + keyFileParser = strOption (long "key" <> short 'k' <> value "key.pem" <> help "Private key for TLS") + port = option auto (long "port" <> value 4347 <> help "Port on which to run the server") + + diff --git a/Types/Unit.hs b/Types/Unit.hs new file mode 100644 --- /dev/null +++ b/Types/Unit.hs @@ -0,0 +1,45 @@ +{-| +Module : Types.Unit +Description : Wrapper for Diplomacy.Unit to make it JSON-able +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Types.Unit ( + + Unit(..) + + ) where + +import GHC.Generics +import Control.Applicative +import Data.String (fromString) +import Data.Typeable +import qualified Data.Text as T +import Data.Aeson +import Data.JSON.Schema +import qualified Diplomacy.Unit as D +import Text.Parsec + +newtype Unit = Unit { + outUnit :: D.Unit + } + deriving (Eq, Ord, Show, Generic, Typeable) + +instance ToJSON Unit where + toJSON (Unit unit) = String . fromString . D.printUnit $ unit + +instance FromJSON Unit where + parseJSON (String txt) = case parse D.parseUnit "" txt of + Left _ -> empty + Right x -> return (Unit x) + parseJSON _ = empty + +instance JSONSchema Unit where + schema _ = Value (LengthBound (Just 1) (Just 1)) diff --git a/Types/UserData.hs b/Types/UserData.hs new file mode 100644 --- /dev/null +++ b/Types/UserData.hs @@ -0,0 +1,25 @@ +{-| +Module : Types.UserData +Description : +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Types.UserData ( + + UserData(..) + + ) where + +import Types.Credentials (Password) +import Diplomacy.GreatPower + +data UserData f = UserData { + password :: Password + , greatPower :: f GreatPower + } diff --git a/client.html b/client.html new file mode 100644 --- /dev/null +++ b/client.html @@ -0,0 +1,2031 @@ + + + + + + + + + + + + + + + diff --git a/diplomacy-server.cabal b/diplomacy-server.cabal new file mode 100644 --- /dev/null +++ b/diplomacy-server.cabal @@ -0,0 +1,84 @@ +-- Initial diplomacy-server.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: diplomacy-server +version: 0.1.0.0 +synopsis: Play Diplomacy over HTTP +-- description: +homepage: https://github.com/avieth/diplomacy-server +license: BSD3 +license-file: LICENSE +author: Alexander Vieth +maintainer: aovieth@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +extra-source-files: ./client.html + +executable diplomacy-server + main-is: Main.hs + Hs-Source-Dirs: ./ + Other-Modules: Types.Credentials + , Types.GameId + , Types.Server + , Types.GameState + , Types.GreatPower + , Types.Order + , Types.ServerOptions + , Types.UserData + , Types.Unit + , Resources.Advance + , Resources.Client + , Resources.Game + , Resources.Game.Create + , Resources.Game.Remove + , Resources.Join + , Resources.Metadata + , Resources.Order + , Resources.Pause + , Resources.Resolution + , Resources.Start + , Router + -- other-modules: + other-extensions: AutoDeriveTypeable + , RankNTypes + , GADTs + , DeriveGeneric + , StandaloneDeriving + , DataKinds + , ScopedTypeVariables + , FlexibleContexts + , OverloadedStrings + , FlexibleInstances + , KindSignatures + + build-depends: base >=4.7 && <4.8 + , async >=2.0 && <2.1 + , stm >=2.4 && <2.5 + , transformers >=0.3 && <0.4 + , containers >=0.5 && <0.6 + , diplomacy >=0.1 && <0.2 + , TypeNat >=0.4 && <0.5 + , hourglass >=0.2 && <0.3 + , rest-core >=0.36 && <0.37 + , rest-wai >=0.1 && <0.2 + , wai >=3.0 && <3.1 + , warp >=3.0 && <3.1 + , warp-tls >=3.0 && <3.1 + , optparse-applicative >=0.11 && <0.12 + , transformers-compat >=0.4 && <0.5 + , bytestring >=0.10 && <0.11 + , aeson >=0.9 && <0.10 + , json-schema >=0.7 && <0.8 + , mtl >=2.1 && <2.2 + , Stream >=0.4 && <0.5 + , deepseq >=1.3 && <1.4 + , text >=1.2 && <1.3 + , filepath >=1.3 && <1.4 + , random >=1.1 && <1.2 + , parsec >=3.1 && <3.2 + -- hs-source-dirs: + default-language: Haskell2010