labyrinth-server 0.1.1.0 → 0.1.2.0
raw patch · 5 files changed
+125/−130 lines, 5 filesdep +HTFdep +HUnitdep +QuickCheck
Dependencies added: HTF, HUnit, QuickCheck, bytestring, directory, http-types, parsec, unordered-containers, wai, wai-test
Files
- labyrinth-server.cabal +52/−3
- src/LabyrinthServer.hs +51/−31
- src/LabyrinthServer/Data.hs +9/−96
- src/Main.hs +5/−0
- testsuite/TestMain.hs +8/−0
labyrinth-server.cabal view
@@ -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
src/LabyrinthServer.hs view
@@ -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
src/LabyrinthServer/Data.hs view
@@ -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]+ ]
+ src/Main.hs view
@@ -0,0 +1,5 @@+module Main where++import LabyrinthServer++main = labyrinthMain
+ testsuite/TestMain.hs view
@@ -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