labyrinth 0.1.6.1 → 0.3.0.0
raw patch · 3 files changed
+258/−112 lines, 3 filesdep +aesondep +hamletdep +shakespeare-cssdep −happstack-serverdep −jsondep ~HTFdep ~lens
Dependencies added: aeson, hamlet, shakespeare-css, shakespeare-js, utf8-string, wai-websockets, warp, websockets, yesod, yesod-static
Dependencies removed: happstack-server, json
Dependency ranges changed: HTF, lens
Files
- labyrinth.cabal +16/−11
- src/LabyrinthServer.hs +191/−63
- src/LabyrinthServer/Data.hs +51/−38
labyrinth.cabal view
@@ -1,5 +1,5 @@ name: labyrinth-version: 0.1.6.1+version: 0.3.0.0 synopsis: A complicated turn-based game description: Players take turns in a labyrinth, competing with each other to pick a treasure and carry it out. They only know@@ -22,7 +22,7 @@ build-depends: base >= 4.5 && < 4.7 , mtl ==2.1.* , template-haskell >= 2.7 && < 2.9- , lens ==3.8.*+ , lens ==3.9.* , filepath ==1.3.* , derive ==2.5.* , safecopy ==0.8.*@@ -59,10 +59,8 @@ build-depends: base >= 4.5 && < 4.7 , mtl ==2.1.* , template-haskell >= 2.7 && < 2.9- , lens ==3.8.*+ , lens ==3.9.* , filepath ==1.3.*- , acid-state ==0.8.*- , happstack-server ==7.1.* , derive ==2.5.* , safecopy ==0.8.* , parsec ==3.1.*@@ -71,8 +69,18 @@ , text ==0.11.* , transformers ==0.3.* , MonadRandom ==0.1.*- , json ==0.7.* , monad-loops ==0.3.*+ , acid-state ==0.8.*+ , 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 test-Suite tests@@ -81,10 +89,8 @@ build-depends: base >= 4.5 && < 4.7 , mtl ==2.1.* , template-haskell >= 2.7 && < 2.9- , lens ==3.8.*+ , lens ==3.9.* , filepath ==1.3.*- , acid-state ==0.8.*- , happstack-server ==7.1.* , derive ==2.5.* , safecopy ==0.8.* , parsec ==3.1.*@@ -93,9 +99,8 @@ , text ==0.11.* , transformers ==0.3.* , MonadRandom ==0.1.*- , json ==0.7.* , monad-loops ==0.3.*- , HTF ==0.10.*+ , HTF ==0.11.* , HUnit ==1.2.* , QuickCheck >=2.6 && < 2.7 hs-source-dirs: src, testsuite
src/LabyrinthServer.hs view
@@ -1,37 +1,53 @@+{-# 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 import Control.Monad import Control.Monad.IO.Class -import Data.Acid (AcidState, openLocalState)+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 Happstack.Server hiding (result)+import qualified Data.String as S -import qualified Text.JSON as J+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 -createLabyrinth :: (MonadIO m) => Int -> Int -> Int -> m Labyrinth-createLabyrinth w h n = do- gen <- liftIO getStdGen- let (l, gen') = generateLabyrinth w h n gen- liftIO $ setStdGen gen'- return l- newId :: (MonadIO m) => m String newId = replicateM 32 $ liftIO $ randomRIO ('a', 'z') @@ -49,69 +65,181 @@ 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- ip <- envVarWithDefault "127.0.0.1" "OPENSHIFT_INTERNAL_IP"- port_ <- liftM read $ envVarWithDefault "8080" "PORT" dataPath <- getDataPath- let conf = nullConf { port = port_ }- bracket (openLocalState noGames)- createCheckpointAndClose- $ \acid -> do- socket <- bindIPv4 ip (port conf)- simpleHTTPWithSocket socket conf $ myApp acid+ 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 -myApp :: AcidState Games -> ServerPart Response-myApp acid = msum (map ($ acid) actions) `mplus` fileServing- where actions = [ createGame- , listGames- , listExampleMoves- ]- ++ map gameAction gameActions- gameActions = [ makeMove- , showLog- ]+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 -bodyPolicy = defaultBodyPolicy "/tmp/" 0 1000 1000+addWatcher :: (MonadIO m) => LabyrinthServer -> WatchTarget -> WSSink -> m ()+addWatcher site watch sink =+ liftIO $ modifyMVar_ (lsWatchers site) $ \watchers ->+ return $ M.insertWith (++) watch [sink] watchers -gameAction :: (AcidState Games -> GameId -> ServerPart Response) -> AcidState Games -> ServerPart Response-gameAction act acid = path $ act acid+query :: (QueryEvent event, EventState event ~ Games)+ => event+ -> Handler (EventResult event)+query ev = do+ site <- getYesod+ let acid = lsGames site+ query' acid ev -fileServing :: ServerPart Response-fileServing = serveDirectory DisableBrowsing ["index.html"] "public"+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 -createGame :: AcidState Games -> ServerPart Response-createGame acid = dir "add" $ nullDir >> method POST >> do- decodeBody bodyPolicy- lWidth <- lookRead "width"- lHeight <- lookRead "height"- pCount <- lookRead "players"+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- lab <- createLabyrinth lWidth lHeight pCount- res <- update' acid $ AddGame gameId lab- ok $ toResponse $ if res then "ok" else "bad game"+ res <- update GameList $ AddGame gameId lab+ returnJson (if res then "ok" else "bad game" :: String) -listGames :: AcidState Games -> ServerPart Response-listGames acid = dir "list" $ nullDir >> do- games <- query' acid GetGames- ok $ toResponse $ J.encode $ gameListJSON games+getGameR :: GameId -> Handler Value+getGameR gameId = immediateResponse (GameLog gameId) -listExampleMoves :: AcidState Games -> ServerPart Response-listExampleMoves _ = dir "examples" $ nullDir >> method GET >> do- ok $ toResponse $ J.encode $ exampleMovesJSON+data PlayerMove = PlayerMove { pmplayer :: PlayerId+ , pmmove :: T.Text+ } -showLog :: AcidState Games -> GameId -> ServerPart Response-showLog acid gameId = dir "log" $ nullDir >> do- g <- query' acid $ GetGame gameId- ok $ toResponse $ J.encode $ gameJSON g+makeMoveForm :: Html+ -> MForm Handler (FormResult PlayerMove, Widget)+makeMoveForm = renderDivs $ PlayerMove+ <$> areq intField (named "player") Nothing+ <*> areq textField (named "move") Nothing -makeMove :: AcidState Games -> GameId -> ServerPart Response-makeMove acid gameId = dir "move" $ nullDir >> method POST >> do- decodeBody bodyPolicy- moveStr <- look "move"- playerId <- lookRead "player"- case parseMove moveStr of- Left err -> ok $ toResponse err+postMakeMoveR :: GameId -> Handler Value+postMakeMoveR gameId = postForm makeMoveForm $ \playerMove -> do+ let PlayerMove playerId moveStr = playerMove+ case parseMove (T.unpack moveStr) of+ Left err -> returnJson err Right move -> do- res <- update' acid $ PerformMove gameId playerId move- ok $ toResponse $ show res+ 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
@@ -1,8 +1,12 @@-{-# Language DeriveDataTypeable, TemplateHaskell, TypeFamilies, Rank2Types #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} module LabyrinthServer.Data where -import Control.Lens hiding (Action)+import Control.Lens hiding (Action, (.=)) import Control.Monad.State import Control.Monad.Reader (ask) @@ -11,10 +15,13 @@ 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 Text.JSON+import System.Random +import Yesod hiding (get, Update)+ import Labyrinth hiding (performMove) import qualified Labyrinth as L @@ -101,6 +108,19 @@ 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)@@ -119,6 +139,11 @@ zoom moves $ logMoveResult $ MoveRecord p m r return r +removeGame :: GameId -> Update Games ()+removeGame gid = stateUpdate $ zoom games $ do+ modify $ M.delete gid+ return ()+ deriveSafeCopy 0 'base ''Games derive makeTypeable ''Games@@ -127,6 +152,7 @@ , 'addGame , 'getGame , 'performMove+ , 'removeGame ] exampleMoves :: [Move]@@ -141,42 +167,29 @@ , Move [Surrender] ] -exampleMovesJSON :: JSValue-exampleMovesJSON = JSArray $ map jsShow $ exampleMoves--logJSON :: MoveLog -> JSValue-logJSON g = JSArray $ map moveJSON g- where moveJSON l = jsObject [ ("player", jsInt $ l ^. rplayer)- , ("move", jsShow $ l ^. rmove)- , ("result", jsShow $ l ^. rresult)- ]--gameInfoJSON :: Game -> JSValue-gameInfoJSON g = jsObject prop- where prop = [ ("width", jsInt $ l ^. labWidth)- , ("height", jsInt $ l ^. labHeight)- , ("players", jsInt $ playerCount l)- , ("currentTurn", jsInt $ l ^. currentTurn)- , ("gameEnded", jsBool $ l ^. gameEnded)- ] ++ mapProp- mapProp = [("map", jsShow l) | l ^. gameEnded]- l = g ^. labyrinth--gameListJSON :: Games -> JSValue-gameListJSON = jsObject . M.toList . M.map gameInfoJSON . view games--gameJSON :: Game -> JSValue-gameJSON g = jsObject [("game", gameInfoJSON g), ("log", logJSON m)]- where m = g ^. moves+exampleMovesJSON :: Value+exampleMovesJSON = array $ map show exampleMoves -jsObject :: [(String, JSValue)] -> JSValue-jsObject = JSObject . toJSObject+instance ToJSON Labyrinth where+ toJSON l = object $ [ "width" .= (l ^. labWidth)+ , "height" .= (l ^. labHeight)+ , "players" .= playerCount l+ , "currentTurn" .= (l ^. currentTurn)+ , "gameEnded" .= (l ^. gameEnded)+ ]+ ++ ["map" .= show l | l ^. gameEnded] -jsInt :: Int -> JSValue-jsInt = JSRational False . fromIntegral+instance ToJSON MoveRecord where+ toJSON r = object [ "player" .= (r ^. rplayer)+ , "move" .= show (r ^. rmove)+ , "result" .= show (r ^. rresult)+ ] -jsBool :: Bool -> JSValue-jsBool = JSBool+instance ToJSON Game where+ toJSON g = object [ "game" .= (g ^. labyrinth)+ , "log" .= (g ^. moves)+ ] -jsShow :: (Show a) => a -> JSValue-jsShow = JSString . toJSString . show+instance ToJSON Games where+ toJSON g = object [T.pack id .= game | (id, game) <- lst]+ where lst = M.toList $ g ^. games