labyrinth-server (empty) → 0.1.1.0
raw patch · 5 files changed
+558/−0 lines, 5 filesdep +acid-statedep +aesondep +basesetup-changed
Dependencies added: acid-state, aeson, base, containers, derive, filepath, hamlet, labyrinth, lens, mtl, random, safecopy, shakespeare-css, shakespeare-js, template-haskell, text, transformers, utf8-string, vector, wai-websockets, warp, websockets, yesod, yesod-static
Files
- LICENSE +7/−0
- Setup.hs +2/−0
- labyrinth-server.cabal +49/−0
- src/LabyrinthServer.hs +245/−0
- src/LabyrinthServer/Data.hs +255/−0
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright (c) 2012 Alexey Kotlyarov++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ labyrinth-server.cabal view
@@ -0,0 +1,49 @@+name: labyrinth-server+version: 0.1.1.0+synopsis: A complicated turn-based game - Web server+description: Players take turns in a labyrinth, competing with each+ other to pick a treasure and carry it out. They only know+ everyone's moves and responses, but do not see the map and+ must deduce it themselves.+ This package contains a Web server to play the game.+homepage: https://github.com/koterpillar/labyrinth-server+license: MIT+license-file: LICENSE+author: Alexey Kotlyarov+maintainer: a@koterpillar.com+category: Game+build-type: Simple+cabal-version: >=1.8++source-repository head+ type: git+ location: git://github.com/koterpillar/labyrinth-server.git++executable labyrinth-server+ main-is: LabyrinthServer.hs+ other-modules: LabyrinthServer.Data+ build-depends: base >= 4.5 && < 4.7+ , labyrinth >= 0.4.2.0 && < 0.5+ , mtl ==2.1.*+ , template-haskell >= 2.7 && < 2.9+ , lens ==3.9.*+ , filepath ==1.3.*+ , derive ==2.5.*+ , safecopy ==0.8.*+ , containers >= 0.4 && < 0.6+ , random ==1.0.*+ , text ==0.11.*+ , transformers ==0.3.*+ , vector ==0.10.*+ , acid-state ==0.12.*+ , yesod ==1.2.*+ , yesod-static ==1.2.*+ , websockets ==0.7.*+ , wai-websockets ==1.3.*+ , warp ==1.3.*+ , utf8-string ==0.3.*+ , aeson ==0.6.*+ , shakespeare-css ==1.0.*+ , shakespeare-js ==1.1.*+ , hamlet ==1.1.*+ hs-source-dirs: src
+ src/LabyrinthServer.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Main where++import Control.Applicative+import Control.Concurrent+import Control.Exception (bracket)+import Control.Lens hiding ((.=))+import Control.Monad+import Control.Monad.IO.Class++import Data.Acid ( AcidState+ , EventResult+ , EventState+ , openLocalStateFrom+ , QueryEvent+ , UpdateEvent+ )+import Data.Acid.Advanced (query', update')+import Data.Acid.Local (createCheckpointAndClose)+import Data.Aeson+import qualified Data.ByteString.UTF8 as BSU+import Data.List+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Text as T+import qualified Data.String as S++import Network.Wai.Handler.Warp+import qualified Network.Wai.Handler.WebSockets as WaiWS+import qualified Network.WebSockets as WS++import System.Environment+import System.FilePath.Posix+import System.Random++import Text.Hamlet (hamletFile)+import Text.Julius (juliusFile)+import Text.Lucius (luciusFile)++import Yesod hiding (update)+import Yesod.Static++import Labyrinth hiding (performMove)++import LabyrinthServer.Data++newId :: (MonadIO m) => m String+newId = replicateM 32 $ liftIO $ randomRIO ('a', 'z')++envVar :: String -> IO (Maybe String)+envVar var = do+ env <- liftM M.fromList getEnvironment+ return $ M.lookup var env++envVarWithDefault :: String -> String -> IO String+envVarWithDefault def var =+ liftM (fromMaybe def) (envVar var)++getDataPath :: IO String+getDataPath = do+ dataDir <- envVarWithDefault "." "OPENSHIFT_DATA_DIR"+ return $ dataDir </> "state"++data WatchTarget = GameList | GameLog GameId+ deriving (Eq, Ord)++type WSType = WS.Hybi00++type WSSink = WS.Sink WSType++data LabyrinthServer = LabyrinthServer { lsGames :: AcidState Games+ , lsStatic :: Static+ , lsWatchers :: MVar (M.Map WatchTarget [WSSink])+ }++staticFiles "static"++mkYesod "LabyrinthServer" [parseRoutes|+/ HomeR GET+/games GamesR GET+/game NewGameR POST+/game/#GameId GameR GET+/game/#GameId/move MakeMoveR POST+/game/#GameId/delete DeleteGameR DELETE+/examples ExampleMovesR GET+/static StaticR Static lsStatic+|]++instance Yesod LabyrinthServer where+ defaultLayout = mainLayout++instance RenderMessage LabyrinthServer FormMessage where+ renderMessage _ _ = defaultFormMessage++postForm :: (Html -> MForm Handler (FormResult a, Widget))+ -> (a -> Handler Value)+ -> Handler Value+postForm form handler = do+ ((result, _), _) <- runFormPostNoToken form+ case result of+ FormSuccess value -> handler value+ FormFailure errors -> returnJson errors++main :: IO ()+main = do+ dataPath <- getDataPath+ port <- liftM read $ envVarWithDefault "8080" "PORT"+ ip <- envVarWithDefault "127.0.0.1" "OPENSHIFT_INTERNAL_IP"+ static <- static "static"+ bracket+ (openLocalStateFrom dataPath noGames)+ createCheckpointAndClose $+ \acid -> do+ watchers <- newMVar M.empty+ let server = LabyrinthServer acid static watchers+ app <- toWaiApp server+ let intercept = WaiWS.intercept $ wsHandler server+ let settings = defaultSettings { settingsPort = port+ , settingsHost = Host ip+ , settingsIntercept = intercept+ }+ runSettings settings app++wsHandler :: LabyrinthServer -> WS.Request -> WS.WebSockets WSType ()+wsHandler site rq = do+ let path = BSU.toString $ WS.requestPath rq+ -- TODO: parse path better+ let watch = if path == "/games" then GameList else GameLog $ drop 6 path+ WS.acceptRequest rq+ sink <- WS.getSink+ addWatcher site watch sink++addWatcher :: (MonadIO m) => LabyrinthServer -> WatchTarget -> WSSink -> m ()+addWatcher site watch sink =+ liftIO $ modifyMVar_ (lsWatchers site) $ \watchers ->+ return $ M.insertWith (++) watch [sink] watchers++query :: (QueryEvent event, EventState event ~ Games)+ => event+ -> Handler (EventResult event)+query ev = do+ site <- getYesod+ let acid = lsGames site+ query' acid ev++update :: (UpdateEvent event, EventState event ~ Games)+ => WatchTarget+ -> event+ -> Handler (EventResult event)+update watch ev = do+ site <- getYesod+ let acid = lsGames site+ res <- update' acid ev+ notifyWatchers site watch+ return res++notifyWatchers :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m ()+notifyWatchers site watch = liftIO $ withMVar (lsWatchers site) $ \watchersMap -> do+ let watchers = fromMaybe [] $ M.lookup watch watchersMap+ value <- watchTargetValue site watch+ forM_ watchers $ \sink ->+ WS.sendSink sink $ WS.textData $ encode value++watchTargetValue :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m Value+watchTargetValue site GameList = do+ let acid = lsGames site+ result <- query' acid GetGames+ return $ toJSON result+watchTargetValue site (GameLog gameId) = do+ let acid = lsGames site+ result <- query' acid $ GetGame gameId+ return $ toJSON result++immediateResponse :: WatchTarget -> Handler Value+immediateResponse target = do+ site <- getYesod+ result <- watchTargetValue site target+ returnJson result++mainLayout :: Widget -> Handler Html+mainLayout widget = do+ p <- widgetToPageContent widget+ giveUrlRenderer $(hamletFile "templates/layout.hamlet")++getHomeR :: Handler Html+getHomeR = defaultLayout $ do+ addScriptRemote "https://cdnjs.cloudflare.com/ajax/libs/jquery/2.0.3/jquery.min.js"+ addScriptRemote "https://cdnjs.cloudflare.com/ajax/libs/handlebars.js/1.0.0/handlebars.min.js"+ toWidget $(juliusFile "templates/index.julius")+ toWidget $(luciusFile "templates/index.lucius")+ $(whamletFile "templates/index.hamlet")++getGamesR :: Handler Value+getGamesR = immediateResponse GameList++named :: T.Text -> FieldSettings LabyrinthServer+named name = FieldSettings "" Nothing Nothing (Just name) []++newGameForm :: Html+ -> MForm Handler (FormResult LabyrinthParams, Widget)+newGameForm = renderDivs $ LabyrinthParams+ <$> areq intField (named "width") Nothing+ <*> areq intField (named "height") Nothing+ <*> areq intField (named "players") Nothing++postNewGameR :: Handler Value+postNewGameR = postForm newGameForm $ \params -> do+ lab <- createLabyrinth params+ gameId <- newId+ res <- update GameList $ AddGame gameId lab+ returnJson (if res then "ok" else "bad game" :: String)++getGameR :: GameId -> Handler Value+getGameR gameId = immediateResponse (GameLog gameId)++data PlayerMove = PlayerMove { pmplayer :: PlayerId+ , pmmove :: T.Text+ }++makeMoveForm :: Html+ -> MForm Handler (FormResult PlayerMove, Widget)+makeMoveForm = renderDivs $ PlayerMove+ <$> areq intField (named "player") Nothing+ <*> areq textField (named "move") Nothing++postMakeMoveR :: GameId -> Handler Value+postMakeMoveR gameId = postForm makeMoveForm $ \playerMove -> do+ let PlayerMove playerId moveStr = playerMove+ case parseMove (T.unpack moveStr) of+ Left err -> returnJson $ object ["error" .= err]+ Right move -> do+ res <- update (GameLog gameId) $ PerformMove gameId playerId move+ returnJson $ show res++deleteDeleteGameR :: GameId -> Handler Value+deleteDeleteGameR gameId = do+ update GameList $ RemoveGame gameId+ returnJson ("ok" :: String)++getExampleMovesR :: Handler Value+getExampleMovesR = returnJson exampleMovesJSON
+ src/LabyrinthServer/Data.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module LabyrinthServer.Data where++import Control.Lens hiding (Action, (.=))+import Control.Monad.State+import Control.Monad.Reader (ask)++import Data.Acid (Query, Update, makeAcidic)+import Data.DeriveTH+import Data.Derive.Typeable+import qualified Data.Map as M+import Data.SafeCopy (base, deriveSafeCopy)+import qualified Data.Text as T+import Data.Typeable+import qualified Data.Vector as V++import System.Random++import Yesod hiding (get, Update)++import Labyrinth hiding (performMove)+import qualified Labyrinth as L++deriveSafeCopy 0 'base ''Direction+deriveSafeCopy 0 'base ''Wall+deriveSafeCopy 0 'base ''CellType+deriveSafeCopy 0 'base ''Cell+deriveSafeCopy 0 'base ''Position+deriveSafeCopy 0 'base ''Treasure+deriveSafeCopy 0 'base ''Health+deriveSafeCopy 0 'base ''Player+deriveSafeCopy 0 'base ''Labyrinth++deriveSafeCopy 0 'base ''Action+deriveSafeCopy 0 'base ''MoveDirection+deriveSafeCopy 0 'base ''QueryType+deriveSafeCopy 0 'base ''Move++deriveSafeCopy 0 'base ''CellTypeResult+deriveSafeCopy 0 'base ''TreasureResult+deriveSafeCopy 0 'base ''CellEvents+deriveSafeCopy 0 'base ''GoResult+deriveSafeCopy 0 'base ''GrenadeResult+deriveSafeCopy 0 'base ''ShootResult+deriveSafeCopy 0 'base ''ActionResult+deriveSafeCopy 0 'base ''ChoosePositionResult+deriveSafeCopy 0 'base ''ReorderCellResult+deriveSafeCopy 0 'base ''QueryResult+deriveSafeCopy 0 'base ''StartResult+deriveSafeCopy 0 'base ''MoveResult++derive makeTypeable ''Labyrinth+derive makeTypeable ''Move+derive makeTypeable ''MoveResult++type GameId = String++data MoveRecord = MoveRecord { _rplayer :: PlayerId+ , _rmove :: Move+ , _rresult :: MoveResult+ , _rstate :: Labyrinth+ }++makeLenses ''MoveRecord++deriveSafeCopy 0 'base ''MoveRecord++derive makeTypeable ''MoveRecord++type MoveLog = [MoveRecord]++logMoveResult :: MoveRecord -> State MoveLog ()+logMoveResult m = modify (++ [m])++data Game = Game { _labyrinth :: Labyrinth+ , _moves :: MoveLog+ }++newGame :: Labyrinth -> Game+newGame l = Game l []++makeLenses ''Game++deriveSafeCopy 0 'base ''Game++derive makeTypeable ''Game++data Games = Games { _games :: M.Map GameId Game }++noGames :: Games+noGames = Games M.empty++makeLenses ''Games++game :: GameId -> Simple Traversal Games Game+game gid = games . ix gid++getGames :: Query Games Games+getGames = ask++stateUpdate :: State x y -> Update x y+stateUpdate f = do+ st <- get+ let (r, st') = runState f st+ put st'+ return r++data LabyrinthParams = LabyrinthParams { lpwidth :: Int+ , lpheight :: Int+ , lpplayers :: Int+ }++createLabyrinth :: (MonadIO m) => LabyrinthParams -> m Labyrinth+createLabyrinth p = do+ gen <- liftIO getStdGen+ let (l, gen') = generateLabyrinth+ (lpwidth p) (lpheight p) (lpplayers p) gen+ liftIO $ setStdGen gen'+ return l++addGame :: GameId -> Labyrinth -> Update Games Bool+addGame gid lab = stateUpdate $ zoom games $ do+ existing <- gets (M.member gid)+ if existing+ then return False+ else do+ modify $ M.insert gid $ newGame lab+ return True++getGame :: GameId -> Query Games Game+getGame = view . singular . game++performMove :: GameId -> PlayerId -> Move -> Update Games MoveResult+performMove g p m = stateUpdate $ zoom (singular $ game g) $ do+ r <- zoom labyrinth $ L.performMove p m+ l <- use labyrinth+ zoom moves $ logMoveResult $ MoveRecord p m r l+ return r++removeGame :: GameId -> Update Games ()+removeGame gid = stateUpdate $ zoom games $ do+ modify $ M.delete gid+ return ()++deriveSafeCopy 0 'base ''Games++derive makeTypeable ''Games++makeAcidic ''Games [ 'getGames+ , 'addGame+ , 'getGame+ , 'performMove+ , 'removeGame+ ]++exampleMoves :: [Move]+exampleMoves = [ ChoosePosition (Pos 2 4)+ , Move [goTowards L]+ , Move [Shoot U]+ , Move [Grenade D, goTowards D]+ , ReorderCell (Pos 3 3)+ , Query [BulletCount, GrenadeCount, PlayerHealth]+ , Say "hello"+ , Move [Conditional "hit a wall" [Grenade D] [Shoot L]]+ , Move [Surrender]+ ]++exampleMovesJSON :: Value+exampleMovesJSON = array $ map show exampleMoves++class ToSensitiveJSON a where+ toSensitiveJSON :: Bool -> a -> Value++instance ToSensitiveJSON a => ToSensitiveJSON [a] where+ toSensitiveJSON s = Array . V.fromList . map (toSensitiveJSON s)++data Sensitive a = Sensitive { isSensitive :: Bool, sensitiveData :: a }+instance ToSensitiveJSON a => ToJSON (Sensitive a) where+ toJSON (Sensitive s a) = toSensitiveJSON s a++instance ToJSON Direction where+ toJSON d = toJSON $ show d++instance ToJSON CellType where+ toJSON ct = object $ [ "type" .= show ct ] ++ prop ct+ where prop (Pit n) = ["number" .= n]+ prop (River d) = ["direction" .= d]+ prop _ = []++instance ToJSON Treasure where+ toJSON t = toJSON $ show t++instance ToJSON Cell where+ toJSON c = object [ "cell" .= (c ^. ctype)+ , "bullets" .= (c ^. cbullets)+ , "grenades" .= (c ^. cgrenades)+ , "treasures" .= (c ^. ctreasures)+ ]++instance ToJSON Position where+ toJSON p = object [ "x" .= pX p+ , "y" .= pY p+ ]++instance ToJSON Wall where+ toJSON NoWall = String "none"+ toJSON Wall = String "wall"+ toJSON HardWall = String "hardwall"++mapToList :: M.Map Position v -> [[v]]+mapToList m = [[(M.!) m (Pos x y) | x <- [xmin..xmax]] | y <- [ymin..ymax]]+ where xmin = minimum xs+ xmax = maximum xs+ ymin = minimum ys+ ymax = maximum ys+ xs = map pX ps+ ys = map pY ps+ ps = M.keys m++instance ToSensitiveJSON Labyrinth where+ toSensitiveJSON s l = object $ [ "width" .= (l ^. labWidth)+ , "height" .= (l ^. labHeight)+ , "currentTurn" .= (l ^. currentTurn)+ , "gameEnded" .= (l ^. gameEnded)+ , "positionsChosen" .= (l ^. positionsChosen)+ , "playerCount" .= playerCount l+ ] ++ sensitive+ where sensitive | s = [ "map" .= show l+ , "cells" .= mapToList (l ^. cells)+ , "wallsW" .= mapToList (l ^. wallsV)+ , "wallsH" .= mapToList (l ^. wallsH)+ ]+ | otherwise = []++instance ToSensitiveJSON MoveRecord where+ toSensitiveJSON s r = object [ "player" .= (r ^. rplayer)+ , "move" .= show (r ^. rmove)+ , "result" .= show (r ^. rresult)+ , "state" .= Sensitive s (r ^. rstate)+ ]++instance ToJSON Game where+ toJSON g = object [ "game" .= Sensitive ended (g ^. labyrinth)+ , "log" .= Sensitive ended (g ^. moves)+ ]+ where ended = g ^. labyrinth ^. gameEnded++instance ToJSON Games where+ toJSON g = object [T.pack id .= game | (id, game) <- lst]+ where lst = M.toList $ g ^. games