diplomacy-server (empty) → 0.1.0.0
raw patch · 27 files changed
+4593/−0 lines, 27 filesdep +Streamdep +TypeNatdep +aesonsetup-changed
Dependencies added: Stream, TypeNat, aeson, async, base, bytestring, containers, deepseq, diplomacy, filepath, hourglass, json-schema, mtl, optparse-applicative, parsec, random, rest-core, rest-wai, stm, text, transformers, transformers-compat, wai, warp, warp-tls
Files
- LICENSE +30/−0
- Main.hs +114/−0
- README.md +81/−0
- Resources/Advance.hs +152/−0
- Resources/Client.hs +56/−0
- Resources/Game.hs +113/−0
- Resources/Game/Create.hs +76/−0
- Resources/Game/Remove.hs +70/−0
- Resources/Join.hs +123/−0
- Resources/Metadata.hs +48/−0
- Resources/Order.hs +200/−0
- Resources/Pause.hs +97/−0
- Resources/Resolution.hs +98/−0
- Resources/Start.hs +147/−0
- Router.hs +79/−0
- Setup.hs +2/−0
- Types/Credentials.hs +41/−0
- Types/GameId.hs +31/−0
- Types/GameState.hs +389/−0
- Types/GreatPower.hs +47/−0
- Types/Order.hs +243/−0
- Types/Server.hs +122/−0
- Types/ServerOptions.hs +49/−0
- Types/Unit.hs +45/−0
- Types/UserData.hs +25/−0
- client.html +2031/−0
- diplomacy-server.cabal +84/−0
+ LICENSE view
@@ -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.
+ Main.hs view
@@ -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)]++
+ README.md view
@@ -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 <username> -p <password>+```++The default port is `4347`, but this can be changed using `--port`. With+the server running, navigate to `https://<host>: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.
+ Resources/Advance.hs view
@@ -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
+ Resources/Client.hs view
@@ -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)
+ Resources/Game.hs view
@@ -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)
+ Resources/Game/Create.hs view
@@ -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
+ Resources/Game/Remove.hs view
@@ -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
+ Resources/Join.hs view
@@ -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
+ Resources/Metadata.hs view
@@ -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)
+ Resources/Order.hs view
@@ -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
+ Resources/Pause.hs view
@@ -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
+ Resources/Resolution.hs view
@@ -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
+ Resources/Start.hs view
@@ -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
+ Router.hs view
@@ -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+ }
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Types/Credentials.hs view
@@ -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
+ Types/GameId.hs view
@@ -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
+ Types/GameState.hs view
@@ -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
+ Types/GreatPower.hs view
@@ -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)
+ Types/Order.hs view
@@ -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
+ Types/Server.hs view
@@ -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
+ Types/ServerOptions.hs view
@@ -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")++
+ Types/Unit.hs view
@@ -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))
+ Types/UserData.hs view
@@ -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+ }
+ client.html view
@@ -0,0 +1,2031 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+ <head>+ <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />+ </head>++ <body>++ <script>++ var animationFrameCallbacks = [];++ var animate = function () {+ for (var i = 0; i < animationFrameCallbacks.length; ++i) {+ animationFrameCallbacks[i]();+ }+ window.requestAnimationFrame(animate);+ };++ var clearContainer = function (in_container) {+ while (in_container.firstChild) {+ in_container.removeChild(in_container.firstChild);+ }+ animationFrameCallbacks = [];+ };++ var uiGameId = function (in_container, in_callback) {+ uiInput(in_container, 'Game name', 'text', in_callback);+ };++ var uiGamePassword = function (in_container, in_callback) {+ uiInput(in_container, 'Game password', 'password', in_callback);+ };++ var uiGameDuration = function (in_container, in_callback) {+ uiInput(in_container, 'Length of typical phase (in minutes)', 'text', in_callback);+ };++ var uiGameSecondDuration = function (in_container, in_callback) {+ uiInput(in_container, 'Length of other phases (in minutes)', 'text', in_callback);+ };++ var uiPassword = function (in_container, in_callback) {+ uiInput(in_container, 'Password', 'password', in_callback);+ };++ var uiUsername = function (in_container, in_callback) {+ uiInput(in_container, 'Username', 'text', in_callback);+ };++ var uiInitial = function (in_container) {+ var element = buttons([+ {+ text : 'Play',+ click : function () {+ uiPlay(in_container);+ }+ },+ { + text : 'Administrate',+ click : function () {+ uiAdmin(in_container);+ }+ }+ ]);+ clearContainer(in_container);+ in_container.appendChild(element);+ };++ var uiAdmin = function (in_container) {+ var element = buttons([+ {+ text : 'Create',+ click : function () {+ uiGameId(in_container, function (in_gameId) {+ uiGamePassword(in_container, function (in_gamePassword) {+ uiGameDuration(in_container, function (in_gameDuration) {+ uiGameSecondDuration(in_container, function (in_gameSecondDuration) {+ uiUsername(in_container, function (in_username) {+ uiPassword(in_container, function (in_password) {+ createGame(in_container, in_gameId, in_gamePassword, Number(in_gameDuration), Number(in_gameSecondDuration), in_username, in_password, function (in_error) {+ if (in_error) {+ uiInitial(in_container);+ } else {+ uiInitial(in_container);+ }+ });+ });+ });+ });+ });+ });+ });+ }+ },+ {+ text : 'Start',+ click : function () {+ uiGameId(in_container, function (in_gameId) {+ uiUsername(in_container, function (in_username) {+ uiPassword(in_container, function (in_password) {+ startGame(in_container, in_gameId, in_username, in_password, function (in_error) {+ if (in_error) {+ uiInitial(in_container);+ } else {+ uiInitial(in_container);+ }+ });+ });+ });+ });+ }+ },+ {+ text : 'Advance',+ click : function () {+ uiGameId(in_container, function (in_gameId) {+ uiUsername(in_container, function (in_username) {+ uiPassword(in_container, function (in_password) {+ advanceGame(in_container, in_gameId, in_username, in_password, function (in_error) {+ if (in_error) {+ uiInitial(in_container);+ } else {+ uiInitial(in_container);+ }+ });+ });+ });+ });+ }+ },+ {+ text : 'Pause',+ click : function () {+ uiGameId(in_container, function (in_gameId) {+ uiUsername(in_container, function (in_username) {+ uiPassword(in_container, function (in_password) {+ pauseGame(in_container, in_gameId, in_username, in_password, function (in_error) {+ if (in_error) {+ uiInitial(in_container);+ } else {+ uiInitial(in_container);+ }+ });+ });+ });+ });+ }+ },++ {+ text : 'Destroy',+ click : function () {+ uiGameId(in_container, function (in_gameId) {+ uiUsername(in_container, function (in_username) {+ uiPassword(in_container, function (in_password) {+ destroyGame(in_container, in_gameId, in_username, in_password, function (in_error) {+ if (in_error) {+ uiInitial(in_container);+ } else {+ uiInitial(in_container);+ }+ });+ });+ });+ });+ }+ }+ ]);+ clearContainer(in_container);+ in_container.appendChild(element);+ };++ var uiPlay = function (in_container) {+ var element = buttons([+ {+ text : 'Continue existing game',+ click : function () {+ uiGameId(in_container, function (in_gameId) {+ uiUsername(in_container, function (in_username) {+ uiPassword(in_container, function (in_password) {+ fetchMetadata(in_gameId, in_username, in_password, function (in_error, in_metadata) {+ if (in_error) {+ uiPlay(in_container);+ } else {+ uiPlayGame(in_container, in_gameId, in_username, in_password, in_metadata);+ }+ });+ });+ });+ });+ }+ },+ {+ text : 'Join game',+ click : function () {+ uiGameId(in_container, function (in_gameId) {+ uiGamePassword(in_container, function (in_gamePassword) {+ uiUsername(in_container, function (in_username) {+ uiPassword(in_container, function (in_password) {+ joinGame(in_container, in_gameId, in_gamePassword, in_username, in_password, function (in_error) {+ if (in_error) {+ uiError(in_container, 'Could not join game.', function () {+ uiInitial(in_container);+ });+ } else {+ uiInitial(in_container);+ }+ });+ });+ });+ });+ });+ }+ }+ ]);+ clearContainer(in_container);+ in_container.appendChild(element);+ };++ var uiPlayGame = function (in_container, in_gameId, in_username, in_password, in_metadata, in_maybeTurn, in_maybeRound) {+ clearContainer(in_container);+ if (in_metadata === null) {+ // Game has not yet begun.+ var divLabel = document.createElement('div');+ divLabel.innerHTML = 'Game not started';+ var liLabel = document.createElement('li');+ liLabel.appendChild(divLabel);+ liLabel.style.display = 'table-row';+ liLabel.style.textAlign = 'center';+ ul.appendChild(liLabel);+ } else {+ // Show the game at the latest round.+ var turn = in_maybeTurn;+ if (typeof turn !== 'number') {+ turn = in_metadata.turn;+ }+ var round = in_maybeRound;+ if (typeof round !== 'number') {+ round = in_metadata.round;+ }+ var f = function (in_callback) {+ fetchResolution(in_gameId, in_username, in_password, turn, round, in_callback);+ };+ if (turn === in_metadata.turn && round === in_metadata.round) {+ var f = function (in_callback) {+ fetchGame(in_gameId, in_username, in_password, in_callback);+ };+ }+ f(function (in_error, in_game) {+ if (in_error) {+ uiError(in_container, 'Could not fetch game.', function () {+ uiPlay(in_container);+ });+ } else {+ uiGameView(in_container, in_gameId, in_username, in_password, in_metadata, turn, round, in_game);+ }+ });+ }+ };++ var uiMetadata = function (in_container, in_gameId, in_username, in_password, in_metadata, in_turn, in_round) {++ var turn = in_turn + 1900;+ var phase = 'Typical';+ var season = 'Spring';+ if (in_round === 1 || in_round === 3) {+ phase = 'Retreat';+ } else if (in_round === 4) {+ phase = 'Adjust';+ }+ if (in_round > 1 && in_round < 4) {+ season = 'Fall';+ } else if (in_round === 4) {+ season = 'Winter';+ }+ var latestPhase = 'Typical';+ if (in_metadata.round === 1 || in_metadata.round === 3) {+ latestPhase = 'Retreat';+ } else if (in_metadata.round === 4) {+ latestPhase = 'Adjust';+ }++ var tdPreviousButton = document.createElement('td');+ var previousButton = document.createElement('input');+ previousButton.type = 'button';+ previousButton.value = 'Previous';+ tdPreviousButton.appendChild(previousButton);+ if (in_turn === 0 && in_round === 0) {+ previousButton.disabled = true;+ }+ tdPreviousButton.addEventListener('click', function (in_event) {+ // Here we must reload the metadata and the game but stick to a+ // particular round!+ if (in_turn === 0 && in_round === 0) {+ } else {+ var previousTurn = in_turn;+ // JavaScript modular arithmetic at negative numbers isn't+ // defined such that we can use (in_round - 1) % 5.+ var previousRound = in_round - 1;+ if (previousRound === -1) {+ previousRound = 4;+ previousTurn = previousTurn - 1;+ }+ uiPlayGame(in_container, in_gameId, in_username, in_password, in_metadata, previousTurn, previousRound);+ }+ });+++ var tdPhase = document.createElement('td');+ tdPhase.innerHTML = season + ' ' + String(turn) + ' ' + phase;+ tdPhase.style.width = '100%';++ var tdCounter = document.createElement('td');+ var updateCounter = function () {+ var paused = !!in_metadata.paused;+ if (paused) {+ tdCounter.innerHTML = 'Paused';+ } else {+ var secondsElapsed = ((new Date().getTime() / 1000) - in_metadata.elapsed)+ var duration = {+ hours : (latestPhase === 'Typical') ? in_metadata.duration.hours : in_metadata.secondDuration.hours,+ minutes : (latestPhase === 'Typical') ? in_metadata.duration.minutes : in_metadata.secondDuration.minutes+ };+ var durationSeconds = duration.hours * 60 * 60 + duration.minutes * 60;+ var secondsRemaining = Math.max(0, durationSeconds - secondsElapsed);+ var minutesRemaining = secondsRemaining / 60;+ var hoursRemaining = minutesRemaining / 60;+ var hoursRemainingText = String(Math.floor(hoursRemaining));+ var minutesRemainingText = String(Math.floor(minutesRemaining) % 60);+ var secondsRemainingText = String(Math.floor(secondsRemaining) % 60);+ if (minutesRemainingText.length === 1) {+ minutesRemainingText = '0' + minutesRemainingText;+ }+ if (secondsRemainingText.length === 1) {+ secondsRemainingText = '0' + secondsRemainingText;+ }+ tdCounter.innerHTML = [+ hoursRemainingText,+ minutesRemainingText,+ secondsRemainingText+ ].join(':');+ }+ };+ updateCounter();+ animationFrameCallbacks.push(updateCounter);++ var tdGreatPowers = document.createElement('td');+ tdGreatPowers.innerHTML = in_metadata.greatPowers.join(', ');++ var tdNextButton = document.createElement('td');+ var nextButton = document.createElement('input');+ nextButton.type = 'button';+ if (in_turn === in_metadata.turn && in_round === in_metadata.round) {+ nextButton.value = 'Refresh';+ } else {+ nextButton.value = 'Next';+ var latestButton = document.createElement('input');+ latestButton.type = 'button';+ latestButton.value = 'Latest';+ tdNextButton.appendChild(latestButton);+ latestButton.addEventListener('click', function (in_event) {+ fetchMetadata(in_gameId, in_username, in_password, function (in_error, in_metadata) {+ if (in_error) {+ uiError(in_container, 'Could not fetch metadata.', function () {+ uiInitial(in_container);+ });+ } else {+ uiPlayGame(in_container, in_gameId, in_username, in_password, in_metadata);+ }+ });+ });+ }+ tdNextButton.appendChild(nextButton);+ tdNextButton.addEventListener('click', function (in_event) {+ if (in_turn === in_metadata.turn && in_round === in_metadata.round) {+ // Here we must reload the metadata and the game but stick to a+ // particular round!+ fetchMetadata(in_gameId, in_username, in_password, function (in_error, in_metadata) {+ if (in_error) {+ uiError(in_container, 'Could not fetch metadata.', function () {+ uiInitial(in_container);+ });+ } else {+ uiPlayGame(in_container, in_gameId, in_username, in_password, in_metadata);+ }+ });+ } else {+ var nextTurn = in_turn;+ var nextRound = (in_round + 1) % 5;+ if (nextRound === 0) {+ nextTurn = nextTurn + 1;+ }+ uiPlayGame(in_container, in_gameId, in_username, in_password, in_metadata, nextTurn, nextRound);+ }+ });++ var table = document.createElement('table');+ var tr = document.createElement('tr');+ tr.appendChild(tdPreviousButton);+ tr.appendChild(tdPhase);+ tr.appendChild(tdCounter);+ tr.appendChild(tdGreatPowers);+ tr.appendChild(tdNextButton);+ tr.style.whiteSpace = 'nowrap';+ table.appendChild(tr);+ return table;+ };++ var uiGameData = function (in_container, in_gameId, in_username, in_password, in_metadata, in_round, in_game) {+ // in_game could be the current game in any phase, or a resolution+ // from any phase.+ // No matter the case, we have enough data to show the map.++ var table = document.createElement('table');+ var tr = document.createElement('tr');+ var tdMap = document.createElement('td');+ var tdOrders = document.createElement('td');+ tdMap.style.width = '50%';+ tdOrders.style.width = '50%';+ tdOrders.style.verticalAlign = 'text-top';+ tr.appendChild(tdMap);+ tr.appendChild(tdOrders);+ table.appendChild(tr);++ var occupation;+ var dislodgement;+ var control = in_game.control;++ if (in_game.resolved) {+ if (in_game.occupation) {+ // It's a retreat phase resolution.+ occupation = in_game.occupation;+ } else {+ occupation = in_game.resolved;+ }+ } else {+ occupation = in_game.occupation;+ dislodgement = in_game.dislodgement || {};+ }++ var svgMap = window.svgMap+ for (var i in svgMap.fleets) {+ svgMap.removeChild(svgMap.fleets[i]);+ }+ for (var i in svgMap.armies) {+ svgMap.removeChild(svgMap.armies[i]);+ }+ svgMap.fleets = [];+ svgMap.armies = [];+ for (var i in occupation) {+ // Here we construct SVG elements for each unit on the board, and+ // throw them into the map.+ if (occupation[i][2] === 'Build') {+ } else if (occupation[i][1] === 'F') {+ svgMap.fleets.push(svgFleet(occupation[i][0], unitOccupationLocation(i)));+ } else {+ svgMap.armies.push(svgArmy(occupation[i][0], unitOccupationLocation(i)));+ }+ }+ for (var i in dislodgement) {+ // Just like occupation, except the units are offset slightly and+ // drawn atop the occupier.+ if (dislodgement[i][1] === 'F') {+ svgMap.fleets.push(svgFleet(dislodgement[i][0], unitDislodgementLocation(i)));+ } else {+ svgMap.armies.push(svgArmy(dislodgement[i][0], unitDislodgementLocation(i)));+ }+ }+ for (var i in svgMap.fleets) {+ svgMap.appendChild(svgMap.fleets[i]);+ }+ for (var i in svgMap.armies) {+ svgMap.appendChild(svgMap.armies[i]);+ }+ for (var i in control) {+ // For control, we can just set all supply centre classes to their+ // controlling nation, since control never reverts to Unowned.+ // It's OK if there's no element; control is for all provinces, but+ // we only SHOW control for supply centres.+ var element = svgMap.getElementById('SC' + i);+ if (element && element.children && element.children[0]) {+ element.children[0].setAttribute('class', control[i]);+ }+ }+ svgMap.style.display = 'inline-block';+ tdMap.appendChild(svgMap);++ if (!in_game.resolved) {+ // Inputs for orders.+ var greatPowers = in_metadata.greatPowers;+ var phase = 'Typical';+ if (in_round === 1 || in_round === 3) {+ phase = 'Retreat';+ } else if (in_round === 4) {+ phase = 'Adjust';+ }+ var orderForm = document.createElement('form');+ orderForm.id = 'orderForm';+ var orderTable = document.createElement('table');+ orderForm.appendChild(orderTable);+ // Identifying when we can give an order... for lack of any proper+ // design in this client, we just check that the third component of+ // an entry is not null, in which case its the current order, and we+ // assume that this unit is under the user's control.+ var orderEntries = [];+ for (var k in greatPowers) {+ var tdGreatPowerLabel = document.createElement('td');+ tdGreatPowerLabel.style.fontStyle = 'italic';+ tdGreatPowerLabel.innerHTML = greatPowers[k];+ tdGreatPowerLabel.setAttribute('colspan', 2);+ trGreatPowerLabel = document.createElement('tr');+ trGreatPowerLabel.appendChild(tdGreatPowerLabel);+ orderTable.appendChild(trGreatPowerLabel);+ if (phase === 'Typical') {+ var atLeastOneOrder = false;+ for (var i in occupation) {+ if (greatPowers[k] === occupation[i][0] && occupation[i][2]) {+ var atLeastOneOrder = true;+ // Above test passes only if this client has control over the+ // great power who owns this entry.+ var orderEntry = makeOrderEntry({+ provinceTarget : i,+ greatPower : occupation[i][0],+ unit : occupation[i][1],+ orderObject : occupation[i][2]+ });+ orderEntries.push(orderEntry);+ var tr = document.createElement('tr');+ var tdl = document.createElement('td');+ tdl.appendChild(orderEntry.left);+ var tdr = document.createElement('td');+ tdr.appendChild(orderEntry.right);+ tr.appendChild(tdl);+ tr.appendChild(tdr);+ orderTable.appendChild(tr);+ }+ }+ if (!atLeastOneOrder) {+ orderTable.removeChild(trGreatPowerLabel);+ }+ } else if (phase === 'Retreat') {+ var atLeastOneOrder = false;+ for (var i in dislodgement) {+ if (greatPowers[k] === dislodgement[i][0] && dislodgement[i][2]) {+ var atLeastOneOrder = true;+ var orderEntry = makeOrderEntry({+ provinceTarget : i,+ greatPower : dislodgement[i][0],+ unit : dislodgement[i][1],+ orderObject : dislodgement[i][2]+ });+ orderEntries.push(orderEntry);+ var tr = document.createElement('tr');+ var tdl = document.createElement('td');+ tdl.appendChild(orderEntry.left);+ var tdr = document.createElement('td');+ tdr.appendChild(orderEntry.right);+ tr.appendChild(tdl);+ tr.appendChild(tdr);+ orderTable.appendChild(tr);+ }+ }+ if (!atLeastOneOrder) {+ orderTable.removeChild(trGreatPowerLabel);+ }+ } else if (phase === 'Adjust') {+ var controlledSupplyCentres = [];+ for (var i in control) {+ if (supplyCentres[i] === true && greatPowers[k] === control[i]) {+ controlledSupplyCentres.push(i);+ }+ }+ var controlledUnits = [];+ for (var i in occupation) {+ if (greatPowers[k] === occupation[i][0]+ && occupation[i][2] !== 'Build') {+ controlledUnits.push([i, occupation[i][1]]);+ }+ }+ var deficit = controlledUnits.length - controlledSupplyCentres.length;+ var atLeastOneOrder = false;+ if (deficit === 0) {+ // Everybody must continue; no need to show any controls.+ } else if (deficit > 0) {+ // Show disband options for all units; server should not accept+ // more disbands than the difference.+ // This is done via checkboxes for each unit.+ var span = document.createElement('span');+ var unitString = (deficit === 1) ? 'unit.' : 'units.';+ tdGreatPowerLabel.innerHTML = greatPowers[k] + ' must disband ' + String(deficit) + ' ' + unitString;+ for (var i in occupation) {+ if (greatPowers[k] === occupation[i][0]) {+ atLeastOneOrder = true;+ var orderEntry = makeOrderEntry({+ phase : 'Adjust',+ provinceTarget : i,+ greatPower : occupation[i][0],+ unit : occupation[i][1],+ deficit : deficit,+ orderObject : occupation[i][2]+ });+ orderEntries.push(orderEntry);+ var tr = document.createElement('tr');+ var tdl = document.createElement('td');+ tdl.appendChild(orderEntry.left);+ var tdr = document.createElement('td');+ tdr.appendChild(orderEntry.right);+ tr.appendChild(tdl);+ tr.appendChild(tdr);+ orderTable.appendChild(tr);+ }+ }+ } else {+ // Show build options for all home supply centres.+ // This is done via dropdowns for each unoccupied+ // home supply centre.+ // We take special care for St. Petersburg, in which we must+ // show options for itself and for both coasts.+ var unitString = (deficit === -1) ? 'unit.' : 'units.';+ tdGreatPowerLabel.innerHTML += ' may build at most ' + String(-deficit) + ' ' + unitString;+ for (var i in supplyCentres) {+ if ( ownership[i] === greatPowers[k]+ && control[i] === greatPowers[k]+ && (!occupation[i] || occupation[i][2] === 'Build')) {+ var orderEntry;+ if (i === 'St. Petersburg') {+ if ( (occupation['St. Petersburg NC'] && occupation['St. Petersburg NC'][2] !== 'Build')+ || (occupation['St. Petersburg SC'] && occupation['St. Petersburg SC'][2] !== 'Build')) {+ continue;+ } else {+ var atLeastOneOrder = true;+ // Special controls for the multi-coast home supply+ // centre: a 4-option dropdown+ // -+ // A+ // F (NC)+ // F (SC)+ var buildSubjectValue = '-';+ if (occupation['St. Petersburg NC'] && occupation['St. Petersburg NC'][2] === 'Build') {+ buildSubjectValue = 'F (NC)';+ } else if (occupation['St. Petersburg SC'] && occupation['St. Petersburg SC'][2] === 'Build') {+ buildSubjectValue = 'F (SC)';+ } else if (occupation['St. Petersburg'] && occupation['St. Petersburg'][2] === 'Build') {+ buildSubjectValue = 'A';+ }+ orderEntry = makeOrderEntry({+ phase : 'Adjust',+ provinceTarget : i,+ greatPower : greatPowers[k],+ buildSubjectValue : buildSubjectValue+ });+ }+ } else {+ atLeastOneOrder = true;+ var buildSubjectValue = '-';+ if (occupation[i] && occupation[i][2] === 'Build') {+ buildSubjectValue = occupation[i][1];+ }+ orderEntry = makeOrderEntry({+ phase : 'Adjust',+ provinceTarget : i,+ greatPower : greatPowers[k],+ buildSubjectValue : buildSubjectValue+ });+ }+ orderEntries.push(orderEntry);+ var tr = document.createElement('tr');+ var tdl = document.createElement('td');+ tdl.appendChild(orderEntry.left);+ var tdr = document.createElement('td');+ tdr.appendChild(orderEntry.right);+ tr.appendChild(tdl);+ tr.appendChild(tdr);+ orderTable.appendChild(tr);+ }+ }+ }+ if (!atLeastOneOrder) {+ orderTable.removeChild(trGreatPowerLabel);+ }+ }+ }+ orderForm.addEventListener('submit', function (in_event) {+ var orders = [];+ var order;+ for (var i in orderEntries) {+ order = orderEntries[i].getOrder();+ if (order === null) {+ } else {+ orders.push([order.greatPower, order.unit + ' ' + order.provinceTarget + ' ' + order.orderObject]);+ }+ }+ submitOrders(in_container, in_gameId, in_username, in_password, phase, orders, function () {+ fetchMetadata(in_gameId, in_username, in_password, function (in_error, in_metadata) {+ if (in_error) {+ uiPlay(in_container);+ } else {+ uiPlayGame(in_container, in_gameId, in_username, in_password, in_metadata);+ }+ });+ });+ in_event.preventDefault();+ in_event.stopPropagation();+ return false;+ });+ var submitButton = document.createElement('input');+ submitButton.type = 'submit';+ submitButton.value = 'Issue orders'+ orderForm.appendChild(submitButton);+ if (orderEntries.length > 0) {+ tdOrders.appendChild(orderForm);+ } else {+ var span = document.createElement('span');+ span.innerHTML = 'There\'s nothing to do.';+ tdOrders.appendChild(span);+ }+ } else {+ // A cheap visualization of the resolved orders.+ var ordersByGreatPower = {};+ for (var i in in_game.resolved) {+ ordersByGreatPower[in_game.resolved[i][0]] = ordersByGreatPower[in_game.resolved[i][0]] || [];+ var orderText = in_game.resolved[i][1] + ' ' + i + ' ' + in_game.resolved[i][2];+ ordersByGreatPower[in_game.resolved[i][0]].push({+ order : orderText,+ succeeded : in_game.resolved[i][3]+ });+ }+ var orderList = document.createElement('div');+ var index = 0;+ for (var i in ordersByGreatPower) {+ var div = document.createElement('div');+ if (index++ % 2 === 0) {+ div.style.backgroundColor = 'rgba(0,0,0,0)';+ } else {+ div.style.backgroundColor = 'rgba(0,0,0,0.0.05)';+ }+ var span = document.createElement('span');+ span.innerHTML = i;+ span.style.fontStyle = 'italic';+ div.appendChild(span);+ var orderTable = document.createElement('table');+ for (var j in ordersByGreatPower[i]) {+ var tr = document.createElement('tr');+ var tdl = document.createElement('td');+ var tdr = document.createElement('td');+ tdr.innerHTML = ordersByGreatPower[i][j].order;+ if (ordersByGreatPower[i][j].succeeded) {+ tdl.innerHTML = '✓';+ tr.style.color = 'green';+ } else {+ tdl.innerHTML = '✗';+ tr.style.color = 'red';+ }+ tr.appendChild(tdl);+ tr.appendChild(tdr);+ orderTable.appendChild(tr);+ }+ div.appendChild(orderTable);+ orderList.appendChild(div);+ }+ var somethingHappened = index > 0;+ if (somethingHappened) {+ tdOrders.appendChild(orderList);+ } else {+ var span = document.createElement('span');+ span.innerHTML = 'Nothing happened.';+ tdOrders.appendChild(span);+ }+ }++ return table;+ };++ var uiGameView = function (in_container, in_gameId, in_username, in_password, in_metadata, in_turn, in_round, in_game) {+ clearContainer(in_container);+ var metadataContainer = uiMetadata(in_container, in_gameId, in_username, in_password, in_metadata, in_turn, in_round);+ var gameDataContainer = uiGameData(in_container, in_gameId, in_username, in_password, in_metadata, in_round, in_game);+ metadataContainer.style.width = '100%';+ gameDataContainer.style.height = '100%';+ gameDataContainer.style.width = '100%';+ in_container.appendChild(metadataContainer);+ in_container.appendChild(gameDataContainer);+ };++ var joinGame = function (in_container, in_gameId, in_gamePassword, in_username, in_password, in_callback) {+ var xhr = new XMLHttpRequest();+ xhr.open('PUT', window.location + '/game/' + in_gameId + '/join');+ xhr.addEventListener('load', function (in_event) {+ if (xhr.status === 200) {+ in_callback(false);+ } else if (xhr.status === 404) {+ in_callback('Game not found');+ } else if (xhr.status === 403) {+ in_callback('Unauthorized');+ } else if (xhr.status === 401) {+ in_callback('Unauthorized');+ } else {+ in_callback('Unexpected error is unexpected');+ }+ });+ xhr.addEventListener('error', function (in_event) {+ in_callback('Unexpected error is unexpected');+ });+ xhr.addEventListener('abort', function (in_event) {+ in_callback('Unexpected error is unexpected');+ });+ xhr.setRequestHeader('Content-Type', 'application/json');+ var credentials = {+ username : in_username,+ password : in_password+ };+ var data = {+ gameId : in_gameId,+ password : in_gamePassword,+ credentials : credentials+ }+ xhr.send(JSON.stringify(data));+ };++ var fetch = function (in_method, in_route, in_data, in_callback) {+ var xhr = new XMLHttpRequest();+ xhr.open(in_method, in_route);+ xhr.addEventListener('load', function (in_event) {+ if (xhr.status === 200) {+ var response = xhr.response;+ if (xhr.response === undefined) {+ // Some browser don't define response...+ response = xhr.responseText;+ }+ in_callback(false, JSON.parse(response));+ } else {+ in_callback(true);+ }+ });+ xhr.addEventListener('error', function (in_event) {+ in_callback(ture);+ });+ xhr.addEventListener('abort', function (in_event) {+ in_callback(ture);+ });+ xhr.setRequestHeader('Content-Type', 'application/json');+ xhr.send(JSON.stringify(in_data));+ };++ var fetchMetadata = function (in_gameId, in_username, in_password, in_callback) {+ var route = window.location + '/game/' + in_gameId + '/metadata';+ var data = {+ username : in_username,+ password : in_password+ };+ fetch('PUT', route, data, in_callback);+ };++ var fetchResolution = function (in_gameId, in_username, in_password, in_turn, in_round, in_callback) {+ var route = window.location + '/game/' + in_gameId + '/resolution?turn=' + in_turn + '&round=' + in_round;+ var data = {+ username : in_username,+ password : in_password+ };+ fetch('PUT', route, data, in_callback);+ };++ var fetchGame = function (in_gameId, in_username, in_password, in_callback) {+ var route = window.location + '/game/' + in_gameId;+ var data = {+ username : in_username,+ password : in_password+ };+ fetch('PUT', route, data, in_callback);+ };++ var createGame = function (in_container, in_gameId, in_gamePassword, in_gameDuration, in_gameSecondDuration, in_username, in_password, in_callback) {+ var xhr = new XMLHttpRequest();+ xhr.open('POST', window.location + '/game/');+ xhr.addEventListener('load', function (in_event) {+ if (xhr.status === 200) {+ in_callback(false);+ } else if (xhr.status === 403) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else if (xhr.status === 401) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else {+ uiError(in_container, 'Unexpected error is unexpected', function () {+ in_callback(true);+ });+ }+ });+ xhr.addEventListener('error', function (in_event) {+ uiError(in_container, 'Unexpected error is unexpected', function () {+ in_callback(true);+ });+ });+ xhr.addEventListener('abort', function (in_event) {+ uiError(in_container, 'Unexpected error is unexpected', function () {+ in_callback(true);+ });+ });+ xhr.setRequestHeader('Content-Type', 'application/json');+ var credentials = {+ username : in_username,+ password : in_password+ };+ var data = {+ gameId : in_gameId,+ gamePassword : in_gamePassword,+ gameDuration : in_gameDuration,+ gameSecondDuration : in_gameSecondDuration,+ credentials : credentials+ };+ xhr.send(JSON.stringify(data));+ };++ var startGame = function (in_container, in_gameId, in_username, in_password, in_callback) {+ var xhr = new XMLHttpRequest();+ xhr.open('PUT', window.location + '/game/' + in_gameId + '/start');+ xhr.addEventListener('load', function (in_event) {+ if (xhr.status === 200) {+ in_callback(false);+ } else if (xhr.status === 404) {+ uiError(in_container, 'Game not found', function () {+ in_callback(true);+ });+ } else if (xhr.status === 403) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else if (xhr.status === 401) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else {+ uiError(in_container, 'Expected error is unexpected', function () {+ in_callback(true);+ });+ }+ });+ xhr.addEventListener('error', function (in_event) {+ uiError(in_container, 'Expected error is unexpected', function () {+ in_callback(true);+ });+ });+ xhr.addEventListener('abort', function (in_event) {+ uiError(in_container, 'Expected error is unexpected', function () {+ in_callback(true);+ });+ });+ xhr.setRequestHeader('Content-Type', 'application/json');+ var credentials = {+ username : in_username,+ password : in_password+ };+ xhr.send(JSON.stringify(credentials));+ };++ var advanceGame = function (in_container, in_gameId, in_username, in_password, in_callback) {+ var xhr = new XMLHttpRequest();+ xhr.open('PUT', window.location + '/game/' + in_gameId + '/advance');+ xhr.addEventListener('load', function (in_event) {+ if (xhr.status === 200) {+ in_callback(false);+ } else if (xhr.status === 404) {+ uiError(in_container, 'Game not found', function () {+ in_callback(true);+ });+ } else if (xhr.status === 403) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else if (xhr.status === 401) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else {+ uiError(in_container, 'Expected error is unexpected', function () {+ in_callback(true);+ });+ }+ });+ xhr.addEventListener('error', function (in_event) {+ uiError(in_container, 'Expected error is unexpected', function () {+ in_callback(true);+ });+ });+ xhr.addEventListener('abort', function (in_event) {+ uiError(in_container, 'Expected error is unexpected', function () {+ in_callback(true);+ });+ });+ xhr.setRequestHeader('Content-Type', 'application/json');+ var credentials = {+ username : in_username,+ password : in_password+ };+ xhr.send(JSON.stringify(credentials));+ };++ var pauseGame = function (in_container, in_gameId, in_username, in_password, in_callback) {+ var route = window.location + '/game/' + in_gameId + '/pause';+ var data = {+ username : in_username,+ password : in_password+ };+ fetch('PUT', route, data, in_callback);+ };++ var destroyGame = function (in_container, in_gameId, in_username, in_password, in_callback) {+ var xhr = new XMLHttpRequest();+ xhr.open('DELETE', window.location + '/game/' + in_gameId);+ xhr.addEventListener('load', function (in_event) {+ if (xhr.status === 200) {+ in_callback(false);+ } else if (xhr.status === 404) {+ uiError(in_container, 'Game not found', function () {+ in_callback(true);+ });+ } else if (xhr.status === 403) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else if (xhr.status === 401) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else {+ uiError(in_container, 'Unexpected error is unexpected', function () {+ in_callback(true);+ });+ }+ });+ xhr.addEventListener('error', function (in_event) {+ in_callback('Unexpected error is unexpected');+ });+ xhr.addEventListener('abort', function (in_event) {+ in_callback('Unexpected error is unexpected');+ });+ xhr.setRequestHeader('Content-Type', 'application/json');+ var credentials = {+ username : in_username,+ password : in_password+ };+ xhr.send(JSON.stringify(credentials));+ };++ var submitOrders = function (in_container, in_gameId, in_username, in_password, in_phase, in_orders, in_callback) {+ var xhr = new XMLHttpRequest();+ xhr.open('PUT', window.location + '/game/' + in_gameId + '/order');+ xhr.addEventListener('load', function (in_event) {+ if (xhr.status === 200) {+ in_callback(false);+ } else if (xhr.status === 404) {+ uiError(in_container, 'Game not found', function () {+ in_callback(true);+ });+ } else if (xhr.status === 403) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else if (xhr.status === 401) {+ uiError(in_container, 'Unauthorized', function () {+ in_callback(true);+ });+ } else {+ uiError(in_container, 'Expected error is unexpected', function () {+ in_callback(true);+ });+ }+ });+ xhr.addEventListener('error', function (in_event) {+ uiError(in_container, 'Expected error is unexpected', function () {+ in_callback(true);+ });+ });+ xhr.addEventListener('abort', function (in_event) {+ uiError(in_container, 'Expected error is unexpected', function () {+ in_callback(true);+ });+ });+ xhr.setRequestHeader('Content-Type', 'application/json');+ var credentials = {+ username : in_username,+ password : in_password+ };+ var orders = {+ tag : in_phase,+ contents : in_orders+ };+ var data = {+ orders : orders,+ credentials : credentials+ };+ xhr.send(JSON.stringify(data));+ };++ var makeOrderEntry = function (in_data) {+ var ret = {+ left : undefined,+ right : undefined,+ getOrder : undefined+ };+ if (in_data.phase === 'Adjust') {+ if (in_data.deficit === 0) {+ } else if (in_data.deficit > 0) {+ var orderSubjectLabel = document.createElement('span');+ orderSubjectLabel.innerHTML = in_data.unit + ' ' + in_data.provinceTarget;+ var orderObjectInput = document.createElement('input');+ orderObjectInput.type = 'checkbox';+ if (in_data.orderObject === 'Disband') {+ orderObjectInput.checked = true;+ } else {+ orderObjectInput.checked = false;+ }+ ret.left = orderSubjectLabel;+ ret.right = orderObjectInput;+ ret.getOrder = function () {+ return {+ greatPower : in_data.greatPower,+ unit : in_data.unit,+ provinceTarget : in_data.provinceTarget,+ orderObject : (orderObjectInput.checked) ? 'Disband' : 'Continue'+ };+ };+ } else {+ var orderObjectLabel = document.createElement('span');+ orderObjectLabel.innerHTML = in_data.provinceTarget + ' Build';+ var orderSubjectInput = document.createElement('select');+ var selectionNone = document.createElement('option');+ selectionNone.innerHTML = '-';+ selectionNone.value = '-';+ orderSubjectInput.appendChild(selectionNone);+ var selectionArmy = document.createElement('option');+ selectionArmy.innerHTML = 'A';+ selectionArmy.value = 'A';+ orderSubjectInput.appendChild(selectionArmy);+ if (in_data.provinceTarget === 'St. Petersburg') {+ var selectionFleetNC = document.createElement('option');+ selectionFleetNC.innerHTML = 'F (NC)';+ selectionFleetNC.value = 'F (NC)';+ orderSubjectInput.appendChild(selectionFleetNC);+ var selectionFleetSC = document.createElement('option');+ selectionFleetSC.innerHTML = 'F (SC)';+ selectionFleetSC.value = 'F (SC)';+ orderSubjectInput.appendChild(selectionFleetSC);+ } else if (coastalHomeSupplyCentres[in_data.provinceTarget]) {+ var selectionFleet = document.createElement('option');+ selectionFleet.innerHTML = 'F';+ selectionFleet.value = 'F';+ orderSubjectInput.appendChild(selectionFleet);+ }+ orderSubjectInput.value = in_data.buildSubjectValue;+ ret.left = orderSubjectInput;+ ret.right = orderObjectLabel;+ ret.getOrder = function () {+ if (orderSubjectInput.value === 'A' || orderSubjectInput.value === 'F') {+ return {+ greatPower : in_data.greatPower,+ unit : orderSubjectInput.value,+ provinceTarget : in_data.provinceTarget,+ orderObject : 'Build'+ };+ } else if (orderSubjectInput.value === 'F (NC)') {+ return {+ greatPower : in_data.greatPower,+ unit : 'F',+ provinceTarget : in_data.provinceTarget + ' NC',+ orderObject : 'Build'+ };+ } else if (orderSubjectInput.value === 'F (SC)') {+ return {+ greatPower : in_data.greatPower,+ unit : 'F',+ provinceTarget : in_data.provinceTarget + ' SC',+ orderObject : 'Build'+ };+ } else {+ return null;+ }+ };+ }+ } else {+ var orderSubjectLabel = document.createElement('span');+ orderSubjectLabel.innerHTML = in_data.unit + ' ' + in_data.provinceTarget;+ var orderObjectInput = document.createElement('input');+ if (in_data.orderObject) {+ orderObjectInput.value = in_data.orderObject;+ }+ orderObjectInput.addEventListener('click', function () {+ this.select();+ });+ ret.left = orderSubjectLabel;+ ret.right = orderObjectInput;+ ret.getOrder = function () {+ return {+ greatPower : in_data.greatPower,+ unit : in_data.unit,+ provinceTarget : in_data.provinceTarget,+ orderObject : orderObjectInput.value+ };+ };+ }+ return ret;+ };++ var button = function (in_text, in_click) {+ var div = document.createElement('div');+ div.innerHTML = in_text;+ div.style.width = '100%';+ div.style.backgroundColor = 'rgba(255,255,255,1)';+ div.style.padding = '10px 10px 10px 10px';+ div.addEventListener('mouseenter', function () {+ div.style.backgroundColor = 'rgba(0,0,0,0.2)';+ });+ div.addEventListener('mouseleave', function () {+ div.style.backgroundColor = 'rgba(255,255,255,1)';+ });+ div.addEventListener('click', function () {+ in_click();+ });+ return div;+ };++ var buttons = function (in_buttons) {+ var ul = document.createElement('ul');+ ul.style.display = 'table';+ ul.style.tableLayout = 'fixed';+ ul.style.width = '100%';+ ul.style.height = '100%';+ ul.style.padding = 0;+ ul.style.margin = 0;+ for (var i = 0; i < in_buttons.length; ++i) {+ var thisButton = button(in_buttons[i].text, in_buttons[i].click);+ thisButton.style.display = 'table-cell';+ thisButton.style.verticalAlign = 'middle';+ var li = document.createElement('li');+ li.style.display = 'table-row';+ li.style.textAlign = 'center';+ li.appendChild(thisButton);+ ul.appendChild(li);+ }+ return ul;+ };++ var uiInput = function (in_container, in_label, in_type, in_callback) {+ var ul = document.createElement('ul');+ ul.style.display = 'table';+ ul.style.tableLayout = 'fixed';+ ul.style.width = '100%';+ ul.style.height = '100%';+ ul.style.padding = 0;+ ul.style.margin = 0;+ var label = document.createElement('div');+ label.innerHTML = in_label;+ label.style.display = 'table-cell';+ label.style.verticalAlign = 'middle';+ var li1 = document.createElement('li');+ li1.style.display = 'table-row';+ li1.style.textAlign = 'center';+ li1.appendChild(label);+ ul.appendChild(li1);+ var input = document.createElement('input');+ input.type = in_type;+ input.style.display = 'table-cell';+ input.style.verticalAlign = 'middle';+ var li2 = document.createElement('li');+ li2.style.display = 'table-row';+ li2.style.textAlign = 'center';+ li2.appendChild(input);+ ul.appendChild(li2);+ var form = document.createElement('form');+ form.appendChild(ul);+ form.addEventListener('submit', function (in_event) {+ in_callback(input.value);+ in_event.preventDefault();+ in_event.stopPropagation();+ return false;+ });+ clearContainer(in_container);+ in_container.appendChild(form);+ input.focus();+ };++ var uiError = function (in_container, in_description, in_callback) {+ var ul = document.createElement('ul');+ ul.style.display = 'table';+ ul.style.tableLayout = 'fixed';+ ul.style.width = '100%';+ ul.style.height = '100%';+ ul.style.padding = 0;+ ul.style.margin = 0;+ var li1 = document.createElement('li');+ li1.style.display = 'table-row';+ li1.style.textAlign = 'center';+ var li2 = document.createElement('li');+ li2.style.display = 'table-row';+ li2.style.textAlign = 'center';+ var li3 = document.createElement('li');+ li3.style.display = 'table-row';+ li3.style.textAlign = 'center';+ var divError = document.createElement('div');+ divError.innerHTML = 'A diplomatic error!';+ divError.style.color = 'red';+ divError.style.display = 'table-cell';+ divError.style.verticalAlign = 'middle';+ var divDescription = document.createElement('div');+ divDescription.innerHTML = in_description;+ divDescription.style.display = 'table-cell';+ divDescription.style.verticalAlign = 'middle';+ var divContinue = button('I understand ...', in_callback);+ divContinue.style.display = 'table-cell';+ divContinue.style.verticalAlign = 'middle';+ li1.appendChild(divError);+ li2.appendChild(divDescription);+ li3.appendChild(divContinue);+ ul.appendChild(li1);+ ul.appendChild(li2);+ ul.appendChild(li3);+ clearContainer(in_container);+ in_container.appendChild(ul);+ };++ var svgArmy = function (in_greatPower, in_location) {+ var g = document.createElementNS('http://www.w3.org/2000/svg', 'g');+ var path1 = document.createElementNS('http://www.w3.org/2000/svg', 'path');+ var path2 = document.createElementNS('http://www.w3.org/2000/svg', 'path');+ var circle = document.createElementNS('http://www.w3.org/2000/svg', 'circle');+ path1.setAttribute('d', 'M9,-6 L2,0 M9,6 L0,0');+ path2.setAttribute('d', 'M-11,-6 v4 h17 a2,2 0,0 0 0,-4z');+ circle.setAttribute('r', '6');+ g.appendChild(path1);+ g.appendChild(path2);+ g.appendChild(circle);+ g.setAttributeNS(null, 'class', in_greatPower);+ var translation = 'translate(' + in_location.x + ',' + in_location.y + ')';+ g.setAttribute('transform', translation);+ return g;+ };++ var svgFleet = function (in_greatPower, in_location) {+ var g = document.createElementNS('http://www.w3.org/2000/svg', 'g');+ var polygon1 = document.createElementNS('http://www.w3.org/2000/svg', 'polygon');+ var polygon2 = document.createElementNS('http://www.w3.org/2000/svg', 'polygon');+ polygon1.setAttributeNS(null, 'points', '-2,-3 10,-3 -2,-13');+ polygon2.setAttributeNS(null, 'points', '-12,-1 -6,5 6,5 12,-1');+ g.appendChild(polygon1);+ g.appendChild(polygon2);+ g.setAttributeNS(null, 'class', in_greatPower);+ var translation = 'translate(' + in_location.x + ',' + in_location.y + ')';+ g.setAttributeNS(null, 'transform', translation);+ return g;+ };++ var supplyCentres = {+ 'Norway' : true,+ 'Sweden' : true,+ 'Denmark' : true,+ 'St. Petersburg' : true,+ 'Moscow' : true,+ 'Sevastopol' : true,+ 'Ankara' : true,+ 'Smyrna' : true,+ 'Constantinople' : true,+ 'Rumania' : true,+ 'Bulgaria' : true,+ 'Greece' : true,+ 'Serbia' : true,+ 'Warsaw' : true,+ 'Budapest' : true,+ 'Vienna' : true,+ 'Trieste' : true,+ 'Berlin' : true,+ 'Kiel' : true,+ 'Munich' : true,+ 'Venice' : true,+ 'Rome' : true,+ 'Naples' : true,+ 'Tunis' : true,+ 'Spain' : true,+ 'Portugal' : true,+ 'Marseilles' : true,+ 'Paris' : true,+ 'Brest' : true,+ 'Belgium' : true,+ 'Holland' : true,+ 'London' : true,+ 'Liverpool' : true,+ 'Edinburgh' : true+ };++ var coastalHomeSupplyCentres = {+ // We don't include st. petersburg, since it has two coasts where+ // fleets must go, and we handle it in a special case elsewhere.+ //'St. Petersburg' : true,+ 'Sevastopol' : true,+ 'Ankara' : true,+ 'Smyrna' : true,+ 'Constantinople' : true,+ 'Trieste' : true,+ 'Venice' : true,+ 'Rome' : true,+ 'Naples' : true,+ 'Berlin' : true,+ 'Kiel' : true,+ 'Marseilles' : true,+ 'Brest' : true,+ 'Liverpool' : true,+ 'London' : true,+ 'Edinburgh' : true+ };++ var ownership = {+ 'Bohemia' : 'Austria',+ 'Budapest' : 'Austria',+ 'Galicia' : 'Austria',+ 'Trieste' : 'Austria',+ 'Tyrolia' : 'Austria',+ 'Vienna' : 'Austria',+ 'Clyde' : 'Austria',+ 'Edinburgh' : 'England',+ 'Liverpool' : 'England',+ 'London' : 'England',+ 'Wales' : 'England',+ 'Yorkshire' : 'England',+ 'Brest' : 'France',+ 'Burgundy' : 'France',+ 'Gascony' : 'France',+ 'Marseilles' : 'France',+ 'Paris' : 'France',+ 'Picardy' : 'France',+ 'Berlin' : 'Germany',+ 'Kiel' : 'Germany',+ 'Munich' : 'Germany',+ 'Prussia' : 'Germany',+ 'Ruhr' : 'Germany',+ 'Silesia' : 'Germany',+ 'Apulia' : 'Italy',+ 'Naples' : 'Italy',+ 'Piedmont' : 'Italy',+ 'Rome' : 'Italy',+ 'Tuscany' : 'Italy',+ 'Venice' : 'Italy',+ 'Livonia' : 'Russia',+ 'Moscow' : 'Russia',+ 'Sevastopol' : 'Russia',+ 'St. Petersburg' : 'Russia',+ 'Ukraine' : 'Russia',+ 'Warsaw' : 'Russia',+ 'Ankara' : 'Turkey',+ 'Armenia' : 'Turkey',+ 'Constantinople' : 'Turkey',+ 'Smyrna' : 'Turkey',+ 'Syria' : 'Turkey'+ };++ var unitOccupationLocationMap = {+ 'Adriatic Sea' : { x : 296, y : 441 },+ 'Aegean Sea' : { x : 403, y : 524 },+ 'Albania' : { x : 339, y : 469 },+ 'Ankara' : { x : 500, y : 460 },+ 'Apulia' : { x : 302, y : 472 },+ 'Armenia' : { x : 576, y : 456 },+ 'Baltic Sea' : { x : 323, y : 250 },+ 'Barents Sea' : { x : 445, y : 41 },+ 'Belgium' : { x : 197, y : 317 },+ 'Berlin' : { x : 279, y : 283 },+ 'Black Sea' : { x : 484, y : 420 },+ 'Bohemia' : { x : 289, y : 336 },+ 'Brest' : { x : 125, y : 334 },+ 'Budapest' : { x : 353, y : 378 },+ 'Bulgaria' : { x : 395, y : 443 },+ 'Bulgaria EC' : { x : 410, y : 440 },+ 'Bulgaria SC' : { x : 399, y : 462 },+ 'Burgundy' : { x : 191, y : 360 },+ 'Clyde' : { x : 139, y : 188 },+ 'Constantinople' : { x : 439, y : 473 },+ 'Denmark' : { x : 256, y : 245 },+ 'Eastern Mediterranean' : { x : 474, y : 546 },+ 'Edinburgh' : { x : 157, y : 210 },+ 'English Channel' : { x : 119, y : 307 },+ 'Finland' : { x : 385, y : 143 },+ 'Galicia' : { x : 377, y : 343 },+ 'Gascony' : { x : 137, y : 388 },+ 'Greece' : { x : 366, y : 515 },+ 'Gulf of Lyon' : { x : 180, y : 444 },+ 'Gulf of Bothnia' : { x : 348, y : 199 },+ 'Heligoland Bight' : { x : 226, y : 252 },+ 'Holland' : { x : 205, y : 297 },+ 'Ionian Sea' : { x : 324, y : 540 },+ 'Irish Sea' : { x : 90, y : 276 },+ 'Kiel' : { x : 243, y : 295 },+ 'Liverpool' : { x : 142, y : 241 },+ 'Livonia' : { x : 382, y : 254 },+ 'London' : { x : 162, y : 281 },+ 'Marseilles' : { x : 184, y : 402 },+ 'Mid-Atlantic Ocean' : { x : 23, y : 355 },+ 'Moscow' : { x : 505, y : 226 },+ 'Munich' : { x : 243, y : 347 },+ 'Naples' : { x : 299, y : 505 },+ 'North Atlantic Ocean' : { x : 65, y : 140 },+ 'North Africa' : { x : 100, y : 536 },+ 'North Sea' : { x : 204, y : 215 },+ 'Norway' : { x : 264, y : 160 },+ 'Norwegian Sea' : { x : 220, y : 90 },+ 'Paris' : { x : 162, y : 346 },+ 'Picardy' : { x : 168, y : 319 },+ 'Piedmont' : { x : 220, y : 399 },+ 'Portugal' : { x : 34, y : 417 },+ 'Prussia' : { x : 315, y : 283 },+ 'Rome' : { x : 264, y : 452 },+ 'Ruhr' : { x : 223, y : 320 },+ 'Rumania' : { x : 415, y : 405 },+ 'Serbia' : { x : 351, y : 438 },+ 'Sevastopol' : { x : 515, y : 330 },+ 'Silesia' : { x : 304, y : 314 },+ 'Skagerrak' : { x : 260, y : 212 },+ 'Smyrna' : { x : 490, y : 505 },+ 'Spain' : { x : 64, y : 439 },+ 'Spain NC' : { x : 80, y : 404 },+ 'Spain SC' : { x : 52, y : 475 },+ 'St. Petersburg' : { x : 500, y : 140 },+ 'St. Petersburg NC' : { x : 472, y : 122 },+ 'St. Petersburg SC' : { x : 418, y : 205 },+ 'Sweden' : { x : 315, y : 140 },+ 'Syria' : { x : 570, y : 520 },+ 'Trieste' : { x : 305, y : 412 },+ 'Tunis' : { x : 212, y : 542 },+ 'Tuscany' : { x : 247, y : 430 },+ 'Tyrolia' : { x : 277, y : 378 },+ 'Tyrrhenian Sea' : { x : 246, y : 483 },+ 'Ukraine' : { x : 427, y : 327 },+ 'Venice' : { x : 250, y : 408 },+ 'Vienna' : { x : 314, y : 360 },+ 'Wales' : { x : 125, y : 285 },+ 'Warsaw' : { x : 361, y : 315 },+ 'Western Mediterranean' : { x : 140, y : 492 },+ 'Yorkshire' : { x : 161, y : 254 }+ };++ var unitOccupationLocation = function (in_provinceTarget) {+ return unitOccupationLocationMap[in_provinceTarget];+ };++ var unitDislodgementLocation = function (in_provinceTarget) {+ var loc = unitOccupationLocation(in_provinceTarget);+ return {+ x : loc.x - 5,+ y : loc.y - 5+ };+ };++ window.onload = function () {+ window.svgMap = document.getElementById('map');+ window.svgMap.style.display = 'none';+ window.svgMap.armies = [];+ window.svgMap.fleets = [];+ document.body.innerWidth = window.innerWidth;+ document.body.innerHeight = window.innerHeight;+ uiInitial(document.body);+ window.requestAnimationFrame(animate);+ };++ </script>++ <svg style="display: none;" id="map" viewBox="0 0 610 560" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+ <title>Diplomacy</title>+ <desc>+ Variant SVG coding 2006 by Martin Asal+ Copyright: CC-BY-SA-3.0-DE (http://creativecommons.org/licenses/by-sa/3.0/deed.de)+ Created for Diplomap (http://www.games2relax.net/diplomap/)+ </desc>++ <defs>+ <style type="text/css">+ <![CDATA[+ .l, .Unowned {fill:#FFFFDD; stroke:black; stroke-linejoin:round}+ .w {fill:#99CCFF; stroke:black; stroke-linejoin:round}+ .s {fill:#DDDDDD; stroke:black; stroke-linejoin:round}++ text {font-family:Arial,Helvetica,sans-serif; font-size:8px}++ .Austria {fill:#FF0000; stroke:black}+ .England {fill:#0000FF; stroke:black}+ .France {fill:#00FFFF; stroke:black}+ .Germany {fill:#808080; stroke:black}+ .Italy {fill:#00FF00; stroke:black}+ .Russia {fill:#008000; stroke:black}+ .Turkey {fill:#FFFF00; stroke:black}+ ]]>+ </style>+ </defs>++ <g id="Norwegian Sea" title="Norwegian Sea">+ <polygon class="w" points="362,33 357,39 343,44 324,54 320,64 310,75 309,84 303,86 292,111 277,132 269,134 264,142 258,141 236,154 198,154 171,181 171,197 158,193 152,194 154,188 161,185 162,181+ 148,177 148,0 362,0"/>+ <text x="220" y="70">Nrg</text>+ </g>+ <g id="North Sea" title="North Sea">+ <path class="w" d="M171,197 L171,181 A27,27 0,0,1 198,154 L241,154 L241,224 L248,224 L245,237 L211,237 L211,301 L173,301 L165,293 L140,197Z"/>+ <text x="190" y="230">Nth</text>+ </g>++ <g id="Switzerland" title="Switzerland">+ <polygon class="s" points="209,363 208,367 194,382 197,385 203,379 207,386 213,387 221,385 227,390 229,385 243,388 245,384 241,378 234,374 234,366 232,363 225,362 222,365"/>+ <text x="215" y="378">Swi</text>+ </g>+ <g id="Adriatic Sea" title="Adriatic Sea">+ <polygon class="w" points="322,480 297,456 300,453 290,453 278,443 272,424 260,417 261,401 270,398 276,399 275,403 278,410 282,401 286,402 289,418 306,436 331,454 331,477 335,480"/>+ <text x="308" y="460">Adr</text>+ </g>+ <g id="Aegean Sea" title="Aegean Sea">+ <polygon class="w" points="376,537 371,520 378,521 377,513 386,516 385,509 370,494 371,491 378,494 368,483 371,477 379,484 382,483 381,477 386,478 380,472 392,472 400,468 408,470 410,473 414,475+ 410,482 409,487 417,486 417,489 420,495 417,498 417,507 423,510 427,524 435,523 435,530 416,549 412,547 387,546 383,544"/>+ <text x="392" y="510">Aeg</text>+ </g>+ <g id="Albania" title="Albania">+ <polygon class="l" points="331,454 331,477 335,480 339,487 350,477 350,471 346,466 346,452 337,446 330,445"/>+ <text x="333" y="460">Alb</text>+ </g>+ <g id="Ankara" title="Ankara">+ <polygon class="l" points="555,438 551,437 520,441 514,438 511,440 502,433 481,438 470,447 464,457 468,461 468,479 466,491 473,491 490,480 501,482 508,480 531,460 546,462 555,460 557,449"/> + <text x="510" y="455">Ank</text>+ </g>+ <g id="Apulia" title="Apulia">+ <polygon class="l" points="304,484 310,480 318,485 322,485 322,480 297,456 300,453 290,453 278,443 274,447 279,451 280,455 279,458 293,481"/>+ <text x="291" y="470">Apu</text>+ </g>+ <g id="Armenia" title="Armenia">+ <polygon class="l" points="609,493 584,478 563,479 562,471 556,467 555,460 557,449 555,438 570,427 589,442 594,439 603,441 609,440"/>+ <text x="585" y="467">Arm</text>+ </g>+ <g id="Baltic Sea" title="Baltic Sea">+ <polygon class="w" points="266,255 271,260 278,254 277,250 280,248 279,243 282,253 289,254 294,245 305,244 312,229 311,220 359,220 349,229 347,243 347,248 348,254 344,262 337,264 334,273 328,274+ 326,265 314,266 307,273 294,275 286,274 287,267 280,266 266,275 261,274 260,269 256,266 256,263 254,255"/>+ <text x="308" y="260">Bal</text>+ </g>+ <g id="Barents Sea" title="Barents Sea">+ <polygon class="w" points="540 0 535,9 530,6 517,19 516,33 513,38 513,23 507,20 505,26 499,33 492,48 495,58 488,60 479,57 477,55 481,50 473,43 466,45 472,62 478,66 478,74 472,72 468,74 457,91+ 469,100 467,106 462,109 444,101 442,110 447,115 454,119 452,122 434,118 426,103 426,94 414,88 412,83 445,84 457,79 459,66 453,61 417,47 405,49 401,45 397,48 391,47 395,41 394,38 384,33 382,40+ 380,33 377,31 374,38 371,33 366,42 366,33 362,33 362,0"/>+ <text x="440" y="15">Bar</text>+ </g>+ <g id="Belgium" title="Belgium">+ <polygon class="l" points="191,299 194,303 206,306 205,311 208,315 210,326 205,331 192,323 184,315 169,311 173,301"/>+ <text x="192" y="321">Bel</text>+ </g>+ <g id="Berlin" title="Berlin">+ <polygon class="l" points="294,275 286,274 287,267 280,266 266,275 266,283 262,287 264,293 261,296 263,310 288,305 296,300 297,296 292,290"/>+ <text x="272" y="292">Ber</text>+ </g>+ <g id="Black Sea" title="Black Sea">+ <polygon class="w" points="440,458 430,455 426,450 422,441 425,427 429,426 430,423 432,409 439,404 438,397 446,378 459,375 461,377 459,379 465,383 476,381 478,383 472,385 468,392 477,396 477,401+ 486,404 488,397 494,396 497,392 507,389 506,384 494,387 485,378 503,364 526,351 527,354 514,365 517,371 520,371 515,384 511,383 510,386 517,393 528,394 554,406 567,408 573,417 570,427 555,438+ 551,437 520,441 514,438 511,440 502,433 481,438 470,447 464,457 442,460"/>+ <text x="500" y="418">Bla</text>+ </g>+ <g id="Bohemia" title="Bohemia">+ <polygon class="l" points="281,356 276,346 268,343 264,329 266,325 278,326 288,321 297,322 311,334 314,332 321,339 322,347 316,348 303,346 295,349 292,357"/>+ <text x="283" y="347">Boh</text>+ </g>+ <g id="Brest" title="Brest">+ <polygon class="l" points="150,319 144,318 142,312 136,310 136,326 124,323 122,318 102,317 100,322 103,328 109,329 123,344 122,350 123,357 128,363 146,365 146,337 148,329"/>+ <text x="130" y="345">Bre</text>+ </g>+ <g id="Budapest" title="Budapest">+ <polygon class="l" points="394,376 395,382 401,385 406,396 401,402 387,402 367,406 365,412 360,413 342,410 338,412 335,410 332,410 323,408 321,398 311,394 308,383 311,375 322,370 335,354 337,350+ 350,347 360,351 368,353 377,360 378,363 384,365"/>+ <text x="350" y="390">Bud</text>+ </g>+ <g id="Bulgaria EC" title="Bulgaria (ec)">+ <polyline class="l" points="413,464 412,454 420,451 426,450 422,441 425,427 429,426 430,423 422,420 410,420 404,422 398,427 390,425 382,427 375,423 370,425 367,421 365,425 368,433 371,438"/>+ <text x="395" y="443">Bul</text>+ </g>+ <g id="Bulgaria SC" title="Bulgaria (sc)">+ <polyline class="l" points="371,438 366,439 371,456 365,461 369,464 376,464 388,460 392,472 400,468 408,470 413,464 412,454"/>+ </g>+ <g id="Burgundy" title="Burgundy">+ <polygon class="l" points="192,323 205,331 204,338 211,346 213,352 209,363 208,367 194,382 178,381 178,390 173,396 168,395 163,387 165,383 158,380 156,374 165,365 185,344 188,332"/>+ <text x="185" y="371">Bur</text>+ </g>+ <g id="Clyde" title="Clyde">+ <polygon class="l" points="138,214 130,208 129,197 139,189 140,182 148,177 162,181 161,185 154,188 152,194 146,200 144,213"/>+ <text x="133" y="201">Cly</text>+ </g>+ <g id="Constantinople" title="Constantinople">+ <polygon class="l" points="408,470 410,473 414,475 410,482 409,487 417,486 417,489 423,487 432,493 452,495 466,491 468,479 468,461 464,457 442,460 440,458 430,455 426,450 420,451 412,454 413,464"/>+ <polygon class="w" points="414,475 421,467 435,463 440,458 442,460 439,463 448,464 425,475"/>+ <text x="435" y="483">Con</text>+ </g>+ <g id="Denmark" title="Denmark">+ <polygon class="l" points="279,243 275,242 269,243 266,240 267,234 266,221 263,223 248,224 245,237 243,247 244,254 254,255 266,255 271,260 278,254 277,250 280,248 "/>+ <polygon class="w" points="269,243 268,246 263,247 266,255 254,255 257,247 266,240"/>+ <text x="250" y="235">Den</text>+ </g>+ <g id="Eastern Mediterranean" title="Eastern Mediterranean">+ <polygon class="w" points="435,530 441,526 447,528 453,534 464,531 466,521 475,520 485,528 491,530 505,526 511,514 520,517 527,508 530,509 525,518 526,530 532,535 528,559 400,559 400,554 414,552 416,549"/>+ <text x="455" y="550">Eas</text>+ </g>+ <g id="Edinburgh" title="Edinburgh">+ <polygon class="l" points="152,194 158,193 171,197 170,202 165,210 158,214 151,215 157,216 161,218 163,226 155,228 145,217 144,213 146,200"/>+ <text x="152" y="202">Edi</text>+ </g>+ <g id="English Channel" title="English Channel">+ <polygon class="w" points="173,301 169,311 153,315 155,320 150,319 144,318 142,312 136,310 136,326 124,323 122,318 102,317 88,303 100,291 110,292 120,295 124,291 134,294 147,295 160,298 168,296"/>+ <text x="135" y="306">Eng</text>+ </g>+ <g id="Finland" title="Finland">+ <polygon class="l" points="362,107 368,108 372,120 366,121 359,136 345,151 347,160 350,165 348,178 349,184 357,186 365,191 384,185 402,177 412,161 410,152 414,147 410,130 402,118 401,110 392,92+ 393,73 387,68 388,61 386,58 388,54 379,48 370,49 369,61 355,62 346,54 342,61 356,71"/>+ <text x="375" y="160">Fin</text>+ </g>+ <g id="Galicia" title="Galicia">+ <polygon class="l" points="333,330 341,330 344,332 353,327 356,323 361,324 367,329 374,327 379,324 383,327 385,332 399,338 404,354 403,360 404,371 394,376 384,365 378,363 377,360 368,353 360,351+ 350,347 337,350 329,346 322,347 321,339 322,347 321,339 325,340 329,338"/>+ <text x="355" y="343">Gal</text>+ </g>+ <g id="Gascony" title="Gascony">+ <polygon class="l" points="128,363 121,382 122,384 112,399 113,407 123,412 134,417 135,414 142,417 149,403 157,397 168,395 163,387 165,383 158,380 156,374 149,372 146,365"/>+ <text x="130" y="400">Gas</text>+ </g>+ <g id="Greece" title="Greece">+ <polygon class="l" points="339,487 346,498 350,498 347,500 352,508 367,507 371,511 355,510 350,514 357,521 359,533 360,528 367,536 368,531 376,537 371,520 378,521 377,513 386,516 385,509 370,494+ 371,491 378,494 368,483 371,477 379,484 382,483 381,477 386,478 380,472 392,472 388,460 376,464 369,464 361,467 356,471 350,471 350,477"/>+ <text x="352" y="490">Gre</text>+ </g>+ <g id="Gulf of Lyon" title="Gulf of Lyon">+ <polygon class="w" points="115,469 110,461 124,444 131,439 146,438 157,432 158,425 158,418 169,412 176,417 188,422 198,421 211,416 222,410 233,415 238,431 224,431 221,434 211,436 213,451 218,454+ 218,458 214,461 206,462 205,466 154,466 148,463 142,469"/>+ <text x="170" y="457">GoL</text>+ </g>+ <g id="Gulf of Bothnia" title="Gulf of Bothnia">+ <polygon class="w" points="311,220 314,209 322,206 328,203 331,193 326,183 320,182 321,161 330,146 343,138 351,128 347,121 349,112 355,104 362,107 368,108 372,120 366,121 359,136 345,151 347,160+ 350,165 348,178 349,184 357,186 365,191 384,185 402,177 403,183 411,184 414,187 408,187 400,192 399,197 387,196 371,198 369,202 365,204 368,210 372,213 373,221 377,227 373,229 366,228 359,220"/>+ <text x="328" y="175">Bot</text>+ </g>+ <g id="Heligoland Bight" title="Heligoland Bight">+ <polygon class="w" points="245,237 243,247 244,254 243,257 245,263 244,270 244,273 235,277 234,274 230,273 226,275 211,274 211,237"/>+ <text x="220" y="265">Hel</text>+ </g>+ <g id="Holland" title="Holland">+ <polygon class="l" points="226,275 227,280 225,292 220,298 215,297 213,302 210,313 208,315 205,311 206,306 194,303 191,299 198,289 205,276 205,279 207,279 211,274"/>+ <text x="210" y="290">Hol</text>+ </g>+ <g id="Ionian Sea" title="Ionian Sea">+ <polygon class="w" points="289,511 290,514 295,515 308,500 311,491 304,484 310,480 318,485 322,485 322,480 335,480 339,487 346,498 350,498 347,500 352,508 367,507 371,511 355,510 350,514 357,521+ 359,533 360,528 367,536 368,531 376,537 383,544 380,547 383,550 400,554 400,559 232,559 234,551 232,544 225,535 231,531 236,524 247,513 258,519 273,531 281,532 282,521 285,513 285,511"/>+ <text x="315" y="520">Ion</text>+ </g>+ <g id="Irish Sea" title="Irish Sea">+ <polygon class="w" points="100,291 112,287 122,281 130,282 127,276 119,272 116,272 115,265 128,262 126,256 121,257 132,250 135,250 139,240 136,229 130,227 120,227 110,232 109,246 98,259 87,257+ 70,261 58,273 88,303"/>+ <text x="95" y="270">Iri</text>+ </g>+ <g id="Kiel" title="Kiel">+ <polygon class="l" points="244,254 243,257 245,263 244,270 244,273 235,277 234,274 230,273 226,275 227,280 225,292 220,298 215,297 213,302 232,308 241,316 243,322 263,310 261,296 264,293+ 262,287 266,283 266,275 261,274 260,269 256,266 256,263 254,255"/>+ <polygon class="w" points="244,270 244,273 256,266 256,263 "/>+ <text x="237" y="285">Kie</text>+ </g>+ <g id="Liverpool" title="Liverpool">+ <polygon class="l" points="128,262 126,256 121,257 132,250 135,250 139,240 136,229 130,227 130,223 138,217 138,214 144,213 145,217 155,228 155,239 151,248 150,264 143,262"/>+ <text x="138" y="230">Lvp</text>+ </g>+ <g id="Livonia" title="Livonia">+ <polygon class="l" points="369,202 365,204 368,210 372,213 373,221 377,227 373,229 366,228 359,220 349,229 347,243 354,251 356,261 362,260 367,265 365,281 372,283 379,290 389,285 392,278+ 404,275 405,239 409,228 405,217 394,205 382,206 372,205"/>+ <text x="380" y="260">Lvn</text>+ </g>+ <g id="London" title="London">+ <polygon class="l" points="166,269 168,270 171,268 177,270 178,274 176,283 165,293 172,294 168,296 160,298 147,295 145,281 150,277 153,271"/>+ <text x="160" y="280">Lon</text>+ </g>+ <g id="Marseilles" title="Marseilles">+ <polygon class="l" points="142,417 149,403 157,397 168,395 173,396 178,390 178,381 194,382 197,385 203,379 207,386 204,390 207,396 201,399 204,402 203,410 211,416 198,421 188,422 176,417+ 169,412 158,418 158,425 154,427"/>+ <text x="173" y="412">Mar</text>+ </g>+ <g id="Mid-Atlantic Ocean" title="Mid-Atlantic Ocean">+ <polygon class="w" points="102,317 100,322 103,328 109,329 123,344 122,350 123,357 128,363 121,382 122,384 112,399 101,396 96,397 72,384 59,381 54,375 48,374 46,378 39,375 33,381 35,384 32,396+ 30,406 17,427 14,427 10,433 13,440 15,441 12,450 13,454 8,462 19,469 27,468 33,475 34,484 37,490 37,495 33,496 17,518 0,520 0,273 58,273"/>+ <text x="50" y="355">Mid</text>+ </g>+ <g id="Moscow" title="Moscow">+ <polygon class="l" points="609,117 598,132 573,143 564,159 534,164 515,169 489,184 476,183 458,194 456,207 457,210 451,213 447,209 439,211 428,225 421,229 409,228 405,239 404,275 392,278+ 389,285 379,290 386,309 390,306 456,292 468,295 477,289 494,295 505,280 516,286 526,287 533,283 549,284 554,304 564,305 569,321 597,330 609,330"/>+ <text x="460" y="265">Mos</text>+ </g>+ <g id="Munich" title="Munich">+ <polygon class="l" points="234,366 243,370 246,369 250,371 267,368 271,370 269,362 275,362 281,356 276,346 268,343 264,329 266,325 278,326 288,321 284,314 288,305 263,310 243,322 237,322+ 219,344 211,346 213,352 209,363 222,365 225,362 232,363"/>+ <text x="235" y="360">Mun</text>+ </g>+ <g id="Naples" title="Naples">+ <polygon class="l" points="271,464 276,474 290,487 294,502 289,511 290,514 295,515 308,500 311,491 304,484 293,481 279,458"/>+ <text x="293" y="493">Nap</text>+ </g>+ <g id="North Atlantic Ocean" title="North Atlantic Ocean">+ <polygon class="w" points="70,261 64,250 67,242 71,245 81,234 74,228 80,225 78,218 82,217 89,220 94,220 95,218 94,216 97,216 101,212 110,212 119,217 120,227 130,227 130,223 138,217 138,214+ 130,208 129,197 139,189 140,182 148,177 148,0 0,0 0,273 58,273"/>+ <text x="65" y="120">NAt</text>+ </g>+ <g id="North Africa" title="North Africa">+ <polygon class="l" points="203,520 179,515 169,518 150,511 117,509 106,511 99,515 89,512 84,518 79,520 68,516 68,511 64,514 46,509 42,502 41,494 37,495 33,496 17,518 0,520 0,559 195,559 197,527"/>+ <text x="130" y="536">NAf</text>+ </g>+ <g id="Norway" title="Norway">+ <polygon class="l" points="397,48 391,47 395,41 394,38 384,33 382,40 380,33 377,31 374,38 371,33 366,42 366,33 362,33 357,39 343,44 324,54 320,64 310,75 309,84 303,86 292,111 277,132 269,134+ 264,142 258,141 236,154 237,160 233,167 231,180 233,186 229,192 231,201 241,209 246,210 266,201 270,193 275,203 279,204 287,177 285,170 290,164 292,133 301,132 300,126 309,115 308,104 311,101+ 324,71 332,74 330,64 341,65 342,61 346,54 355,62 369,61 370,49 379,48 388,54 386,58 388,61"/>+ <text x="250" y="175">Nwy</text>+ </g>+ <g id="Paris" title="Paris">+ <polygon class="l" points="146,365 149,372 156,374 165,365 185,344 188,332 172,328 165,331 159,331 148,329 146,337"/>+ <text x="155" y="358">Par</text>+ </g>+ <g id="Picardy" title="Picardy">+ <polygon class="l" points="169,311 153,315 155,320 150,319 148,329 159,331 165,331 172,328 188,332 192,323 184,315"/>+ <text x="168" y="326">Pic</text>+ </g>+ <g id="Piedmont" title="Piedmont">+ <polygon class="l" points="207,386 204,390 207,396 201,399 204,402 203,410 211,416 222,410 233,415 236,411 233,404 246,392 243,388 229,385 227,390 221,385 213,387"/>+ <text x="215" y="408">Pie</text>+ </g>+ <g id="Portugal" title="Portugal">+ <polygon class="l" points="32,396 30,406 17,427 14,427 10,433 13,440 15,441 12,450 13,454 8,462 19,469 27,468 36,457 34,447 40,441 37,431 42,432 52,412 61,411 62,407 55,400 42,399 43,395"/>+ <text x="22" y="440">Por</text>+ </g>+ <g id="Prussia" title="Prussia">+ <polygon class="l" points="347,243 347,248 348,254 344,262 337,264 334,273 328,274 326,265 314,266 307,273 294,275 292,290 297,296 296,300 320,303 324,299 326,292 341,287 345,289 359,286+ 365,281 367,265 362,260 356,261 354,251"/>+ <text x="335" y="283">Pru</text>+ </g>+ <g id="Rome" title="Rome">+ <polygon class="l" points="247,442 248,447 256,458 271,464 279,458 280,455 279,451 274,447 263,434 250,438"/>+ <text x="257" y="452">Rom</text>+ </g>+ <g id="Ruhr" title="Ruhr">+ <polygon class="l" points="213,302 210,313 208,315 210,326 205,331 204,338 211,346 219,344 237,322 243,322 241,316 232,308"/>+ <text x="215" y="330">Ruh</text>+ </g>+ <g id="Rumania" title="Rumania">+ <polygon class="l" points="403,360 404,371 394,376 395,382 401,385 406,396 401,402 387,402 367,406 365,412 367,421 370,425 375,423 382,427 390,425 398,427 404,422 410,420 422,420 430,423 432,409+ 439,404 438,397 427,399 422,382 423,376 414,372 411,361"/>+ <text x="410" y="415">Rum</text>+ </g>+ <g id="Serbia" title="Serbia">+ <polygon class="l" points="365,412 360,413 342,410 338,412 335,410 332,410 330,416 331,424 327,429 330,437 337,446 346,452 346,466 350,471 356,471 361,467 369,464 365,461 371,456 366,439 371,438+ 368,433 365,425 367,421"/>+ <text x="350" y="450">Ser</text>+ </g>+ <g id="Sevastopol" title="Sevastopol">+ <polygon class="l" points="438,397 446,378 459,375 461,377 459,379 465,383 476,381 478,383 472,385 468,392 477,396 477,401 486,404 488,397 494,396 497,392 507,389 506,384 494,387 485,378 503,364+ 526,351 527,354 514,365 517,371 520,371 515,384 511,383 510,386 517,393 528,394 554,406 567,408 573,417 570,427 589,442 594,439 603,441 609,440 609,330 597,330 569,321 564,305 554,304 549,284+ 533,283 526,287 516,286 505,280 494,295 477,289 468,295 470,303 466,307 460,345 445,350 434,360 432,372 423,376 422,382 427,399"/>+ <text x="540" y="350">Sev</text>+ </g>+ <g id="Silesia" title="Silesia">+ <polygon class="l" points="288,321 297,322 311,334 314,332 321,339 325,340 329,338 333,330 326,327 323,322 320,303 296,300 288,305 284,314"/>+ <text x="304" y="325">Sil</text>+ </g>+ <g id="Skagerrak" title="Skagerrak">+ <polygon class="w" points="241,209 246,210 266,201 270,193 275,203 277,218 276,224 282,236 279,240 279,243 275,242 269,243 266,240 267,234 266,221 263,223 248,224 241,224"/>+ <text x="255" y="220">Ska</text>+ </g>+ <g id="Smyrna" title="Smyrna">+ <polygon class="l" points="417,489 420,495 417,498 417,507 423,510 427,524 435,523 435,530 441,526 447,528 453,534 464,531 466,521 475,520 485,528 491,530 505,526 511,514 520,517 527,508 530,509+ 536,494 545,486 555,484 563,479 562,471 556,467 555,460 546,462 531,460 508,480 501,482 490,480 473,491 466,491 452,495 432,493 423,487"/>+ <text x="460" y="510">Smy</text>+ </g>+ <g id="Spain NC" title="Spain (nc)">+ <polyline class="l" points="134,417 123,412 113,407 112,399 101,396 96,397 72,384 59,381 54,375 48,374 46,378 39,375 33,381 35,384 32,396 43,395 42,399 55,400 62,407 61,411 52,412 42,432 37,431 40,441"/>+ </g>+ <g id="Spain SC" title="Spain (sc)">+ <polyline class="l" points="40,441 34,447 36,457 27,468 33,475 34,484 37,490 47,488 52,489 60,486 78,491 83,494 86,485 90,483 98,484 107,474 113,473 115,469 110,461 124,444 131,439 146,438+ 157,432 158,425 154,427 142,417 135,414 134,417 123,412"/>+ <text x="85" y="450">Spa</text>+ </g>+ <g id="St. Petersburg NC" title="St Petersburg (nc)">+ <polyline class="l" points="534,164 564,159 573,143 598,132 609,117 609,0 540 0 535,9 530,6 517,19 516,33 513,38 513,23 507,20 505,26 499,33 492,48 495,58 488,60 479,57 477,55 481,50 473,43 466,45 472,62+ 478,66 478,74 472,72 468,74 457,91 469,100 467,106 462,109 444,101 442,110 447,115 454,119 452,122 434,118 426,103 426,94 414,88 412,83 445,84 457,79 459,66 453,61 417,47 405,49 401,45 397,48+ 388,61 387,68 393,73 392,92 401,110 402,118 410,130 414,147"/>+ <text x="460" y="149">StP</text>+ </g>+ <g id="St. Petersburg SC" title="St Petersburg (sc)">+ <polyline class="l" points="414,147 410,152 412,161 402,177 403,183 411,184 414,187 408,187 400,192 399,197 387,196 371,198 369,202 372,205 382,206 394,205 405,217 409,228 421,229 428,225 439,211+ 447,209 451,213 457,210 456,207 458,194 476,183 489,184 515,169 534,164 564,159"/>+ </g>+ <g id="Sweden" title="Sweden">+ <polygon class="l" points="275,203 277,218 276,224 282,236 279,240 279,243 282,253 289,254 294,245 305,244 312,229 311,220 314,209 322,206 328,203 331,193 326,183 320,182 321,161 330,146 343,138+ 351,128 347,121 349,112 355,104 362,107 356,71 342,61 341,65 330,64 332,74 324,71 311,101 308,104 309,115 300,126 301,132 292,133 290,164 285,170 287,177 279,204"/>+ <text x="300" y="170">Swe</text>+ </g>+ <g id="Syria" title="Syria">+ <polygon class="l" points="530,509 536,494 545,486 555,484 563,479 584,478 609,493 609,559 528,559 532,535 526,530 525,518"/>+ <text x="570" y="535">Syr</text>+ </g>+ <g title="Trieste">+ <polygon class="l" points="276,399 275,403 278,410 282,401 286,402 289,418 306,436 331,454 330,445 337,446 330,437 327,429 331,424 330,416 332,410 323,408 321,398 311,394 308,383 299,385 294,380+ 289,385 276,386 279,389"/>+ <text x="305" y="425">Tri</text>+ </g>+ <g id="Tunis" title="Tunis">+ <polygon class="l" points="232,559 234,551 232,544 225,535 231,531 236,524 233,523 224,527 223,518 218,516 212,517 208,521 203,520 197,527 195,559"/>+ <text x="210" y="555">Tun</text>+ </g>+ <g id="Tuscany" title="Tuscany">+ <polygon class="l" points="233,415 238,431 247,442 250,438 263,434 253,418 246,416 240,415 236,411"/>+ <text x="240" y="425">Tus</text>+ </g>+ <g id="Tyrolia" title="Tyrolia">+ <polygon class="l" points="234,366 243,370 246,369 250,371 267,368 271,370 269,362 275,362 281,356 292,357 295,362 294,380 289,385 276,386 268,385 259,388 255,394 250,397 246,392 243,388 245,384+ 241,378 234,374"/>+ <text x="255" y="380">Tyr</text>+ </g>+ <g id="Tyrrhenian Sea" title="Tyrrhenian Sea">+ <polygon class="w" points="238,431 247,442 248,447 256,458 271,464 276,474 290,487 294,502 289,511 285,511 285,508 276,510 263,510 257,507 252,508 247,513 236,524 233,523 224,527 223,518+ 218,516 218,490 220,490 224,468 222,458 218,458 218,454 223,450 225,444 225,436 224,431"/>+ <text x="245" y="495">Tyn</text>+ </g>+ <g id="Ukraine" title="Ukraine">+ <polygon class="l" points="383,327 385,332 399,338 404,354 403,360 411,361 414,372 423,376 432,372 434,360 445,350 460,345 466,307 470,303 468,295 456,292 390,306 386,309"/>+ <text x="420" y="340">Ukr</text>+ </g>+ <g id="Venice" title="Venice">+ <polygon class="l" points="278,443 272,424 260,417 261,401 270,398 276,399 279,389 276,386 268,385 259,388 255,394 250,397 246,392 233,404 236,411 240,415 246,416 253,418 263,434 274,447"/>+ <text x="245" y="407">Ven</text>+ </g>+ <g id="Vienna" title="Vienna">+ <polygon class="l" points="292,357 295,349 303,346 316,348 322,347 329,346 337,350 335,354 322,370 311,375 308,383 299,385 294,380 295,362"/>+ <text x="307" y="370">Vie</text>+ </g>+ <g id="Wales" title="Wales">+ <polygon class="l" points="100,291 112,287 122,281 130,282 127,276 119,272 116,272 115,265 128,262 143,262 150,264 153,271 150,277 145,281 147,295 134,294 124,291 120,295 110,292"/>+ <text x="130" y="275">Wal</text>+ </g>+ <g id="Warsaw" title="Warsaw">+ <polygon class="l" points="333,330 326,327 323,322 320,303 324,299 326,292 341,287 345,289 359,286 365,281 372,283 379,290 386,309 383,327 379,324 374,327 367,329 361,324 356,323 353,327+ 344,332 341,330"/>+ <text x="355" y="304">War</text>+ </g>+ <g id="Western Mediterranean" title="Western Mediterranean">+ <polygon class="w" points="37,490 47,488 52,489 60,486 78,491 83,494 86,485 90,483 98,484 107,474 113,473 115,469 142,469 150,471 154,466 205,466 206,476 204,485 208,492 212,492 217,489 218,490+ 218,516 212,517 208,521 203,520 179,515 169,518 150,511 117,509 106,511 99,515 89,512 84,518 79,520 68,516 68,511 64,514 46,509 42,502 41,494 37,495"/>+ <text x="160" y="491">Wes</text>+ </g>+ <g id="Yorkshire" title="Yorkshire">+ <polygon class="l" points="163,226 163,239 168,246 170,252 169,265 166,269 153,271 150,264 151,248 155,239 155,228"/>+ <text x="155" y="254">Yor</text>+ </g><defs>++ <g id="A">+ <path d="M9,-6 L2,0 M9,6 L0,0"/>+ <path d="M-11,-6 v4 h17 a2,2 0,0 0 0,-4z"/>+ <circle r="6"/>+ </g>+ <g id="F">+ <polygon points="-2,-3 10,-3 -2,-13"/>+ <polygon points="-12,-1 -6,5 6,5 12,-1"/>+ </g>+ <g id="sc"> <!-- colored SC -->+ <circle r="4"/>+ </g>+ <use id="SC" xlink:href="#sc" class="Unowned"/>+ </defs>++ <g id="SCNorway" title="Norway"><use xlink:href="#sc" class="Unowned" transform="translate(270,187)"/></g>+ <g id="SCSweden" title="Sweden"><use xlink:href="#sc" class="Unowned" transform="translate(323,196)"/></g>+ <g id="SCDenmark" title="Denmark"><use xlink:href="#sc" class="Unowned" transform="translate(272,252)"/></g>+ <g id="SCMoscow" title="Moscow"><use xlink:href="#sc" class="Unowned" transform="translate(481,234)"/></g>+ <g id="SCSevastopol" title="Sevastopol"><use xlink:href="#sc" class="Unowned" transform="translate(483,396)"/></g>+ <g id="SCSt. Petersburg" title="St Petersburg"><use xlink:href="#sc" class="Unowned" transform="translate(418,187)"/></g>+ <g id="SCAnkara" title="Ankara"><use xlink:href="#sc" class="Unowned" transform="translate(482,469)"/></g>+ <g id="SCConstantinople" title="Constantinople"><use xlink:href="#sc" class="Unowned" transform="translate(429,460)"/></g>+ <g id="SCSmyrna" title="Smyrna"><use xlink:href="#sc" class="Unowned" transform="translate(424,502)"/></g>+ <g id="SCRumania" title="Rumania"><use xlink:href="#sc" class="Unowned" transform="translate(402,413)"/></g>+ <g id="SCBulgaria" title="Bulgaria"><use xlink:href="#sc" class="Unowned" transform="translate(377,444)"/></g>+ <g id="SCGreece" title="Greece"><use xlink:href="#sc" class="Unowned" transform="translate(378,507)"/></g>+ <g id="SCSerbia" title="Serbia"><use xlink:href="#sc" class="Unowned" transform="translate(343,419)"/></g>+ <g id="SCWarsaw" title="Warsaw"><use xlink:href="#sc" class="Unowned" transform="translate(346,302)"/></g>+ <g id="SCBudapest" title="Budapest"><use xlink:href="#sc" class="Unowned" transform="translate(326,376)"/></g>+ <g id="SCVienna" title="Vienna"><use xlink:href="#sc" class="Unowned" transform="translate(301,363)"/></g>+ <g id="SCTrieste" title="Trieste"><use xlink:href="#sc" class="Unowned" transform="translate(284,396)"/></g>+ <g id="SCBerlin" title="Berlin"><use xlink:href="#sc" class="Unowned" transform="translate(281,298)"/></g>+ <g id="SCKiel" title="Kiel"><use xlink:href="#sc" class="Unowned" transform="translate(254,278)"/></g>+ <g id="SCMunich" title="Munich"><use xlink:href="#sc" class="Unowned" transform="translate(258,359)"/></g>+ <g id="SCVenice" title="Venice"><use xlink:href="#sc" class="Unowned" transform="translate(261,397)"/></g>+ <g id="SCRome" title="Rome"><use xlink:href="#sc" class="Unowned" transform="translate(252,443)"/></g>+ <g id="SCNaples" title="Naples"><use xlink:href="#sc" class="Unowned" transform="translate(278,469)"/></g>+ <g id="SCTunis" title="Tunis"><use xlink:href="#sc" class="Unowned" transform="translate(220,529)"/></g>+ <g id="SCSpain" title="Spain"><use xlink:href="#sc" class="Unowned" transform="translate(80,432)"/></g>+ <g id="SCPortugal" title="Portugal"><use xlink:href="#sc" class="Unowned" transform="translate(15,434)"/></g>+ <g id="SCMarseilles" title="Marseilles"><use xlink:href="#sc" class="Unowned" transform="translate(186,417)"/></g>+ <g id="SCParis" title="Paris"><use xlink:href="#sc" class="Unowned" transform="translate(173,334)"/></g>+ <g id="SCBrest" title="Brest"><use xlink:href="#sc" class="Unowned" transform="translate(106,322)"/></g>+ <g id="SCBelgium" title="Belgium"><use xlink:href="#sc" class="Unowned" transform="translate(186,305)"/></g>+ <g id="SCHolland" title="Holland"><use xlink:href="#sc" class="Unowned" transform="translate(205,284)"/></g>+ <g id="SCLondon" title="London"><use xlink:href="#sc" class="Unowned" transform="translate(162,290)"/></g>+ <g id="SCLiverpool" title="Liverpool"><use xlink:href="#sc" class="Unowned" transform="translate(144,257)"/></g>+ <g id="SCEdinburgh" title="Edinburgh"><use xlink:href="#sc" class="Unowned" transform="translate(154,219)"/></g>++ <!--+ <g title="Vienna"><use xlink:href="#A" id="Vienna" class="Austria" transform="translate(&Vienna;)"/></g>+ <g title="Budapest"><use xlink:href="#A" id="Budapest" class="Austria" transform="translate(&Budapest;)"/></g>+ <g title="Trieste"><use xlink:href="#F" id="Trieste" class="Austria" transform="translate(&Trieste;)"/></g>+ <g title="London"><use xlink:href="#F" id="London" class="England" transform="translate(&London;)"/></g>+ <g title="Edinburgh"><use xlink:href="#F" id="Edinburgh" class="England" transform="translate(&Edinburgh;)"/></g>+ <g title="Liverpool"><use xlink:href="#A" id="Liverpool" class="England" transform="translate(&Liverpool;)"/></g>+ <g title="Paris"><use xlink:href="#A" id="Paris" class="France" transform="translate(&Paris;)"/></g>+ <g title="Marseilles"><use xlink:href="#A" id="Marseilles" class="France" transform="translate(&Marseilles;)"/></g>+ <g title="Brest"><use xlink:href="#F" id="Brest" class="France" transform="translate(&Brest;)"/></g>+ <g title="Berlin"><use xlink:href="#A" id="Berlin" class="Germany" transform="translate(&Berlin;)"/></g>+ <g title="Munich"><use xlink:href="#A" id="Munich" class="Germany" transform="translate(&Munich;)"/></g>+ <g title="Kiel"><use xlink:href="#F" id="Kiel" class="Germany" transform="translate(&Kiel;)"/></g>+ <g title="Rome"><use xlink:href="#A" id="Rome" class="Italy" transform="translate(&Rome;)"/></g>+ <g title="Venice"><use xlink:href="#A" id="Venice" class="Italy" transform="translate(&Venice;)"/></g>+ <g title="Naples"><use xlink:href="#F" id="Naples" class="Italy" transform="translate(&Naples;)"/></g>+ <g title="Moscow"><use xlink:href="#A" id="Moscow" class="Russia" transform="translate(&Moscow;)"/></g>+ <g title="Warsaw"><use xlink:href="#A" id="Warsaw" class="Russia" transform="translate(&Warsaw;)"/></g>+ <g title="St Petersburg (sc)"><use xlink:href="#F" id="St_Petersburg" class="Russia" transform="translate(&St_Petersburg__sc;)"/></g>+ <g title="Sevastopol"><use xlink:href="#F" id="Sevastopol" class="Russia" transform="translate(&Sevastopol;)"/></g>+ <g title="Constantinople"><use xlink:href="#A" id="Constantinople" class="Turkey" transform="translate(&Constantinople;)"/></g>+ <g title="Smyrna"><use xlink:href="#A" id="Smyrna" class="Turkey" transform="translate(&Smyrna;)"/></g>+ <g title="Ankara"><use xlink:href="#F" id="Ankara" class="Turkey" transform="translate(&Ankara;)"/></g>+ -->+ </svg>++ </body>++</html>
+ diplomacy-server.cabal view
@@ -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