hanabi-dealer-0.5.0.0: Game/Hanabi/Backend.lhs
\begin{code}
{-# LANGUAGE CPP, TupleSections, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings #-}
-- Do not forget -threaded!
--
-- x #define SNAP
module Game.Hanabi.Backend(server, Options(..), defaultOptions, module Game.Hanabi) where
import Game.Hanabi hiding (main)
import Game.Hanabi.Msg
import Data.Maybe(fromJust, isNothing, 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(isPrefixOf)
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(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(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 TFRANDOM
g <- newTFGen
#else
g <- newStdGen
#endif
mv <- newMVar (IntMap.empty::IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move]))))
let params = Params{gen = g, mvTIDToMVH = mv, versionString = version options, gsConstructorMap = Map.fromList $ strategies options, conn = error "Game.Hanabi.Backend.server: should not happen"}
#ifdef SNAP
httpServe (setPort (port options) defaultConfig) $ runWebSocketsSnap $ loop params
#else
# ifdef WARP
Warp.run (port options) $ websocketsOr defaultConnectionOptions (loop params) $ \_ resp -> resp $ responseLBS status400 [] "Not a WebSocket request."
# else
runServer "127.0.0.1" (port options) $ loop params
# endif
#endif
data Params g = Params{gen :: g,
mvTIDToMVH :: MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))),
conn :: Connection,
versionString :: String,
gsConstructorMap :: Map.Map String (IO (DynamicStrategy IO))
}
-- 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
# ifdef TFRANDOM
g <- newTFGen
# else
g <- newStdGen
# endif
let p = params{gen = g, conn = c}
#endif
withPingThread c 30 (return ()) $ fmap (const ()) $ answerHIO p
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
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
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
isWS = (`elem` ["0", "WS", "via WebSocket"])
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 creater args = case reads args of [(rule,rest)] | isRuleValid rule -> create creater rule rest
_ -> create creater defaultRule args
create :: Maybe Int -> Rule -> String -> IO ()
create from rule args =
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 params) 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
_ -> hash tidstr -- Just for future compatibility.
mvFinalSituation <- newEmptyMVar :: IO (MVar (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 = mkDS "via WebSocket" (VWS (conn params) mbVerb sendFullHistoryInFact) : ixSs
(playOrder,g) = case from of Just n -> (dr++tk, gen params)
where (tk,dr) = splitAt n playerList
Nothing -> shuffle playerList $ gen params
eithFinalSituation <- try $ start (GS (succ numAllies) rule) playOrder g
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 finalSituation
putMVar mvFinalSituation 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 (Just 0) args
[("from", args)] -> case reads args of [(n, ars)] -> createR (Just n) ars
_ -> sender "Parse error. The player number expected."
[("shuffle",args)] -> createR 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"
finalSituation <- readMVar mvFinalSituation
sendTextData (conn params) $ 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 <<game ID>>' : attend the game identified by the game ID.\n"
++ "'available' : request the list of games calling for players.\n"
\end{code}