hanabi-dealer-0.3.0.0: Game/Hanabi/Backend.lhs
\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 <<game ID>>' : attend the game identified by the game ID.\n"
++ "'available' : request the list of games calling for players.\n"
\end{code}