labyrinth 0.1.0.0 → 0.1.5.0
raw patch · 3 files changed
+56/−30 lines, 3 filesdep +QuickCheckdep +jsondep +lensdep ~basedep ~containersdep ~template-haskell
Dependencies added: QuickCheck, json, lens, monad-loops
Dependency ranges changed: base, containers, template-haskell
Files
- labyrinth.cabal +37/−5
- src/LabyrinthServer.hs +15/−24
- testsuite/Main.hs +4/−1
labyrinth.cabal view
@@ -1,5 +1,5 @@ name: labyrinth-version: 0.1.0.0+version: 0.1.5.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@@ -10,7 +10,6 @@ license-file: LICENSE author: Alexey Kotlyarov maintainer: koterpillar@gmail.com--- copyright: category: Game build-type: Simple cabal-version: >=1.8@@ -25,13 +24,46 @@ executable labyrinth-server main-is: LabyrinthServer.hs- build-depends: base ==4.5.*, mtl ==2.1.*, template-haskell ==2.7.*, acid-state ==0.8.*, happstack-server ==7.1.*, derive ==2.5.*, safecopy ==0.8.*, parsec ==3.1.*, containers ==0.4.*, random ==1.0.*, text ==0.11.*, transformers ==0.3.*, MonadRandom ==0.1.*+ build-depends: base >= 4.5 && < 4.7+ , mtl ==2.1.*+ , template-haskell >= 2.7 && < 2.9+ , lens ==3.8.*+ , acid-state ==0.8.*+ , happstack-server ==7.1.*+ , derive ==2.5.*+ , safecopy ==0.8.*+ , parsec ==3.1.*+ , containers >= 0.4 && < 0.6+ , random ==1.0.*+ , text ==0.11.*+ , transformers ==0.3.*+ , MonadRandom ==0.1.*+ , json ==0.7.*+ , monad-loops ==0.3.* hs-source-dirs: src if (flag(static)) ghc-options: -static -optl-pthread -optl-static -Test-Suite tests+test-Suite tests type: exitcode-stdio-1.0 main-is: Main.hs- build-depends: base ==4.5.*, mtl ==2.1.*, template-haskell ==2.7.*, acid-state ==0.8.*, happstack-server ==7.1.*, derive ==2.5.*, safecopy ==0.8.*, parsec ==3.1.*, containers ==0.4.*, random ==1.0.*, text ==0.11.*, transformers ==0.3.*, MonadRandom ==0.1.*, HTF ==0.10.*, HUnit ==1.2.*+ build-depends: base >= 4.5 && < 4.7+ , mtl ==2.1.*+ , template-haskell >= 2.7 && < 2.9+ , lens ==3.8.*+ , acid-state ==0.8.*+ , happstack-server ==7.1.*+ , derive ==2.5.*+ , safecopy ==0.8.*+ , parsec ==3.1.*+ , containers >= 0.4 && < 0.6+ , random ==1.0.*+ , text ==0.11.*+ , transformers ==0.3.*+ , MonadRandom ==0.1.*+ , json ==0.7.*+ , monad-loops ==0.3.*+ , HTF ==0.10.*+ , HUnit ==1.2.*+ , QuickCheck >=2.6 && < 2.7 hs-source-dirs: src, testsuite
src/LabyrinthServer.hs view
@@ -1,6 +1,7 @@ module Main where import Control.Exception (bracket)+import Control.Lens import Control.Monad import Control.Monad.IO.Class @@ -14,7 +15,7 @@ import Happstack.Server hiding (result) -import Peeker+import qualified Text.JSON as J import System.Environment import System.Random@@ -23,15 +24,15 @@ import LabyrinthServer.Data -createLabyrinth :: (MonadIO m) => Int -> m Labyrinth-createLabyrinth n = do+createLabyrinth :: (MonadIO m) => Int -> Int -> Int -> m Labyrinth+createLabyrinth w h n = do gen <- liftIO getStdGen- let (l, gen') = generateLabyrinth 5 6 n gen+ let (l, gen') = generateLabyrinth w h n gen liftIO $ setStdGen gen' return l newId :: (MonadIO m) => m String-newId = sequence $ take 32 $ repeat $ liftIO $ randomRIO ('a', 'z')+newId = replicateM 32 $ liftIO $ randomRIO ('a', 'z') getPort :: IO Int getPort = do@@ -46,7 +47,7 @@ port <- getPort let conf = nullConf { port = port } bracket (openLocalState noGames)- (createCheckpointAndClose)+ createCheckpointAndClose (simpleHTTP conf . myApp) myApp :: AcidState Games -> ServerPart Response@@ -57,7 +58,6 @@ ++ map gameAction gameActions gameActions = [ makeMove , showLog- , cheat ] bodyPolicy = defaultBodyPolicy "/tmp/" 0 1000 1000@@ -72,32 +72,23 @@ createGame acid = dir "add" $ nullDir >> method POST >> do nullDir decodeBody bodyPolicy+ lWidth <- lookRead "width"+ lHeight <- lookRead "height" pCount <- lookRead "players" gameId <- newId- lab <- createLabyrinth pCount+ lab <- createLabyrinth lWidth lHeight pCount res <- update' acid $ AddGame gameId lab- if res- then ok $ toResponse "ok"- else ok $ toResponse "bad game"+ ok $ toResponse $ if res then "ok" else "bad game" listGames :: AcidState Games -> ServerPart Response listGames acid = dir "list" $ nullDir >> do- games <- query' acid $ GameList- ok $ toResponse $ intercalate ", " $ games--cheat :: AcidState Games -> GameId -> ServerPart Response-cheat acid gameId = dir "cheat" $ nullDir >> do- l <- query' acid $ ShowLabyrinth gameId- ok $ toResponse $ show l+ games <- query' acid GetGames+ ok $ toResponse $ J.encode $ gameListJSON games showLog :: AcidState Games -> GameId -> ServerPart Response showLog acid gameId = dir "log" $ nullDir >> do- l <- query' acid $ GameLog gameId- let str = intercalate "\n" $ map showMove l- ok $ toResponse str- where showMove m = "player " ++ show (getP rplayer m)- ++ ": " ++ show (getP rmove m)- ++ "\n" ++ show (getP rresult m)+ g <- query' acid $ GetGame gameId+ ok $ toResponse $ J.encode $ gameJSON g makeMove :: AcidState Games -> GameId -> ServerPart Response makeMove acid gameId = dir "move" $ nullDir >> method POST >> do
testsuite/Main.hs view
@@ -5,11 +5,14 @@ import {-@ HTF_TESTS @-} TestLabyrinth import {-@ HTF_TESTS @-} TestLabyrinth.Generate import {-@ HTF_TESTS @-} TestLabyrinth.Move.ChoosePosition+import {-@ HTF_TESTS @-} TestLabyrinth.Move.Conditional import {-@ HTF_TESTS @-} TestLabyrinth.Move.Grenade import {-@ HTF_TESTS @-} TestLabyrinth.Move.Movement+import {-@ HTF_TESTS @-} TestLabyrinth.Move.Query+import {-@ HTF_TESTS @-} TestLabyrinth.Move.Say import {-@ HTF_TESTS @-} TestLabyrinth.Move.Shoot+import {-@ HTF_TESTS @-} TestLabyrinth.Move.Surrender import {-@ HTF_TESTS @-} TestLabyrinth.ShowLabyrinth import {-@ HTF_TESTS @-} TestLabyrinth.ShowMove-import {-@ HTF_TESTS @-} TestPeeker main = htfMain htf_importedTests