hanabi-dealer-0.15.1.1: Game/Hanabi/Backend.lhs
\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, toLower, isAlpha)
import Data.List(sort, transpose, tails)
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 | Lazy -- x | Socket FilePath | Interactive
cmdOpts :: [OptDescr Flag]
cmdOpts = [ Option ['p'] ["port-number"] (ReqArg (Port . toEnum . readOrErr msgp) "PORT_NUMBER") "use port number PORT_NUMBER"
, Option ['l'] ["lazy"] (NoArg Lazy) "initialize lazily. This may cause the first game to take a prohibitive long time."
]
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}
procFlag opt Lazy = opt{lazy=True}
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)
hPutStrLn stderr "Preloading algorithms.... This may take some minutes depending on the set of strategies."
constrAssoc <- mapM sequenceA [ (name, crs $ lazy options) | (name, Just crs) <- strategies options]
-- foldr seq (hPutStrLn stderr "Done.") $ map snd constrAssoc
hPutStrLn stderr "Done."
return Params{gen = g, mvTIDToMVH = mv, versionString = version options, gsConstructorMap = Map.fromList constrAssoc, 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
repeatReadingAMoveUntilSuccess conn v
_ -> sender conn (Str ("Parse error.\n"++help)) >> repeatReadingAMoveUntilSuccess conn v
sender conn = sendTextData conn . endecodeX (verbVWS vh)
observe _ [] _ = return ()
observe (v:_) (m:_) vh = liftIO $ sendTextData (connection vh) $ endecodeX (verbVWS vh) $ WhatsUp1 v m
observeEndGame d eg vh = do
liftIO $ sendTextData (connection vh) $ endecodeX (verbVWS vh) $ PrettyEndGame d $ Just eg
return vh
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 rest
| 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
newGame 1 [] (gen params) playerList mvFinalSituation
where numAllies = length is
newGame :: (RandomGen g) =>
Int -> [Int] -> g -> [DynamicStrategy IO] -> MVar ([Card], Maybe (EndGame, [State], [Move])) -> IO ()
newGame ntimes scores g0 playerList mvFinalSituation = do
sender "starting the game\n"
let (g1,g2) = split g0
let (playOrder,g) = orderPlayers from g0 playerList
shuffled | null deck = fst $ createDeck rule g1
| otherwise = deck
tryTakeMVar mvFinalSituation
eithFinalSituation <- try $ if observe then sender ("The initial deck is " ++ show shuffled) >>
startFromCardsToEnd (GS numAllies rule) [watch (conn params) mbVerb] playOrder shuffled
else startFromCardsToEnd (GS (succ numAllies) rule) [] playOrder shuffled
let (finalMsg, newScores) = case eithFinalSituation of
Left _e -> (Nothing, scores)
Right (fs@(eg,sts@(st:_),mvs),_) -> (Just $ if sendFullHistoryInFact then fs else (eg, truncate sts, mvs), egToInt st eg : scores)
where truncate = take $ numPlayers $ gameSpec $ publicState $ head sts
-- sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame shuffled finalMsg
-- putMVar mvFinalSituation (shuffled, finalMsg)
case eithFinalSituation of
Left e -> hPutStrLn stderr $ "Exception while playing: " ++ displayException (e::SomeException)
Right (_,ps) -> do
let continue n = newGame n newScores g2 ps mvFinalSituation
sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame shuffled finalMsg
sendTextData (conn params) $ endecodeX mbVerb $ Str $ prettyMsg undefined $ Scores newScores
-- `Str $ prettyMsg undefined $' is unnecessary, but it will be there for a while just for compatibility (until Ver. 0.16 or 1.0).
if ntimes > 1 then continue $ pred ntimes else do
sendTextData (conn params) $ endecodeX mbVerb PlayAgain
eithinp <- try $ receiveDataMessage $ conn params
case eithinp of
Left e -> hPutStrLn stderr $ "Exception while requesting an answer: " ++ displayException (e::SomeException)
Right input -> do
let inp = unpack $ fromDataMessage input
sender (inp++" received.")
case dropWhile (not . isAlpha) inp of
c:cs | toLower c == 'n' -> return ()
| c == 'r' -> case reads cs of [(num, _)] | num > 0 -> if num <= 100 then sender ("repeating "++show num++" times.") >> continue num
else sender "The number must be at most 100." >> continue 1
_ -> continue 1
_ -> continue 1
_ -> 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"
forever $ do
(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 <<game ID>>' : attend the game identified by the game ID.\n"
++ "'available' : request the list of games calling for players.\n"
\end{code}