diff --git a/labyrinth-server.cabal b/labyrinth-server.cabal --- a/labyrinth-server.cabal +++ b/labyrinth-server.cabal @@ -1,5 +1,5 @@ name: labyrinth-server -version: 0.1.1.0 +version: 0.1.2.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 @@ -20,10 +20,13 @@ location: git://github.com/koterpillar/labyrinth-server.git executable labyrinth-server - main-is: LabyrinthServer.hs - other-modules: LabyrinthServer.Data + main-is: Main.hs + other-modules: LabyrinthServer + , 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.* @@ -42,8 +45,54 @@ , wai-websockets ==1.3.* , warp ==1.3.* , utf8-string ==0.3.* + , unordered-containers ==0.2.* , aeson ==0.6.* , shakespeare-css ==1.0.* , shakespeare-js ==1.1.* , hamlet ==1.1.* + , parsec ==3.1.* + , bytestring ==0.10.* hs-source-dirs: src + +test-Suite tests + type: exitcode-stdio-1.0 + main-is: TestMain.hs + 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.* + , unordered-containers ==0.2.* + , aeson ==0.6.* + , shakespeare-css ==1.0.* + , shakespeare-js ==1.1.* + , hamlet ==1.1.* + , parsec ==3.1.* + , bytestring ==0.10.* + + , HTF ==0.11.* + , HUnit ==1.2.* + , QuickCheck >=2.6 && < 2.7 + , bytestring ==0.10.* + , wai ==1.4.* + , wai-test ==1.3.* + , directory ==1.2.* + , http-types ==0.8.* + hs-source-dirs: src, testsuite diff --git a/src/LabyrinthServer.hs b/src/LabyrinthServer.hs --- a/src/LabyrinthServer.hs +++ b/src/LabyrinthServer.hs @@ -3,7 +3,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Main where +module LabyrinthServer where import Control.Applicative import Control.Concurrent @@ -22,11 +22,13 @@ import Data.Acid.Advanced (query', update') import Data.Acid.Local (createCheckpointAndClose) import Data.Aeson -import qualified Data.ByteString.UTF8 as BSU +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Lazy as BS import Data.List import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T +import qualified Data.Text.Encoding as E import qualified Data.String as S import Network.Wai.Handler.Warp @@ -47,6 +49,7 @@ import Labyrinth hiding (performMove) import LabyrinthServer.Data +import LabyrinthServer.JSON newId :: (MonadIO m) => m String newId = replicateM 32 $ liftIO $ randomRIO ('a', 'z') @@ -93,6 +96,30 @@ instance Yesod LabyrinthServer where defaultLayout = mainLayout +makeServer :: FilePath -> (LabyrinthServer -> IO a) -> IO a +makeServer dataPath cont = do + static <- static "static" + bracket + (openLocalStateFrom dataPath noGames) + createCheckpointAndClose $ + \acid -> do + watchers <- newMVar M.empty + cont $ LabyrinthServer acid static watchers + +labyrinthMain :: IO () +labyrinthMain = do + dataPath <- getDataPath + makeServer dataPath $ \server -> do + port <- liftM read $ envVarWithDefault "8080" "PORT" + ip <- envVarWithDefault "127.0.0.1" "OPENSHIFT_INTERNAL_IP" + app <- toWaiApp server + let intercept = WaiWS.intercept $ wsHandler server + let settings = defaultSettings { settingsPort = port + , settingsHost = Host ip + , settingsIntercept = intercept + } + runSettings settings app + instance RenderMessage LabyrinthServer FormMessage where renderMessage _ _ = defaultFormMessage @@ -103,37 +130,25 @@ ((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 + FormFailure errors -> returnCORSJson errors wsHandler :: LabyrinthServer -> WS.Request -> WS.WebSockets WSType () wsHandler site rq = do - let path = BSU.toString $ WS.requestPath rq + let path = T.unpack $ E.decodeUtf8 $ 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 +addCORSHeader :: MonadHandler m => m () +addCORSHeader = addHeader "Access-Control-Allow-Origin" "*" + +returnCORSJson :: (MonadHandler m, ToJSON a) => a -> m Value +returnCORSJson v = do + addCORSHeader + returnJson v + addWatcher :: (MonadIO m) => LabyrinthServer -> WatchTarget -> WSSink -> m () addWatcher site watch sink = liftIO $ modifyMVar_ (lsWatchers site) $ \watchers -> @@ -179,7 +194,7 @@ immediateResponse target = do site <- getYesod result <- watchTargetValue site target - returnJson result + returnCORSJson result mainLayout :: Widget -> Handler Html mainLayout widget = do @@ -212,7 +227,7 @@ lab <- createLabyrinth params gameId <- newId res <- update GameList $ AddGame gameId lab - returnJson (if res then "ok" else "bad game" :: String) + returnCORSJson (if res then "ok" else "bad game" :: String) getGameR :: GameId -> Handler Value getGameR gameId = immediateResponse (GameLog gameId) @@ -227,19 +242,24 @@ <$> areq intField (named "player") Nothing <*> areq textField (named "move") Nothing +parseMove' :: T.Text -> Either String Move +parseMove' str = case eitherDecode (BS.fromStrict $ E.encodeUtf8 str) of + Left err -> parseMove (T.unpack str) + Right m -> Right m + 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] + case parseMove' moveStr of + Left err -> returnCORSJson $ object ["error" .= err] Right move -> do res <- update (GameLog gameId) $ PerformMove gameId playerId move - returnJson $ show res + returnCORSJson res deleteDeleteGameR :: GameId -> Handler Value deleteDeleteGameR gameId = do update GameList $ RemoveGame gameId - returnJson ("ok" :: String) + returnCORSJson ("ok" :: String) getExampleMovesR :: Handler Value -getExampleMovesR = returnJson exampleMovesJSON +getExampleMovesR = returnCORSJson $ Sensitive True exampleMoves diff --git a/src/LabyrinthServer/Data.hs b/src/LabyrinthServer/Data.hs --- a/src/LabyrinthServer/Data.hs +++ b/src/LabyrinthServer/Data.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -15,9 +14,7 @@ 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 @@ -160,96 +157,12 @@ 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 + , 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] + ] diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,5 @@ +module Main where + +import LabyrinthServer + +main = labyrinthMain diff --git a/testsuite/TestMain.hs b/testsuite/TestMain.hs new file mode 100644 --- /dev/null +++ b/testsuite/TestMain.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} + +import Test.Framework + +import {-@ HTF_TESTS @-} TestLabyrinthServer +import {-@ HTF_TESTS @-} TestLabyrinthServer.JSON + +main = htfMain htf_importedTests