diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +## [v0.8.1.0](https://github.com/LambdaHack/LambdaHack/compare/v0.8.0.0...v0.8.1.0) + +- no player-visible changes +- significantly reduce RAM usage when compiling library +- update and extend CI + ## [v0.8.0.0, aka 'Explosive dashboard'](https://github.com/LambdaHack/LambdaHack/compare/v0.7.1.0...v0.8.0.0) - rework greying out menu items and permitting item application and projection diff --git a/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs b/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs deleted file mode 100644 --- a/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | The implementation of our custom game client monads. Just as any other --- component of the library, this implementation can be substituted. -module Game.LambdaHack.SampleImplementation.SampleMonadClient - ( executorCli -#ifdef EXPOSE_INTERNAL - -- * Internal operations - , CliState(..), CliImplementation(..) -#endif - ) where - -import Prelude () - -import Game.LambdaHack.Common.Prelude - -import Control.Concurrent -import qualified Control.Monad.IO.Class as IO -import Control.Monad.Trans.State.Strict hiding (State) - -import Game.LambdaHack.Atomic (MonadStateWrite (..), putState) -import Game.LambdaHack.Client -import Game.LambdaHack.Client.ClientOptions -import Game.LambdaHack.Client.HandleAtomicM -import Game.LambdaHack.Client.HandleResponseM -import Game.LambdaHack.Client.LoopM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Kind -import Game.LambdaHack.Common.MonadStateRead -import qualified Game.LambdaHack.Common.Save as Save -import Game.LambdaHack.Common.State -import Game.LambdaHack.Server (ChanServer (..)) - -data CliState = CliState - { cliState :: State -- ^ current global state - , cliClient :: StateClient -- ^ current client state - , cliSession :: Maybe SessionUI -- ^ UI state, empty for AI clients - , cliDict :: ChanServer -- ^ this client connection information - , cliToSave :: Save.ChanSave (StateClient, Maybe SessionUI) - -- ^ connection to the save thread - } - --- | Client state transformation monad. -newtype CliImplementation a = CliImplementation - { runCliImplementation :: StateT CliState IO a } - deriving (Monad, Functor, Applicative) - -instance MonadStateRead CliImplementation where - {-# INLINE getsState #-} - getsState f = CliImplementation $ gets $ f . cliState - -instance MonadStateWrite CliImplementation where - {-# INLINE modifyState #-} - modifyState f = CliImplementation $ state $ \cliS -> - let !newCliState = f $ cliState cliS - in ((), cliS {cliState = newCliState}) - -instance MonadClient CliImplementation where - {-# INLINE getsClient #-} - getsClient f = CliImplementation $ gets $ f . cliClient - {-# INLINE modifyClient #-} - modifyClient f = CliImplementation $ state $ \cliS -> - let !newCliState = f $ cliClient cliS - in ((), cliS {cliClient = newCliState}) - liftIO = CliImplementation . IO.liftIO - -instance MonadClientSetup CliImplementation where - saveClient = CliImplementation $ do - toSave <- gets cliToSave - cli <- gets cliClient - msess <- gets cliSession - IO.liftIO $ Save.saveToChan toSave (cli, msess) - restartClient = CliImplementation $ state $ \cliS -> - case cliSession cliS of - Just sess -> - let !newSess = (emptySessionUI (sUIOptions sess)) - { schanF = schanF sess - , sbinding = sbinding sess - , shistory = shistory sess - , sstart = sstart sess - , sgstart = sgstart sess - , sallTime = sallTime sess - , snframes = snframes sess - , sallNframes = sallNframes sess - } - in ((), cliS {cliSession = Just newSess}) - Nothing -> ((), cliS) - -instance MonadClientUI CliImplementation where - {-# INLINE getsSession #-} - getsSession f = CliImplementation $ gets $ f . fromJust . cliSession - {-# INLINE modifySession #-} - modifySession f = CliImplementation $ state $ \cliS -> - let !newCliSession = f $ fromJust $ cliSession cliS - in ((), cliS {cliSession = Just newCliSession}) - liftIO = CliImplementation . IO.liftIO - -instance MonadClientReadResponse CliImplementation where - receiveResponse = CliImplementation $ do - ChanServer{responseS} <- gets cliDict - IO.liftIO $ takeMVar responseS - -instance MonadClientWriteRequest CliImplementation where - sendRequestAI scmd = CliImplementation $ do - ChanServer{requestAIS} <- gets cliDict - IO.liftIO $ putMVar requestAIS scmd - sendRequestUI scmd = CliImplementation $ do - ChanServer{requestUIS} <- gets cliDict - IO.liftIO $ putMVar (fromJust requestUIS) scmd - clientHasUI = CliImplementation $ do - mSession <- gets cliSession - return $! isJust mSession - -instance MonadClientAtomic CliImplementation where - {-# INLINE execUpdAtomic #-} - execUpdAtomic _ = return () -- handleUpdAtomic, until needed, save resources - -- Don't catch anything; assume exceptions impossible. - {-# INLINE execPutState #-} - execPutState = putState - --- | Run the main client loop, with the given arguments and empty --- initial states, in the @IO@ monad. -executorCli :: KeyKind -> UIOptions -> ClientOptions - -> COps - -> Bool - -> FactionId - -> ChanServer - -> IO () -executorCli copsClient sUIOptions clientOptions cops isUI fid cliDict = - let cliSession | isUI = Just $ emptySessionUI sUIOptions - | otherwise = Nothing - stateToFileName (cli, _) = - ssavePrefixCli (soptions cli) <> Save.saveNameCli cops (sside cli) - totalState cliToSave = CliState - { cliState = updateCOpsAndCachedData (const cops) emptyState - -- state is empty, so the cached data is left empty and untouched - , cliClient = emptyStateClient fid - , cliDict - , cliToSave - , cliSession - } - m = loopCli copsClient sUIOptions clientOptions - exe = evalStateT (runCliImplementation m) . totalState - in Save.wrapInSaves cops stateToFileName exe diff --git a/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs b/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs deleted file mode 100644 --- a/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | The implementation of our custom game server monads. Just as any other --- component of the library, this implementation can be substituted. -module Game.LambdaHack.SampleImplementation.SampleMonadServer - ( executorSer -#ifdef EXPOSE_INTERNAL - -- * Internal operations - , SerState(..), SerImplementation(..) -#endif - ) where - -import Prelude () - -import Game.LambdaHack.Common.Prelude - -import Control.Concurrent -import qualified Control.Exception as Ex -import qualified Control.Monad.IO.Class as IO -import Control.Monad.Trans.State.Strict hiding (State) -import qualified Data.EnumMap.Strict as EM -import qualified Data.Text.IO as T -import Options.Applicative (defaultPrefs, execParserPure, - handleParseResult) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath -import System.IO (hFlush, stdout) - -import Game.LambdaHack.Atomic -import Game.LambdaHack.Client -import Game.LambdaHack.Common.File -import Game.LambdaHack.Common.Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import qualified Game.LambdaHack.Common.Save as Save -import Game.LambdaHack.Common.State -import Game.LambdaHack.Common.Thread -import Game.LambdaHack.SampleImplementation.SampleMonadClient (executorCli) -import Game.LambdaHack.Server -import Game.LambdaHack.Server.BroadcastAtomic -import Game.LambdaHack.Server.HandleAtomicM -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.ProtocolM -import Game.LambdaHack.Server.ServerOptions -import Game.LambdaHack.Server.State - -data SerState = SerState - { serState :: State -- ^ current global state - , serServer :: StateServer -- ^ current server state - , serDict :: ConnServerDict -- ^ client-server connection information - , serToSave :: Save.ChanSave (State, StateServer) - -- ^ connection to the save thread - } - --- | Server state transformation monad. -newtype SerImplementation a = - SerImplementation {runSerImplementation :: StateT SerState IO a} - deriving (Monad, Functor, Applicative) - -instance MonadStateRead SerImplementation where - {-# INLINE getsState #-} - getsState f = SerImplementation $ gets $ f . serState - -instance MonadStateWrite SerImplementation where - {-# INLINE modifyState #-} - modifyState f = SerImplementation $ state $ \serS -> - let !newSerState = f $ serState serS - in ((), serS {serState = newSerState}) - -instance MonadServer SerImplementation where - {-# INLINE getsServer #-} - getsServer f = SerImplementation $ gets $ f . serServer - {-# INLINE modifyServer #-} - modifyServer f = SerImplementation $ state $ \serS -> - let !newSerServer = f $ serServer serS - in ((), serS {serServer = newSerServer}) - chanSaveServer = SerImplementation $ gets serToSave - liftIO = SerImplementation . IO.liftIO - -instance MonadServerReadRequest SerImplementation where - {-# INLINE getsDict #-} - getsDict f = SerImplementation $ gets $ f . serDict - {-# INLINE modifyDict #-} - modifyDict f = SerImplementation $ state $ \serS -> - let !newSerDict = f $ serDict serS - in ((), serS {serDict = newSerDict}) - liftIO = SerImplementation . IO.liftIO - -instance MonadServerAtomic SerImplementation where - execUpdAtomic cmd = do - oldState <- getState - (ps, atomicBroken, executedOnServer) <- handleCmdAtomicServer cmd - when executedOnServer $ cmdAtomicSemSer oldState cmd - handleAndBroadcast ps atomicBroken (UpdAtomic cmd) - execUpdAtomicSer cmd = SerImplementation $ StateT $ \cliS -> do - cliSNewOrE <- Ex.try - $ execStateT (runSerImplementation $ handleUpdAtomic cmd) - cliS - case cliSNewOrE of - Left AtomicFail{} -> return (False, cliS) - Right cliSNew -> - -- We know @cliSNew@ differs only in @serState@. - return (True, cliSNew) - execUpdAtomicFid fid cmd = SerImplementation $ StateT $ \cliS -> do - -- Don't catch anything; assume exceptions impossible. - let sFid = sclientStates (serServer cliS) EM.! fid - cliSNew <- execStateT (runSerImplementation $ handleUpdAtomic cmd) - cliS {serState = sFid} - -- We know @cliSNew@ differs only in @serState@. - let serServerNew = (serServer cliS) - {sclientStates = EM.insert fid (serState cliSNew) - $ sclientStates $ serServer cliS} - return $! ((), cliS {serServer = serServerNew}) - execUpdAtomicFidCatch fid cmd = SerImplementation $ StateT $ \cliS -> do - let sFid = sclientStates (serServer cliS) EM.! fid - cliSNewOrE <- Ex.try - $ execStateT (runSerImplementation $ handleUpdAtomic cmd) - cliS {serState = sFid} - case cliSNewOrE of - Left AtomicFail{} -> return (False, cliS) - Right cliSNew -> do - -- We know @cliSNew@ differs only in @serState@. - let serServerNew = (serServer cliS) - {sclientStates = EM.insert fid (serState cliSNew) - $ sclientStates $ serServer cliS} - return $! (True, cliS {serServer = serServerNew}) - execSfxAtomic sfx = do - ps <- posSfxAtomic sfx - handleAndBroadcast ps [] (SfxAtomic sfx) - execSendPer = sendPer - --- Don't inline this, to keep GHC hard work inside the library --- for easy access of code analysis tools. --- | Run the main server loop, with the given arguments and empty --- initial states, in the @IO@ monad. -executorSer :: COps -> KeyKind -> ServerOptions -> IO () -executorSer cops copsClient soptionsNxtCmdline = do - -- Parse UI client configuration file. - -- It is reparsed at each start of the game executable. - let benchmark = sbenchmark $ sclientOptions soptionsNxtCmdline - -- Fail here, not inside client code, so that savefiles are not removed, - -- because they are not the source of the failure. - sUIOptions <- mkUIOptions cops benchmark - soptionsNxt <- case uCmdline sUIOptions of - [] -> return soptionsNxtCmdline - args -> handleParseResult $ execParserPure defaultPrefs serverOptionsPI args - -- Options for the clients modified with the configuration file. - -- The client debug inside server debug only holds the client commandline - -- options and is never updated with config options, etc. - let clientOptions = applyUIOptions cops sUIOptions - $ sclientOptions soptionsNxt - -- Partially applied main loop of the clients. - executorClient = executorCli copsClient sUIOptions clientOptions cops - -- Wire together game content, the main loop of game clients - -- and the game server loop. - let stateToFileName (_, ser) = - ssavePrefixSer (soptions ser) <> Save.saveNameSer cops - totalState serToSave = SerState - { serState = updateCOpsAndCachedData (const cops) emptyState - -- state is empty, so the cached data is left empty and untouched - , serServer = emptyStateServer - , serDict = EM.empty - , serToSave - } - m = loopSer soptionsNxt executorClient - exe = evalStateT (runSerImplementation m) . totalState - exeWithSaves = Save.wrapInSaves cops stateToFileName exe - defPrefix = ssavePrefixSer defServerOptions - bkpOneSave name = do - dataDir <- appDataDir - let path bkp = dataDir "saves" bkp <> name - b <- doesFileExist (path "") - when b $ renameFile (path "") (path "bkp.") - bkpAllSaves = if benchmark then return () else do - T.hPutStrLn stdout "The game crashed, so savefiles are moved aside." - bkpOneSave $ defPrefix <> Save.saveNameSer cops - forM_ [-99..99] $ \n -> - bkpOneSave $ defPrefix <> Save.saveNameCli cops (toEnum n) - -- Wait for clients to exit even in case of server crash - -- (or server and client crash), which gives them time to save - -- and report their own inconsistencies, if any. - Ex.handle (\(ex :: Ex.SomeException) -> case Ex.fromException ex of - Just ExitSuccess -> - -- User-forced shutdown, not crash, so the intention is - -- to keep old saves and also clients may be not ready to save. - Ex.throwIO ex - _ -> do - Ex.uninterruptibleMask_ $ threadDelay 1000000 - -- let clients report their errors and save - when (ssavePrefixSer soptionsNxt == defPrefix) bkpAllSaves - hFlush stdout - Ex.throwIO ex -- crash eventually, which kills clients - ) - exeWithSaves --- T.hPutStrLn stdout "Server exiting, waiting for clients." --- hFlush stdout - waitForChildren childrenServer -- no crash, wait for clients indefinitely --- T.hPutStrLn stdout "Server exiting now." --- hFlush stdout diff --git a/GameDefinition/Implementation/MonadClientImplementation.hs b/GameDefinition/Implementation/MonadClientImplementation.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Implementation/MonadClientImplementation.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | The implementation of our custom game client monads. Just as any other +-- component of the library, this implementation can be substituted. +module Implementation.MonadClientImplementation + ( executorCli +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , CliState(..), CliImplementation(..) +#endif + ) where + +import Prelude () + +import Game.LambdaHack.Common.Prelude + +import Control.Concurrent +import qualified Control.Monad.IO.Class as IO +import Control.Monad.Trans.State.Strict hiding (State) + +import Game.LambdaHack.Atomic (MonadStateWrite (..), putState) +import Game.LambdaHack.Client +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.HandleAtomicM +import Game.LambdaHack.Client.HandleResponseM +import Game.LambdaHack.Client.LoopM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Kind +import Game.LambdaHack.Common.MonadStateRead +import qualified Game.LambdaHack.Common.Save as Save +import Game.LambdaHack.Common.State +import Game.LambdaHack.Server (ChanServer (..)) + +data CliState = CliState + { cliState :: State -- ^ current global state + , cliClient :: StateClient -- ^ current client state + , cliSession :: Maybe SessionUI -- ^ UI state, empty for AI clients + , cliDict :: ChanServer -- ^ this client connection information + , cliToSave :: Save.ChanSave (StateClient, Maybe SessionUI) + -- ^ connection to the save thread + } + +-- | Client state transformation monad. +newtype CliImplementation a = CliImplementation + { runCliImplementation :: StateT CliState IO a } + deriving (Monad, Functor, Applicative) + +instance MonadStateRead CliImplementation where + {-# INLINE getsState #-} + getsState f = CliImplementation $ gets $ f . cliState + +instance MonadStateWrite CliImplementation where + {-# INLINE modifyState #-} + modifyState f = CliImplementation $ state $ \cliS -> + let !newCliState = f $ cliState cliS + in ((), cliS {cliState = newCliState}) + +instance MonadClient CliImplementation where + {-# INLINE getsClient #-} + getsClient f = CliImplementation $ gets $ f . cliClient + {-# INLINE modifyClient #-} + modifyClient f = CliImplementation $ state $ \cliS -> + let !newCliState = f $ cliClient cliS + in ((), cliS {cliClient = newCliState}) + liftIO = CliImplementation . IO.liftIO + +instance MonadClientSetup CliImplementation where + saveClient = CliImplementation $ do + toSave <- gets cliToSave + cli <- gets cliClient + msess <- gets cliSession + IO.liftIO $ Save.saveToChan toSave (cli, msess) + restartClient = CliImplementation $ state $ \cliS -> + case cliSession cliS of + Just sess -> + let !newSess = (emptySessionUI (sUIOptions sess)) + { schanF = schanF sess + , sbinding = sbinding sess + , shistory = shistory sess + , sstart = sstart sess + , sgstart = sgstart sess + , sallTime = sallTime sess + , snframes = snframes sess + , sallNframes = sallNframes sess + } + in ((), cliS {cliSession = Just newSess}) + Nothing -> ((), cliS) + +instance MonadClientUI CliImplementation where + {-# INLINE getsSession #-} + getsSession f = CliImplementation $ gets $ f . fromJust . cliSession + {-# INLINE modifySession #-} + modifySession f = CliImplementation $ state $ \cliS -> + let !newCliSession = f $ fromJust $ cliSession cliS + in ((), cliS {cliSession = Just newCliSession}) + liftIO = CliImplementation . IO.liftIO + +instance MonadClientReadResponse CliImplementation where + receiveResponse = CliImplementation $ do + ChanServer{responseS} <- gets cliDict + IO.liftIO $ takeMVar responseS + +instance MonadClientWriteRequest CliImplementation where + sendRequestAI scmd = CliImplementation $ do + ChanServer{requestAIS} <- gets cliDict + IO.liftIO $ putMVar requestAIS scmd + sendRequestUI scmd = CliImplementation $ do + ChanServer{requestUIS} <- gets cliDict + IO.liftIO $ putMVar (fromJust requestUIS) scmd + clientHasUI = CliImplementation $ do + mSession <- gets cliSession + return $! isJust mSession + +instance MonadClientAtomic CliImplementation where + {-# INLINE execUpdAtomic #-} + execUpdAtomic _ = return () -- handleUpdAtomic, until needed, save resources + -- Don't catch anything; assume exceptions impossible. + {-# INLINE execPutState #-} + execPutState = putState + +-- | Run the main client loop, with the given arguments and empty +-- initial states, in the @IO@ monad. +executorCli :: KeyKind -> UIOptions -> ClientOptions + -> COps + -> Bool + -> FactionId + -> ChanServer + -> IO () +executorCli copsClient sUIOptions clientOptions cops isUI fid cliDict = + let cliSession | isUI = Just $ emptySessionUI sUIOptions + | otherwise = Nothing + stateToFileName (cli, _) = + ssavePrefixCli (soptions cli) <> Save.saveNameCli cops (sside cli) + totalState cliToSave = CliState + { cliState = updateCOpsAndCachedData (const cops) emptyState + -- state is empty, so the cached data is left empty and untouched + , cliClient = emptyStateClient fid + , cliDict + , cliToSave + , cliSession + } + m = loopCli copsClient sUIOptions clientOptions + exe = evalStateT (runCliImplementation m) . totalState + in Save.wrapInSaves cops stateToFileName exe diff --git a/GameDefinition/Implementation/MonadServerImplementation.hs b/GameDefinition/Implementation/MonadServerImplementation.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Implementation/MonadServerImplementation.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | The implementation of our custom game server monads. Just as any other +-- component of the library, this implementation can be substituted. +module Implementation.MonadServerImplementation + ( executorSer +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , SerState(..), SerImplementation(..) +#endif + ) where + +import Prelude () + +import Game.LambdaHack.Common.Prelude + +import Control.Concurrent +import qualified Control.Exception as Ex +import qualified Control.Monad.IO.Class as IO +import Control.Monad.Trans.State.Strict hiding (State) +import qualified Data.EnumMap.Strict as EM +import qualified Data.Text.IO as T +import Options.Applicative (defaultPrefs, execParserPure, + handleParseResult) +import System.Exit (ExitCode (ExitSuccess)) +import System.FilePath +import System.IO (hFlush, stdout) + +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client +import Game.LambdaHack.Common.File +import Game.LambdaHack.Common.Kind +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import qualified Game.LambdaHack.Common.Save as Save +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Thread +import Game.LambdaHack.Server +import Game.LambdaHack.Server.BroadcastAtomic +import Game.LambdaHack.Server.HandleAtomicM +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.ProtocolM +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State + +import Implementation.MonadClientImplementation (executorCli) + +data SerState = SerState + { serState :: State -- ^ current global state + , serServer :: StateServer -- ^ current server state + , serDict :: ConnServerDict -- ^ client-server connection information + , serToSave :: Save.ChanSave (State, StateServer) + -- ^ connection to the save thread + } + +-- | Server state transformation monad. +newtype SerImplementation a = + SerImplementation {runSerImplementation :: StateT SerState IO a} + deriving (Monad, Functor, Applicative) + +instance MonadStateRead SerImplementation where + {-# INLINE getsState #-} + getsState f = SerImplementation $ gets $ f . serState + +instance MonadStateWrite SerImplementation where + {-# INLINE modifyState #-} + modifyState f = SerImplementation $ state $ \serS -> + let !newSerState = f $ serState serS + in ((), serS {serState = newSerState}) + +instance MonadServer SerImplementation where + {-# INLINE getsServer #-} + getsServer f = SerImplementation $ gets $ f . serServer + {-# INLINE modifyServer #-} + modifyServer f = SerImplementation $ state $ \serS -> + let !newSerServer = f $ serServer serS + in ((), serS {serServer = newSerServer}) + chanSaveServer = SerImplementation $ gets serToSave + liftIO = SerImplementation . IO.liftIO + +instance MonadServerReadRequest SerImplementation where + {-# INLINE getsDict #-} + getsDict f = SerImplementation $ gets $ f . serDict + {-# INLINE modifyDict #-} + modifyDict f = SerImplementation $ state $ \serS -> + let !newSerDict = f $ serDict serS + in ((), serS {serDict = newSerDict}) + liftIO = SerImplementation . IO.liftIO + +instance MonadServerAtomic SerImplementation where + execUpdAtomic cmd = do + oldState <- getState + (ps, atomicBroken, executedOnServer) <- handleCmdAtomicServer cmd + when executedOnServer $ cmdAtomicSemSer oldState cmd + handleAndBroadcast ps atomicBroken (UpdAtomic cmd) + execUpdAtomicSer cmd = SerImplementation $ StateT $ \cliS -> do + cliSNewOrE <- Ex.try + $ execStateT (runSerImplementation $ handleUpdAtomic cmd) + cliS + case cliSNewOrE of + Left AtomicFail{} -> return (False, cliS) + Right cliSNew -> + -- We know @cliSNew@ differs only in @serState@. + return (True, cliSNew) + execUpdAtomicFid fid cmd = SerImplementation $ StateT $ \cliS -> do + -- Don't catch anything; assume exceptions impossible. + let sFid = sclientStates (serServer cliS) EM.! fid + cliSNew <- execStateT (runSerImplementation $ handleUpdAtomic cmd) + cliS {serState = sFid} + -- We know @cliSNew@ differs only in @serState@. + let serServerNew = (serServer cliS) + {sclientStates = EM.insert fid (serState cliSNew) + $ sclientStates $ serServer cliS} + return $! ((), cliS {serServer = serServerNew}) + execUpdAtomicFidCatch fid cmd = SerImplementation $ StateT $ \cliS -> do + let sFid = sclientStates (serServer cliS) EM.! fid + cliSNewOrE <- Ex.try + $ execStateT (runSerImplementation $ handleUpdAtomic cmd) + cliS {serState = sFid} + case cliSNewOrE of + Left AtomicFail{} -> return (False, cliS) + Right cliSNew -> do + -- We know @cliSNew@ differs only in @serState@. + let serServerNew = (serServer cliS) + {sclientStates = EM.insert fid (serState cliSNew) + $ sclientStates $ serServer cliS} + return $! (True, cliS {serServer = serServerNew}) + execSfxAtomic sfx = do + ps <- posSfxAtomic sfx + handleAndBroadcast ps [] (SfxAtomic sfx) + execSendPer = sendPer + +-- Don't inline this, to keep GHC hard work inside the library +-- for easy access of code analysis tools. +-- | Run the main server loop, with the given arguments and empty +-- initial states, in the @IO@ monad. +executorSer :: COps -> KeyKind -> ServerOptions -> IO () +executorSer cops copsClient soptionsNxtCmdline = do + -- Parse UI client configuration file. + -- It is reparsed at each start of the game executable. + let benchmark = sbenchmark $ sclientOptions soptionsNxtCmdline + -- Fail here, not inside client code, so that savefiles are not removed, + -- because they are not the source of the failure. + sUIOptions <- mkUIOptions cops benchmark + soptionsNxt <- case uCmdline sUIOptions of + [] -> return soptionsNxtCmdline + args -> handleParseResult $ execParserPure defaultPrefs serverOptionsPI args + -- Options for the clients modified with the configuration file. + -- The client debug inside server debug only holds the client commandline + -- options and is never updated with config options, etc. + let clientOptions = applyUIOptions cops sUIOptions + $ sclientOptions soptionsNxt + -- Partially applied main loop of the clients. + executorClient = executorCli copsClient sUIOptions clientOptions cops + -- Wire together game content, the main loop of game clients + -- and the game server loop. + let stateToFileName (_, ser) = + ssavePrefixSer (soptions ser) <> Save.saveNameSer cops + totalState serToSave = SerState + { serState = updateCOpsAndCachedData (const cops) emptyState + -- state is empty, so the cached data is left empty and untouched + , serServer = emptyStateServer + , serDict = EM.empty + , serToSave + } + m = loopSer soptionsNxt executorClient + exe = evalStateT (runSerImplementation m) . totalState + exeWithSaves = Save.wrapInSaves cops stateToFileName exe + defPrefix = ssavePrefixSer defServerOptions + bkpOneSave name = do + dataDir <- appDataDir + let path bkp = dataDir "saves" bkp <> name + b <- doesFileExist (path "") + when b $ renameFile (path "") (path "bkp.") + bkpAllSaves = if benchmark then return () else do + T.hPutStrLn stdout "The game crashed, so savefiles are moved aside." + bkpOneSave $ defPrefix <> Save.saveNameSer cops + forM_ [-99..99] $ \n -> + bkpOneSave $ defPrefix <> Save.saveNameCli cops (toEnum n) + -- Wait for clients to exit even in case of server crash + -- (or server and client crash), which gives them time to save + -- and report their own inconsistencies, if any. + Ex.handle (\(ex :: Ex.SomeException) -> case Ex.fromException ex of + Just ExitSuccess -> + -- User-forced shutdown, not crash, so the intention is + -- to keep old saves and also clients may be not ready to save. + Ex.throwIO ex + _ -> do + Ex.uninterruptibleMask_ $ threadDelay 1000000 + -- let clients report their errors and save + when (ssavePrefixSer soptionsNxt == defPrefix) bkpAllSaves + hFlush stdout + Ex.throwIO ex -- crash eventually, which kills clients + ) + exeWithSaves +-- T.hPutStrLn stdout "Server exiting, waiting for clients." +-- hFlush stdout + waitForChildren childrenServer -- no crash, wait for clients indefinitely +-- T.hPutStrLn stdout "Server exiting now." +-- hFlush stdout diff --git a/GameDefinition/Implementation/TieKnot.hs b/GameDefinition/Implementation/TieKnot.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Implementation/TieKnot.hs @@ -0,0 +1,77 @@ +-- | Here the knot of engine code pieces, frontend and the game-specific +-- content definitions is tied, resulting in an executable game. +module Implementation.TieKnot + ( tieKnot + ) where + +import Prelude () + +import Game.LambdaHack.Common.Prelude + +import qualified System.Random as R + +import Game.LambdaHack.Common.Kind +import qualified Game.LambdaHack.Common.Tile as Tile +import qualified Game.LambdaHack.Content.CaveKind as CK +import qualified Game.LambdaHack.Content.ItemKind as IK +import qualified Game.LambdaHack.Content.ModeKind as MK +import qualified Game.LambdaHack.Content.PlaceKind as PK +import qualified Game.LambdaHack.Content.RuleKind as RK +import qualified Game.LambdaHack.Content.TileKind as TK +import Game.LambdaHack.Server + +import qualified Client.UI.Content.KeyKind as Content.KeyKind +import qualified Content.CaveKind +import qualified Content.ItemKind +import qualified Content.ModeKind +import qualified Content.PlaceKind +import qualified Content.RuleKind +import qualified Content.TileKind +import Implementation.MonadServerImplementation (executorSer) + +-- | Tie the LambdaHack engine client, server and frontend code +-- with the game-specific content definitions, and run the game. +-- +-- The custom monad types to be used are determined by the 'executorSer' +-- call, which in turn calls 'executorCli'. If other functions are used +-- in their place- the types are different and so the whole pattern +-- of computation differs. Which of the frontends is run inside the UI client +-- depends on the flags supplied when compiling the engine library. +-- Similarly for the choice of native vs JS builds. +tieKnot :: ServerOptions -> IO () +tieKnot options@ServerOptions{sallClear, sboostRandomItem, sdungeonRng} = do + -- This setup ensures the boosting option doesn't affect generating initial + -- RNG for dungeon, etc., and also, that setting dungeon RNG on commandline + -- equal to what was generated last time, ensures the same item boost. + initialGen <- maybe R.getStdGen return sdungeonRng + let soptionsNxt = options {sdungeonRng = Just initialGen} + boostedItems = IK.boostItemKindList initialGen Content.ItemKind.items + coitem = IK.makeData $ + if sboostRandomItem + then boostedItems ++ Content.ItemKind.otherItemContent + else Content.ItemKind.content + coItemSpeedup = IK.speedupItem coitem + cotile = TK.makeData coitem Content.TileKind.content + coTileSpeedup = Tile.speedupTile sallClear cotile + coplace = PK.makeData cotile Content.PlaceKind.content + cocave = CK.makeData coitem coplace cotile Content.CaveKind.content + -- Common content operations, created from content definitions. + -- Evaluated fully to discover errors ASAP and to free memory. + -- Fail here, not inside server code, so that savefiles are not removed, + -- because they are not the source of the failure. + !cops = COps + { cocave + , coitem + , comode = MK.makeData cocave coitem Content.ModeKind.content + , coplace + , corule = RK.makeData Content.RuleKind.content + , cotile + , coItemSpeedup + , coTileSpeedup + } + -- Client content operations containing default keypresses + -- and command descriptions. + !copsClient = Content.KeyKind.standardKeys + -- Wire together game content, the main loops of game clients + -- and the game server loop. + executorSer cops copsClient soptionsNxt diff --git a/GameDefinition/Main.hs b/GameDefinition/Main.hs --- a/GameDefinition/Main.hs +++ b/GameDefinition/Main.hs @@ -23,7 +23,8 @@ #endif import Game.LambdaHack.Server (serverOptionsPI) -import TieKnot + +import Implementation.TieKnot -- | Parse commandline options, tie the engine, content and clients knot, -- run the game and handle exit. diff --git a/GameDefinition/TieKnot.hs b/GameDefinition/TieKnot.hs deleted file mode 100644 --- a/GameDefinition/TieKnot.hs +++ /dev/null @@ -1,77 +0,0 @@ --- | Here the knot of engine code pieces, frontend and the game-specific --- content definitions is tied, resulting in an executable game. -module TieKnot - ( tieKnot - ) where - -import Prelude () - -import Game.LambdaHack.Common.Prelude - -import qualified System.Random as R - -import Game.LambdaHack.Common.Kind -import qualified Game.LambdaHack.Common.Tile as Tile -import qualified Game.LambdaHack.Content.CaveKind as CK -import qualified Game.LambdaHack.Content.ItemKind as IK -import qualified Game.LambdaHack.Content.ModeKind as MK -import qualified Game.LambdaHack.Content.PlaceKind as PK -import qualified Game.LambdaHack.Content.RuleKind as RK -import qualified Game.LambdaHack.Content.TileKind as TK -import Game.LambdaHack.SampleImplementation.SampleMonadServer (executorSer) -import Game.LambdaHack.Server - -import qualified Client.UI.Content.KeyKind as Content.KeyKind -import qualified Content.CaveKind -import qualified Content.ItemKind -import qualified Content.ModeKind -import qualified Content.PlaceKind -import qualified Content.RuleKind -import qualified Content.TileKind - --- | Tie the LambdaHack engine client, server and frontend code --- with the game-specific content definitions, and run the game. --- --- The custom monad types to be used are determined by the 'executorSer' --- call, which in turn calls 'executorCli'. If other functions are used --- in their place- the types are different and so the whole pattern --- of computation differs. Which of the frontends is run inside the UI client --- depends on the flags supplied when compiling the engine library. --- Similarly for the choice of native vs JS builds. -tieKnot :: ServerOptions -> IO () -tieKnot options@ServerOptions{sallClear, sboostRandomItem, sdungeonRng} = do - -- This setup ensures the boosting option doesn't affect generating initial - -- RNG for dungeon, etc., and also, that setting dungeon RNG on commandline - -- equal to what was generated last time, ensures the same item boost. - initialGen <- maybe R.getStdGen return sdungeonRng - let soptionsNxt = options {sdungeonRng = Just initialGen} - boostedItems = IK.boostItemKindList initialGen Content.ItemKind.items - coitem = IK.makeData $ - if sboostRandomItem - then boostedItems ++ Content.ItemKind.otherItemContent - else Content.ItemKind.content - coItemSpeedup = IK.speedupItem coitem - cotile = TK.makeData coitem Content.TileKind.content - coTileSpeedup = Tile.speedupTile sallClear cotile - coplace = PK.makeData cotile Content.PlaceKind.content - cocave = CK.makeData coitem coplace cotile Content.CaveKind.content - -- Common content operations, created from content definitions. - -- Evaluated fully to discover errors ASAP and to free memory. - -- Fail here, not inside server code, so that savefiles are not removed, - -- because they are not the source of the failure. - !cops = COps - { cocave - , coitem - , comode = MK.makeData cocave coitem Content.ModeKind.content - , coplace - , corule = RK.makeData Content.RuleKind.content - , cotile - , coItemSpeedup - , coTileSpeedup - } - -- Client content operations containing default keypresses - -- and command descriptions. - !copsClient = Content.KeyKind.standardKeys - -- Wire together game content, the main loops of game clients - -- and the game server loop. - executorSer cops copsClient soptionsNxt diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -5,7 +5,7 @@ -- PVP summary:+-+------- breaking API changes -- | | +----- minor or non-breaking API additions -- | | | +--- code changes with no API change -version: 0.8.0.0 +version: 0.8.1.0 synopsis: A game engine library for tactical squad ASCII roguelike dungeon crawlers description: LambdaHack is a Haskell game engine library for ASCII roguelike games of arbitrary theme, size and complexity, with optional @@ -45,7 +45,7 @@ bug-reports: http://github.com/LambdaHack/LambdaHack/issues license: BSD3 license-file: LICENSE -tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 +tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 data-files: GameDefinition/config.ui.default, GameDefinition/fonts/16x16x.fon, GameDefinition/fonts/8x8xb.fon, @@ -199,8 +199,6 @@ Game.LambdaHack.Content.PlaceKind Game.LambdaHack.Content.RuleKind Game.LambdaHack.Content.TileKind - Game.LambdaHack.SampleImplementation.SampleMonadClient - Game.LambdaHack.SampleImplementation.SampleMonadServer Game.LambdaHack.Server Game.LambdaHack.Server.BroadcastAtomic Game.LambdaHack.Server.Commandline @@ -230,7 +228,7 @@ other-modules: Paths_LambdaHack build-depends: assert-failure >= 0.1.2 && < 0.2, - async >= 2, + async >= 2.2.1, base >= 4.9 && < 99, base-compat >= 0.8.0, binary >= 0.8, @@ -323,13 +321,15 @@ Content.PlaceKind, Content.RuleKind, Content.TileKind, - TieKnot, + Implementation.MonadClientImplementation, + Implementation.MonadServerImplementation, + Implementation.TieKnot, Paths_LambdaHack build-depends: LambdaHack, template-haskell >= 2.6, assert-failure >= 0.1.2 && < 0.2, - async >= 2, + async >= 2.2.1, base >= 4.9 && < 99, base-compat >= 0.8.0, binary >= 0.8, @@ -375,8 +375,6 @@ cpp-options: -DUSE_JSFILE } else { build-depends: zlib >= 0.5.3.1 --- ghc-options: -with-rtsopts=-K1K --- TODO: get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one), that is, when I can drop GHC 8.0.2 and older and also when I fix some other stack leaks } test-suite test @@ -396,13 +394,15 @@ Content.PlaceKind, Content.RuleKind, Content.TileKind, - TieKnot, + Implementation.MonadClientImplementation, + Implementation.MonadServerImplementation, + Implementation.TieKnot, Paths_LambdaHack build-depends: LambdaHack, template-haskell >= 2.6, assert-failure >= 0.1.2 && < 0.2, - async >= 2, + async >= 2.2.1, base >= 4.9 && < 99, base-compat >= 0.8.0, binary >= 0.8, @@ -431,7 +431,7 @@ default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, - LambdaCase, StrictData + LambdaCase, StrictData, CPP other-extensions: TemplateHaskell ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively @@ -446,6 +446,4 @@ cpp-options: -DGHCJS_BUSY_YIELD=50 } else { build-depends: zlib >= 0.5.3.1 --- ghc-options: -with-rtsopts=-K1K --- TODO: get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one), that is, when I can drop GHC 8.0.2 and older and also when I fix some other stack leaks } diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -5,7 +5,7 @@ import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Server -import TieKnot +import Implementation.TieKnot main :: IO () main = do