\begin{code} {-# LANGUAGE CPP, TupleSections, MultiParamTypeClasses, FlexibleInstances #-} -- Do not forget -threaded! -- -- x #define SNAP module Game.Hanabi.Backend(main') where 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 #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(isPrefixOf) import Data.Time import System.Console.GetOpt import System.Environment import System.Exit import Control.Monad -- These are for reporting resource usage. #if __GLASGOW_HASKELL__ >= 700 import GHC.Stats #endif -- import Control.Monad.Par.Class -- import Control.Monad.Par.IO import Control.Monad.IO.Class(MonadIO, liftIO) import System.Timeout import Data.Hashable(hash) import Data.Text(unpack, pack) -- import Control.Concurrent.ParallelIO(stopGlobalPool) -- import Data.Map #ifdef UNIX -- as suggested by /usr/share/doc/libghc6-network-doc/html/Network.html import System.Posix hiding (Default) #endif import qualified Data.IntMap as IntMap #ifdef SNAP import Network.WebSockets.Snap import Snap.Http.Server.Config import Snap.Http.Server import Data.ByteString.UTF8(fromString) #endif #ifdef AESON import Data.Text.Encoding(decodeUtf8) import Data.ByteString.Lazy(toStrict) import Data.Aeson #endif portID = 8720 {- trusted "localhost" = True trusted "127.0.0.1" = True trusted hostname = "133.54." `isPrefixOf` hostname deadlineTO = 30 * minutes minutes = 60*1000000 -} 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 data HowToServe = Network Int data ServerOptions = SO {howToServe :: HowToServe} defaultSO = SO {howToServe = Network portID} procFlags :: [Flag] -> ServerOptions procFlags = foldl procFlag defaultSO procFlag :: ServerOptions -> Flag -> ServerOptions procFlag st (Port i) = st{howToServe = Network i} main = main' "hoge" main' :: String -> IO () main' versionString = do (flags, _args) <- readOpts let so = procFlags flags withSocketsDo $ do hPutStrLn stderr $ "hanabi-dealer server " ++ versionString beginCT <- getCurrentTime hPutStrLn stderr ("started at " ++ show beginCT) #ifdef TFRANDOM gen <- newTFGen #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 #else runServer "127.0.0.1" portID #endif $ loop g1 stat tidToMVH loop :: RandomGen g => g -> (String, ServerOptions) -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> PendingConnection -> IO () loop gen stat tidToMVH socket = do #ifdef DEBUG #else # ifdef TFRANDOM gen <- newTFGen # else gen <- newStdGen # 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. endecodeX Nothing = endecode -- endecodeX Nothing = pack . show . prettyMsg verbose endecodeX (Just verb) = pack . prettyMsg verb #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 -- sendTextData (connection vh) $ endecodeX (verbVWS vh) $ Str "Your turn.\n" 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 data IndexedStrategy = IxS Int Dynamic ixSConstructorMap :: IntMap.IntMap (IO IndexedStrategy) ixSConstructorMap = IntMap.fromAscList $ zipWith (\i iodyn -> (i, fmap (IxS i) iodyn)) [1..] [ -- return $ toDyn $ Sontakki emptyDefault ] ixSMap :: (MonadIO m) => IntMap.IntMap (m String, [PrivateView] -> [Move] -> Dynamic -> m (Move, Dynamic)) ixSMap = IntMap.fromAscList $ zip [0..] [ (return "Via WebSocket", \pvs mvs dyn -> fmap (\(m,p)->(m, toDyn p)) $ move pvs mvs (fromDyn dyn (error "Type error." :: ViaWebSocket))) -- , (return "Sontakki", \pvs mvs (IxS i dyn) -> fmap (\(m,p)->(m, IxS i $ toDyn p)) $ move pvs mvs (fromDyn dyn (Sontakki emptyDefault))) -- , ... ] ixSMapSize :: Int ixSMapSize = IntMap.size (ixSMap :: IntMap.IntMap (IO String, [PrivateView] -> [Move] -> Dynamic -> IO (Move, Dynamic))) instance (MonadIO m) => Strategy IndexedStrategy m where strategyName mp = do IxS i _dyn <- mp fst $ ixSMap IntMap.! (i `mod` ixSMapSize) -- "Array of Strategies" 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 () answerHIO :: RandomGen g => g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> (String, ServerOptions) -> Connection -> IO () answerHIO gen mvTIDToMVH tup@(_, _) conn = do available Nothing mvTIDToMVH conn hPutStrLn stderr "trying to receive data" eithinp <- try $ receiveDataMessage conn hPutStrLn stderr $ "received " ++ show eithinp let (g1,g2) = split gen 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 g1 mvTIDToMVH tup conn _ -> interpret (Just verbose) inp g1 mvTIDToMVH tup conn answerHIO g2 mvTIDToMVH tup conn sendFullHistoryInFact = False 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 = let sender :: String -> IO () sender = sendTextData conn . endecodeX mbVerb . Str in case lex inp of [("version", _)] -> sender $ "hanabi-dealer server "++versionString [("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)] 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 (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 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 -- let finalSituation = either (\e -> const Nothing (e::ConnectionException)) (Just.(fst.fst)) eithFinalSituation 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 $ endecodeX mbVerb $ PrettyEndGame finalSituation putMVar mvFinalSituation finalSituation where numAllies = length is _ -> sender "The arguments of the `create' command could not be parsed." [("available", s)] | all isSpace s -> when (isJust mbVerb) $ available mbVerb mvTIDToMVH conn [("attend", arg)] -> case reads arg of [(gid, s)] | all isSpace s -> do tidToMVH <- readMVar mvTIDToMVH 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 mbVerb sendFullHistoryInFact) >> sender "Successfully registered to the game.\n" [] -> sender "The game already has enough number of players.\n" finalSituation <- readMVar mvFinalSituation sendTextData conn $ endecodeX mbVerb $ PrettyEndGame 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 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 = "`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}