make http server actually able to play dominion...

Tested-on: collins x86_64 GNU/Linux

Dominion.hs

@@ -1,7 +1,8 @@
 module Dominion ( module Dominion.Game, module Dominion.Cards,
-                  module Dominion.Types, shuffleIO ) where
+                  module Dominion.Types, shuffleIO, Pretty(pretty) ) where
 
 import Dominion.Game
 import Dominion.Cards
 import Dominion.Types
-import Dominion.Stack ( shuffleIO )
+import Dominion.Stack ( shuffleIO )
+import Dominion.Pretty ( Pretty(pretty) )

Dominion/Pretty.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Dominion.Pretty ( Pretty(pretty) ) where
+
+import Dominion.Types
+import Data.List ( intercalate )
+
+class Pretty p where
+    pretty :: p -> String
+
+instance Pretty CardDescription where
+    pretty c = cname c++" ("++show (cprice c)++")" --  ["++ show (cid c)++"]"
+instance Pretty [CardDescription] where
+    pretty cs = intercalate ", " $ map pretty cs
+instance Pretty InfoMessage where
+    pretty (InfoMessage s) | 1==1 = s -- prevent overlapping match warning
+    pretty (GameOver s) = s
+    pretty (CardPlay p cs) = p ++ " played " ++ pretty cs
+    pretty (CardDraw p (Left n)) = p ++ " drew " ++ show n ++ " cards"
+    pretty (CardDraw _ (Right cs)) = "You drew " ++ pretty cs
+    pretty (CardDiscard p cs) = p ++ " discarded " ++ pretty cs
+    pretty (CardTrash p cs) = p ++ " trashed " ++ pretty cs
+    pretty (CardReveal p cs f) = p ++ " revealed " ++ pretty cs ++ " from " ++ f
+    pretty (CardBuy p cs) = p ++ " bought " ++ pretty cs
+    pretty (CardGain p cs) = p ++ " gained " ++ pretty cs
+    pretty (Reshuffled p) = p ++ " reshuffled"
+    pretty s = show s -- prevent crashing when we add message types
+instance Pretty Answer where
+    pretty (Choose s) = s
+    pretty (PickCard c) = pretty c
+instance Pretty MessageToClient where
+    pretty (Info i) = pretty i
+    pretty (Question _ m as (a0,a1)) =
+                unlines (["Question: "++show m,
+                          "Options:"]++zipWith showopt [1..] as++
+                         ["Enter "++showRange a0 a1++" separated by spaces: "])
+            where showopt n a =
+                      "  "++ show n++": "++pretty a
+                  showRange 0 1 = "up to 1 number"
+                  showRange 0 a = "up to " ++ show a ++ " numbers"
+                  showRange 1 1 = "1 number"
+                  showRange a b
+                      | a==b = show a ++ " numbers"
+                      | b==a+1 = show a ++ " or " ++ show b ++ " numbers"
+                      | otherwise = " from " ++ show a ++ " to " ++ show a
+                                    ++ " numbers"

HTTP/Dominion.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE PatternGuards #-}
 
-module HTTP.Dominion ( dominionHandler, MessageToGame(..), game ) where
+module HTTP.Dominion ( dominionHandler, MessageToGame(..) ) where
 
-import Dominion ( Card, MessageToClient, ResponseFromClient, play, evalGame,
+import Dominion ( Card, MessageToClient(Question, Info), QId, Answer,
+                  ResponseFromClient(ResponseFromClient),
+                  play, evalGame, pretty,
                   shuffleIO, allRecommended, allDecks )
 import qualified Dominion ( start )
-import TCP.Chan ( Output, pipe, readInput )
+import TCP.Chan ( Output, pipe, readInput, writeOutput )
 
 import HTTP.Response ( Response, jsPrintf, blank200, error404 )
 import HTTP.LoginServer ( Agent )
@@ -15,6 +17,7 @@ import System.Random ( randomRIO )
 import Data.Maybe ( fromMaybe )
 import Control.Monad ( forM_, forever )
 import Control.Concurrent ( forkIO )
+import Control.Concurrent.MVar ( MVar, newEmptyMVar, putMVar, takeMVar )
 
 data MessageToGame = StartGame
                    | NewPlayer Agent (Output MessageToClient)
@@ -24,6 +27,7 @@ data MessageToGame = StartGame
 dominionHandler :: String -> (Agent -> String -> IO ()) -> IO Handler
 dominionHandler area sendmess =
     do (i,o) <- pipe -- ResponseFromClient
+       latestq <- newEmptyMVar
        let handle a ps q =
                Message $ \st ->
                    do putStrLn $ "dominionHandler <o> "++show a++" "++
@@ -34,21 +38,27 @@ dominionHandler area sendmess =
                           state <- Dominion.start cls i decks
                           forkIO (evalGame play state >>= print)
                           return ()
-           initstate = DomState [] o startg
+           initstate = DomState [] o latestq startg
        return $ Handler initstate handle
 
 manageClient :: (Agent -> String -> IO ()) -> DomState -> (Agent, a)
              -> IO (String, Output MessageToClient)
 manageClient sendmess ds (a,_) =
     do (i,o) <- pipe
-       forkIO $ forever $ do x <- readInput i
-                             putStrLn ("got message "++show x++" for "++show a)
-                             -- FIXME: no privacy here!
-                             say sendmess ds ("for "++show a++": "++show x)
+       forkIO $ forever $
+              do x <- readInput i
+                 putStrLn ("got message for "++show a++":\n"++pretty x)
+                 mapM_ (sayto sendmess ds a) (lines $ pretty x)
+                 case x of
+                   Question qid _ as mnmx ->
+                       do putStrLn "got question..."
+                          putMVar (latestQ ds) (qid, as, mnmx)
+                   Info _ -> putStrLn "got info."
        return (show a, o)
 
 data DomState = DomState { clients :: [(Agent, String -> String)],
                            game :: Output ResponseFromClient,
+                           latestQ :: MVar (QId, [Answer], (Int,Int)),
                            start :: DomState -> IO () }
 
 handler :: String -> (Agent -> String -> IO ())
@@ -57,7 +67,7 @@ handler :: String -> (Agent -> String -> IO ())
         -> IO (DomState, Response)
 handler _ sendmess ds _ ["start"] _ =
     do putStrLn "game should start now..."
-       say sendmess ds "Game is starting! (just kidding)"
+       say sendmess ds "Game is starting!"
        say sendmess ds ("Players: "++unwords (map (show . fst) $ clients ds))
        start ds ds
        r <- blank200
@@ -81,11 +91,34 @@ handler _ sendmess ags a ["say"] q =
        say sendmess ags (show a++": "++msg)
        r <- blank200
        return (ags, r)
+handler _ sendmess ds a ["answer"] q =
+ do putStrLn "checking on the question... (should be maybe version)"
+    (qid, as, (mn,mx)) <- takeMVar $ latestQ ds
+    case lookup "q" q of
+      Just ns ->
+          do let toa x = case reads x of
+                           [(num,"")] | num < 1 -> []
+                                      | num > length as -> []
+                                      | otherwise -> [as !! (num-1)]
+                           _ -> []
+                 myas = concatMap toa $ words ns
+             if length myas > mx || length myas < mn
+                then sayto sendmess ds a "Bad answer!"
+                else writeOutput (game ds) $ ResponseFromClient qid myas
+      _ -> putStrLn "This doesn't seem quite right..."
+    r <- blank200
+    return (ds, r)
 handler _ _ ags _ _ _ =
     do putStrLn "handler _ _ _ _"
        r <- error404
        return (ags, r)
 
+sayto :: (Agent -> String -> IO ()) -> DomState -> Agent -> String -> IO ()
+sayto sendmess ags a s =
+    case lookup a (clients ags) of
+      Just f -> sendmess a (f s)
+      Nothing -> return ()
+
 say :: (Agent -> String -> IO ()) -> DomState -> String -> IO ()
 say sendmess ags s =
     forM_ (clients ags) $ \(a,f) -> sendmess a (f s)

htdocs/index.html

@@ -16,7 +16,7 @@
 <textarea id="silly" cols="80" rows="10" readonly></textarea>
 <br/>
 <input id="sillyinput" type="text" size="60"/>
-<input id="sillysay" type="submit" value="silly"/>
+<input id="sillyanswer" type="submit" value="Answer"/>
 <input id="startgame" type="submit" value="Start game!"/>
 </div>
 
@@ -98,11 +98,17 @@
     $.ajax({url:"/silly/say",data:{u:$.user,q:inp.attr("value")}});
     inp.val("");
   }
+  function answer(){
+    var inp = $("#sillyinput");
+    var txt = $("#silly");
+    $.ajax({url:"/silly/answer",data:{u:$.user,q:inp.attr("value")}});
+    inp.val("");
+  }
   function startgame(){
     $.ajax({url:"/silly/start",data:{u:$.user}});
   }
   $("#say").bind("click",function(e){say()});
-  $("#sillysay").bind("click",function(e){silly()});
+  $("#sillyanswer").bind("click",function(e){answer()});
   $("#startgame").bind("click",function(e){startgame()});
   $("#input").bind("keypress",function(e){if(e.which==13)say();});
   $("#sillyinput").bind("keypress",function(e){if(e.which==13)silly();});

testdom.hs

@@ -10,11 +10,11 @@ import NamePicker ( simpleNamedClient, pickNames )
 
 import Control.Concurrent ( forkIO )
 import TCP.Chan ( Input, Output, readInput, writeOutput, pipe )
-import Control.Monad ( forever, replicateM, forM_ )
+import Control.Monad ( forever, replicateM )
 import Control.Monad.State ( execStateT,
                              StateT, runStateT, put, get, modify, liftIO )
 import Data.Char ( toLower, isSpace )
-import Data.List ( sortBy, intercalate )
+import Data.List ( sortBy )
 import Data.Ord ( comparing )
 import System.IO ( hFlush, stdout )
 import System.Environment ( getArgs )
@@ -63,30 +63,6 @@ stateToPlayer ss ri aq s0 = PlayerFunctions
     where this = stateToPlayer ss ri aq
           (***) f g (a,b) = (f a,g b)
 
-class Pretty p where
-    pretty :: p -> String
-
-instance Pretty CardDescription where
-    pretty c = cname c++" ("++show (cprice c)++")" --  ["++ show (cid c)++"]"
-instance Pretty [CardDescription] where
-    pretty cs = intercalate ", " $ map pretty cs
-instance Pretty InfoMessage where
-    pretty (InfoMessage s) | 1==1 = s -- prevent overlapping match warning
-    pretty (GameOver s) = s
-    pretty (CardPlay p cs) = p ++ " played " ++ pretty cs
-    pretty (CardDraw p (Left n)) = p ++ " drew " ++ show n ++ " cards"
-    pretty (CardDraw _ (Right cs)) = "You drew " ++ pretty cs
-    pretty (CardDiscard p cs) = p ++ " discarded " ++ pretty cs
-    pretty (CardTrash p cs) = p ++ " trashed " ++ pretty cs
-    pretty (CardReveal p cs f) = p ++ " revealed " ++ pretty cs ++ " from " ++ f
-    pretty (CardBuy p cs) = p ++ " bought " ++ pretty cs
-    pretty (CardGain p cs) = p ++ " gained " ++ pretty cs
-    pretty (Reshuffled p) = p ++ " reshuffled"
-    pretty s = show s -- prevent crashing when we add message types
-instance Pretty Answer where
-    pretty (Choose s) = s
-    pretty (PickCard c) = pretty c
-
 stdioClient :: String -> Input MessageToClient -> Output ResponseFromClient -> IO ()
 stdioClient name = client (stateToPlayer status info answer "") name
     where status _ = return () -- status = liftIO . hPutStrLn stderr
@@ -96,11 +72,7 @@ stdioClient name = client (stateToPlayer status info answer "") name
           answer m as (a0,a1) =
               do get >>= liftIO . putStrLn
                  put ""
-                 liftIO $ putStrLn $ "Question: " ++ show m
-                 liftIO $ putStrLn "Options:"
-                 forM_ (zip [1..] as) $
-                   \(n,a) -> liftIO $ putStrLn $ "  " ++ show n ++ ": "
-                                                 ++ pretty a
+                 liftIO $ putStrLn $ pretty $ Question 0 m as (a0,a1)
                  ans <- untilJust $ do
                    liftIO $ putStr $ "Enter " ++ showRange a0 a1
                               ++ " separated by spaces: "