diff --git a/labyrinth.cabal b/labyrinth.cabal --- a/labyrinth.cabal +++ b/labyrinth.cabal @@ -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 diff --git a/src/LabyrinthServer.hs b/src/LabyrinthServer.hs --- a/src/LabyrinthServer.hs +++ b/src/LabyrinthServer.hs @@ -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 diff --git a/src/LabyrinthServer/Data.hs b/src/LabyrinthServer/Data.hs --- a/src/LabyrinthServer/Data.hs +++ b/src/LabyrinthServer/Data.hs @@ -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