summaryrefslogtreecommitdiff
path: root/Game/Hanabi/Backend.lhs
diff options
context:
space:
mode:
Diffstat (limited to 'Game/Hanabi/Backend.lhs')
-rw-r--r--Game/Hanabi/Backend.lhs74
1 files changed, 40 insertions, 34 deletions
diff --git a/Game/Hanabi/Backend.lhs b/Game/Hanabi/Backend.lhs
index 6282c3d..33df97d 100644
--- a/Game/Hanabi/Backend.lhs
+++ b/Game/Hanabi/Backend.lhs
@@ -10,7 +10,6 @@ import Game.Hanabi hiding (main)
import Game.Hanabi.Msg
import Data.Maybe(fromJust, isNothing, isJust)
-import Data.Dynamic
import System.Random
#ifdef TFRANDOM
import System.Random.TF
@@ -56,6 +55,7 @@ import System.Posix hiding (Default)
#endif
import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
#ifdef SNAP
import Network.WebSockets.Snap
@@ -103,20 +103,20 @@ usage = do progname <- getProgName
hPutStrLn stderr $ usageInfo ("Usage: "++progname++" [OPTION...]") cmdOpts
data HowToServe = Network Int
-data ServerOptions = SO {howToServe :: HowToServe}
-defaultSO = SO {howToServe = Network portID}
-procFlags :: [Flag] -> ServerOptions
+defaultSO = Network portID
+
+procFlags :: [Flag] -> HowToServe
procFlags = foldl procFlag defaultSO
-procFlag :: ServerOptions -> Flag -> ServerOptions
-procFlag st (Port i) = st{howToServe = Network i}
+procFlag :: HowToServe -> Flag -> HowToServe
+procFlag st (Port i) = Network i
main = main' "hoge"
main' :: String -> IO ()
main' versionString = do
(flags, _args) <- readOpts
- let so = procFlags flags
+ let Network pid = procFlags flags
withSocketsDo $ do
hPutStrLn stderr $ "hanabi-dealer server " ++ versionString
beginCT <- getCurrentTime
@@ -126,25 +126,24 @@ main' versionString = do
#else
gen <- newStdGen
#endif
- let (g1,g2) = split gen
- let stat = (versionString, so)
tidToMVH <- newMVar (IntMap.empty::IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move]))))
#ifdef SNAP
- httpServe (setPort portID defaultConfig) $ runWebSocketsSnap
+ httpServe (setPort pid defaultConfig) $ runWebSocketsSnap
#else
- runServer "127.0.0.1" portID
+ runServer "127.0.0.1" pid
#endif
- $ loop g1 stat tidToMVH
+ $ loop gen tidToMVH versionString
loop :: RandomGen g =>
g
- -> (String, ServerOptions)
-> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move]))))
+ -> String
-> PendingConnection
-> IO ()
-loop gen stat tidToMVH socket = do
+loop gen tidToMVH ver socket = do
#ifdef DEBUG
+-- In this case, every time this program is run, the gen is refreshed, but the same gen (and thus the same card deck) is always used.
#else
# ifdef TFRANDOM
gen <- newTFGen
@@ -153,9 +152,7 @@ loop gen stat tidToMVH socket = do
# endif
#endif
conn <- acceptRequest socket
- let (g1,g2) = split gen
- withPingThread conn 30 (return ()) $ fmap (const ()) $ answerHIO g1 tidToMVH stat conn
--- loop g2 stat tidToMVH socket -- Seemingly this is unnecessary.
+ withPingThread conn 30 (return ()) $ fmap (const ()) $ answerHIO gen tidToMVH ver conn
endecodeX Nothing = endecode
@@ -191,6 +188,7 @@ instance (MonadIO m) => Strategy ViaWebSocket m where
observe _ [] _ = return ()
observe (v:_) (m:_) vh = liftIO $ sendTextData (connection vh) $ endecodeX (verbVWS vh) $ WhatsUp1 v m
+{-
data IndexedStrategy = IxS Int Dynamic
ixSConstructorMap :: IntMap.IntMap (IO IndexedStrategy)
ixSConstructorMap = IntMap.fromAscList $ zipWith (\i iodyn -> (i, fmap (IxS i) iodyn)) [1..] [
@@ -209,12 +207,17 @@ instance (MonadIO m) => Strategy IndexedStrategy m where
move pvs mvs ixs@(IxS i dyn) = fmap (\(m,p)->(m, IxS i p)) $ (snd $ ixSMap IntMap.! (i `mod` ixSMapSize)) pvs mvs dyn -- modulo is used in order to avoid failure.
observe vs ms (IxS 0 dyn) = observe vs ms (fromDyn dyn (error "Type error." :: ViaWebSocket))
observe _ _ _ = return ()
+-}
+gsConstructorMap :: Map.Map String (IO (DynamicStrategy IO))
+gsConstructorMap = Map.fromList [
+ -- ("Sontakki", return $ mkDS (Sontakki emptyDefault))
+ ]
answerHIO :: RandomGen g =>
- g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> (String, ServerOptions) -> Connection -> IO ()
-answerHIO gen mvTIDToMVH tup@(_, _) conn = do
+ g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> String -> Connection -> IO ()
+answerHIO gen mvTIDToMVH tup conn = do
available Nothing mvTIDToMVH conn
hPutStrLn stderr "trying to receive data"
eithinp <- try $ receiveDataMessage conn
@@ -231,10 +234,13 @@ answerHIO gen mvTIDToMVH tup@(_, _) conn = do
answerHIO g2 mvTIDToMVH tup conn
sendFullHistoryInFact = False
-
+wordsBy :: (a->Bool) -> [a] -> [[a]]
+wordsBy pred xs = case break pred xs of (tk, []) -> [tk]
+ (tk,_:dr) -> tk : wordsBy pred dr
+isWS = (`elem` ["0", "WS", "via WebSocket"])
interpret :: RandomGen g =>
- Maybe Verbosity -> String -> g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> (String, ServerOptions) -> Connection -> IO ()
-interpret mbVerb inp gen mvTIDToMVH tup@(versionString, _) conn
+ Maybe Verbosity -> String -> g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> String -> Connection -> IO ()
+interpret mbVerb inp gen mvTIDToMVH versionString conn
= let sender :: String -> IO ()
sender = sendTextData conn . endecodeX mbVerb . Str
in case lex inp of
@@ -242,13 +248,13 @@ interpret mbVerb inp gen mvTIDToMVH tup@(versionString, _) conn
[("create", args)] -> case reads args of [(rule,rest)] | isRuleValid rule -> create rule rest
_ -> create defaultRule args
where create rule args =
- case reads $ '[':args++"]" of
- [(is,"")] | numAllies > 0 -> if numAllies >= 9
- then sender "Too many teemmates!\n"
- else if any (>=ixSMapSize) is
- then sender $ "Algorithm " ++ shows (maximum is) " not implemented yet.\n"
- else do
- pl2MVHs <- sequence [ fmap (pl,) newEmptyMVar | (pl,0) <- zip [0..] is ] :: IO [(Int, MVar ViaWebSocket)]
+ case wordsBy (==',') args of
+ is | numAllies > 0 -> if numAllies >= 9
+ then sender "Too many teemmates!\n"
+ else case dropWhile (\s -> isWS s || s `Map.member` gsConstructorMap) is of
+ alg:_ -> sender $ "Algorithm " ++ shows (maximum is) " not implemented yet.\n"
+ [] -> do
+ pl2MVHs <- sequence [ fmap (pl,) newEmptyMVar | (pl,name) <- zip [0..] is, isWS name ] :: IO [(Int, MVar ViaWebSocket)]
tidstr <- fmap show myThreadId
let gid = case [ i | ("ThreadId", xs) <- lex tidstr, (i, ys) <- reads xs, all isSpace ys ] of
[i] -> i
@@ -256,13 +262,13 @@ interpret mbVerb inp gen mvTIDToMVH tup@(versionString, _) conn
mvFinalSituation <- newEmptyMVar :: IO (MVar (Maybe (EndGame,[State],[Move])))
modifyMVar_ mvTIDToMVH (return . IntMap.insert gid (map snd pl2MVHs, mvFinalSituation)) -- IntMap.insert replaces with the new value if the key already exists. This behavior is good here because that means the game for the threadId has either finished or been killed and the threadId is reused.
sender $ "The ID of the game is " ++ show gid
- let constructor :: Int -> Int -> IO IndexedStrategy
- constructor plIx 0 = do vws <- readMVar $ fromJust $ lookup plIx pl2MVHs
- return $ IxS 0 $ toDyn vws
- constructor _ algIx = fromJust $ IntMap.lookup algIx ixSConstructorMap
+ let constructor :: Int -> String -> IO (DynamicStrategy IO)
+ constructor plIx algIx | isWS algIx = do vws <- readMVar $ fromJust $ lookup plIx pl2MVHs
+ return $ mkDS "via WebSocket" vws
+ constructor _ algIx = fromJust $ Map.lookup algIx gsConstructorMap
ixSs <- sequence $ zipWith constructor [0..] is
sender "starting the game\n"
- eithFinalSituation <- try $ start (GS (succ numAllies) rule) (IxS 0 (toDyn $ VWS conn mbVerb sendFullHistoryInFact) : ixSs) gen
+ eithFinalSituation <- try $ start (GS (succ numAllies) rule) (mkDS "via WebSocket" (VWS conn mbVerb sendFullHistoryInFact) : ixSs) gen
-- let finalSituation = either (\e -> const Nothing (e::ConnectionException)) (Just.(fst.fst)) eithFinalSituation
finalSituation <- case eithFinalSituation of
Left e -> do hPutStrLn stderr $ displayException (e::SomeException)