\begin{code} {-# LANGUAGE CPP, TupleSections, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings #-} -- Do not forget -threaded! -- -- x #define SNAP module Game.Hanabi.Backend(server, #ifdef WARP hanabiApp, #endif Options(..), defaultOptions, module Game.Hanabi) where import Game.Hanabi hiding (main) import Game.Hanabi.Msg import Data.Maybe(fromJust, isJust) import System.Random #ifdef TFRANDOM import System.Random.TF #endif import Control.Concurrent import Network.Socket import Network.WebSockets import System.IO import System.IO.Error(isEOFError) import Control.Exception import Data.Char(isSpace) import Data.List(sort) import Data.Time import System.Console.GetOpt import System.Environment import System.Exit import Control.Monad import Control.Monad.IO.Class(MonadIO, liftIO) -- import System.Timeout import Data.Hashable(hash) import Data.Text(Text, unpack, pack) import qualified Data.IntMap as IntMap import qualified Data.Map as Map #ifdef SNAP import Network.WebSockets.Snap import Snap.Http.Server.Config import Snap.Http.Server import Data.ByteString.UTF8(fromString) #else # ifdef WARP import Network.Wai.Handler.WebSockets import Network.Wai.Handler.Warp as Warp import Network.Wai(Application, responseLBS) import Network.HTTP.Types(status400) # endif #endif #ifdef AESON import Data.Text.Encoding(decodeUtf8) import Data.ByteString.Lazy(toStrict) import Data.Aeson #endif data Flag = Port Int -- x | Socket FilePath | Interactive cmdOpts :: [OptDescr Flag] cmdOpts = [ Option ['p'] ["port-number"] (ReqArg (Port . toEnum . readOrErr msgp) "PORT_NUMBER") "use port number PORT_NUMBER" ] where readOrErr msg xs = case reads xs of [(i,"")] | i>=0 -> i _ -> error msg msgp = "--port-number (or -p) takes a non-negative integral value specifying the port number." readOpts :: IO ([Flag], [String]) readOpts = do argv <- getArgs case (getOpt Permute cmdOpts argv) of (o,n,[] ) -> return (o,n) (_,_,errs) -> do hPutStrLn stderr (concat errs) usage exitFailure usage :: IO () usage = do progname <- getProgName hPutStrLn stderr $ usageInfo ("Usage: "++progname++" [OPTION...]") cmdOpts procFlags :: Options -> [Flag] -> Options procFlags = foldl procFlag procFlag :: Options -> Flag -> Options procFlag opt (Port i) = opt{port=i} server :: Options -> IO () server opt = do (flags, _args) <- readOpts let options = procFlags opt flags withSocketsDo $ do hPutStrLn stderr $ "hanabi-dealer server " ++ version options beginCT <- getCurrentTime hPutStrLn stderr ("started at " ++ show beginCT) #ifdef WARP app <- hanabiApp options $ \_ resp -> resp $ responseLBS status400 [] "Not a WebSocket request." Warp.run (port options) app #else params <- mkParams options # ifdef SNAP httpServe (setPort (port options) defaultConfig) $ runWebSocketsSnap $ loop params # else runServer "127.0.0.1" (port options) $ loop params # endif #endif #ifdef WARP hanabiApp :: Options -> Application -> IO Application hanabiApp options fallbackApp = do params <- mkParams options return $ websocketsOr defaultConnectionOptions (loop params) fallbackApp #endif type GameData = IntMap.IntMap ([MVar ViaWebSocket], MVar ([Card], Maybe (EndGame,[State],[Move]))) data Params g = Params{gen :: g, mvTIDToMVH :: MVar GameData, conn :: Connection, versionString :: String, gsConstructorMap :: Map.Map String (IO (DynamicStrategy IO)) } #ifdef TFRANDOM mkParams :: Options -> IO (Params TFGen) #else mkParams :: Options -> IO (Params StdGen) #endif mkParams options = do g <- newGen mv <- newMVar (IntMap.empty::GameData) return Params{gen = g, mvTIDToMVH = mv, versionString = version options, gsConstructorMap = Map.fromList $ strategies options, conn = error "Game.Hanabi.Backend.server: should not happen"} -- Well, this is not a loop any longer.... loop :: RandomGen g => Params g -> PendingConnection -> IO () loop params socket = do c <- acceptRequest socket #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. let p = params{conn = c} #else g <- newGen let p = params{gen = g, conn = c} #endif withPingThread c 25 (return ()) $ fmap (const ()) $ answerHIO p endecodeX :: Maybe Verbosity -> Msg -> Text endecodeX Nothing = endecode -- endecodeX Nothing = pack . show . prettyMsg verbose endecodeX (Just verb) = pack . prettyMsg verb endecode :: Msg -> Text #ifdef AESON endecode = decodeUtf8 . toStrict . encode #else endecode = pack . show . show #endif data ViaWebSocket = VWS {connection :: Connection, verbVWS :: Maybe Verbosity, sendFullHistory :: Bool} instance (MonadIO m) => Strategy ViaWebSocket m where strategyName _p = return "via WebSocket" move views@(v:_) moves vh = liftIO $ do let truncate = if sendFullHistory vh then id else take $ numPlayers $ gameSpec $ publicView v msg = WhatsUp "via WebSocket" (truncate views) (truncate moves) sendTextData (connection vh) $ endecodeX (verbVWS vh) msg mov <- repeatReadingAMoveUntilSuccess (connection vh) v return (mov, vh) where repeatReadingAMoveUntilSuccess :: Connection -> PrivateView -> IO Move repeatReadingAMoveUntilSuccess conn v = do str <- fmap unpack $ receiveData conn let mvstr = case reads str of [(mvs,rest)] | all isSpace rest -> mvs _ -> str case reads mvstr of [(mv, rest)] | all isSpace rest -> if isMoveValid v mv then return mv else do sender conn "Invalid Move" repeatReadingAMoveUntilSuccess conn v _ -> sender conn ("Parse error.\n"++help) >> repeatReadingAMoveUntilSuccess conn v sender conn = sendTextData conn . endecodeX (verbVWS vh) . Str observe _ [] _ = return () observe (v:_) (m:_) vh = liftIO $ sendTextData (connection vh) $ endecodeX (verbVWS vh) $ WhatsUp1 v m watch :: Connection -> Maybe Verbosity -> State -> [Move] -> IO () watch conn mbVerb st mvs = sendTextData conn $ endecodeX mbVerb $ Watch st $ take 1 mvs answerHIO :: RandomGen g => Params g -> IO () answerHIO params = do available Nothing (mvTIDToMVH params) (conn params) hPutStrLn stderr "trying to receive data" eithinp <- try $ receiveDataMessage $ conn params hPutStrLn stderr $ "received " ++ show eithinp let (g1,g2) = split $ gen params case eithinp of Left e | isEOFError e -> hPutStrLn stderr $ show e | otherwise -> hPutStrLn stderr $ show e Right input -> do let inp = unpack $ fromDataMessage input hPutStrLn stderr inp case reads inp of [(cmdl, _)] -> interpret Nothing cmdl params{gen=g1} _ -> interpret (Just verbose) inp params{gen=g1} answerHIO params{gen=g2} sendFullHistoryInFact = False wordsBy :: (a->Bool) -> [a] -> [[a]] wordsBy pred xs = case break pred xs of (tk, []) -> [tk] (tk,_:dr) -> tk : wordsBy pred dr interpret :: RandomGen g => Maybe Verbosity -> String -> Params g -> IO () interpret mbVerb inp params = let sender :: String -> IO () sender = sendTextData (conn params) . endecodeX mbVerb . Str createR observe creater args = case reads args of [(rule,rest)] | isRuleValid rule -> createD observe creater rule rest _ -> createD observe creater defaultRule args createD observe from rule args = case reads args of [(deck,';':rest)] | sort (cardBag rule) == sort deck -> create observe from rule deck args | otherwise -> sender $ "Invalid deck!\ndeck = " ++ show deck _ -> create observe from rule [] args create :: Bool -> Maybe Int -> Rule -> [Card] -> String -> IO () create observe from rule deck args = case wordsBy (==',') args of is | numAllies > 0 -> if numAllies >= 9 then sender "Too many teammates!\n" else case dropWhile (\s -> isWS s || s `Map.member` gsConstructorMap params) is of alg:_ -> sender $ "Algorithm " ++ alg ++ " 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 _ -> hash tidstr -- Just for future compatibility. mvFinalSituation <- newEmptyMVar :: IO (MVar ([Card], Maybe (EndGame,[State],[Move]))) modifyMVar_ (mvTIDToMVH params) (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 -> 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 params ixSs <- sequence $ zipWith constructor [0..] is sender "starting the game\n" let playerList | observe = ixSs |otherwise= mkDS "via WebSocket" (VWS (conn params) mbVerb sendFullHistoryInFact) : ixSs (playOrder,g) = orderPlayers from (gen params) playerList shuffled | null deck = fst $ createDeck rule g | otherwise = deck eithFinalSituation <- try $ if observe then sender ("The initial deck is " ++ show shuffled) >> startFromCards (GS numAllies rule) [watch (conn params) mbVerb] playOrder shuffled else startFromCards (GS (succ numAllies) rule) [] playOrder shuffled finalSituation <- case eithFinalSituation of Left e -> do hPutStrLn stderr $ displayException (e::SomeException) return Nothing Right (fs@(eg,sts,mvs),_) -> return $ Just $ if sendFullHistoryInFact then fs else (eg, truncate sts, truncate mvs) where truncate = take $ numPlayers $ gameSpec $ publicState $ head sts sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame shuffled finalSituation putMVar mvFinalSituation (shuffled, finalSituation) where numAllies = length is _ -> sender "The arguments of the `create' command could not be parsed." in case lex inp of [("version", _)] -> sender $ "hanabi-dealer server " ++ versionString params [("create", args)] -> createR False (Just 0) args [("from", args)] -> case reads args of [(n, ars)] -> createR False (Just n) ars _ -> sender "Parse error. The player number expected." [("observe",args)] -> case reads args of [(n, ars)] -> createR True (Just n) ars _ -> createR True Nothing args [("shuffle",args)] -> createR False Nothing args [("available", s)] | all isSpace s -> when (isJust mbVerb) $ available mbVerb (mvTIDToMVH params) (conn params) [("attend", arg)] -> case reads arg of [(gid, s)] | all isSpace s -> do tidToMVH <- readMVar $ mvTIDToMVH params case IntMap.lookup gid tidToMVH of Nothing -> sender $ "Could not find the game ID " ++ show gid Just (mvhs, mvFinalSituation) -> do emptyMVHs <- fmap (map fst . filter snd . zip mvhs) $ mapM isEmptyMVar mvhs case emptyMVHs of emvh:_ -> putMVar emvh (VWS (conn params) mbVerb sendFullHistoryInFact) >> sender "Successfully registered to the game.\n" [] -> sender "The game already has enough number of players.\n" (initialDeck, finalSituation) <- readMVar mvFinalSituation sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame initialDeck finalSituation -- This could be from the viewpoint of this player. _ -> sender "The arguments of the `attend' command could not be parsed." _ -> sender $ inp ++ " : command unknown\n" ++ commandHelp available :: Maybe Verbosity -> MVar GameData -> Connection -> IO () available mbVerb mvTIDToMVH conn = do tidToMVH <- readMVar mvTIDToMVH -- availableGames <- IntMap.traverse filt tidToMVH games <- mapM fun $ IntMap.toAscList $ fmap fst tidToMVH let availableGames = filter (\(_,(n,_)) -> n/=0) games sendTextData conn $ endecodeX mbVerb $ PrettyAvailable availableGames where fun (gameid, mvhs) = do emptyMVHs <- filterM isEmptyMVar mvhs return (gameid, (length emptyMVHs, length mvhs)) commandHelp :: String commandHelp = "`create 0' : create a two-player game, call for a player, then start the game. The game ID will be printed.\n" ++ "`create 0,0' : create a three-player game, call for two players, then start the game. The game ID will be printed.\n" ++ " etc. up to nine-player game.\n" ++ " (`0' means a human player. We plan to add various algorithmic players.)\n" ++ "`attend <>' : attend the game identified by the game ID.\n" ++ "'available' : request the list of games calling for players.\n" \end{code}