swarm-game/swarm
1
1
Fork 0
mirror of https://github.com/swarm-game/swarm.git synced 2024-10-05 20:19:09 +03:00
Code Issues Projects Releases Wiki Activity

Notify user about newer version (#652)

Browse Source 
- query GitHub Releases for a new version
- add `swarm version` command
- show the version notification in the main menu
- add a new app-wide logging queue
- show the app-wide logs in the main menu as Messages
- catch and show the web API failure in the Messages
- closes #66
- closes #627
This commit is contained in:
Ondřej Šebek 2022-09-06 09:32:24 +02:00 committed by GitHub
parent b3651e2e9a
commit 8366135ae1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 402 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.github/deadpendency.yaml vendored
View File

@ -6,6 +6,7 @@ ignore-failures:
- tasty-expected-failure
- fused-effects-lens
- dotgen
- http-types
# exports GHC capabilities and does not need updates
- array
- syb
@ -21,7 +22,7 @@ rules-config:
warn-at-months: 12
fail-at-months: 18
few-yearly-commits:
warn-at-count: 2
warn-at-count: 1
fail-at-count: disabled # does not fail by default
# these can be 'disabled', 'warn' or 'fail'

6
CHANGELOG.md
View File

@ -1,5 +1,7 @@
# Revision history for swarm
## 0.1.0.0 -- YYYY-mm-dd
## 0.0.0.1 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.
* Pre-alpha version.
* This is a __placeholder__ until swarm is released.
* Please replace this with an actual release.

24
app/Main.hs
View File

@ -1,19 +1,19 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Data.Foldable qualified
import Data.Text (Text, pack)
import Data.Text.IO qualified as Text
import GitHash (giBranch, giHash, tGitInfoCwdTry)
import Options.Applicative
import Swarm.App (appMain)
import Swarm.DocGen (EditorType (..), GenerateDocs (..), SheetType (..), generateDocs)
import Swarm.Language.LSP (lspMain)
import Swarm.Language.Pipeline (processTerm)
import Swarm.Version
import Swarm.Web (defaultPort)
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPrint, stderr)
data CLI
= Run
@ -25,14 +25,16 @@ data CLI
| Format Input
| DocGen GenerateDocs
| LSP
| Version
cliParser :: Parser CLI
cliParser =
subparser
( mconcat
[ command "format" (info (format <**> helper) (progDesc "Format a file"))
, command "lsp" (info (pure LSP) (progDesc "Start the LSP"))
, command "generate" (info (DocGen <$> docgen <**> helper) (progDesc "Generate docs"))
, command "lsp" (info (pure LSP) (progDesc "Start the LSP"))
, command "version" (info (pure Version) (progDesc "Get current and upstream version."))
]
)
<|> Run <$> seed <*> scenario <*> run <*> cheat <*> webPort
@ -77,15 +79,10 @@ cliInfo :: ParserInfo CLI
cliInfo =
info
(cliParser <**> helper)
( header ("Swarm game - pre-alpha version" <> commitInfo)
( header ("Swarm game - " <> version <> commitInfo)
<> progDesc "To play the game simply run without any command."
<> fullDesc
)
where
mgit = $$tGitInfoCwdTry
commitInfo = case mgit of
Left _ -> ""
Right git -> " (" <> giBranch git <> "@" <> take 10 (giHash git) <> ")"
data Input = Stdin | File FilePath
@ -109,11 +106,18 @@ formatFile input = do
Text.putStrLn $ showInput input <> ":" <> e
exitFailure
showVersion :: IO ()
showVersion = do
putStrLn $ "Swarm game - " <> version <> commitInfo
up <- getNewerReleaseVersion
either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up
main :: IO ()
main = do
cli <- execParser cliInfo
case cli of
Run seed scenario toRun cheat webPort -> appMain webPort seed scenario toRun cheat
Format fo -> formatFile fo
DocGen g -> generateDocs g
Format fo -> formatFile fo
LSP -> lspMain
Version -> showVersion

21
src/Swarm/App.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Swarm.App
-- Copyright : Brent Yorgey
@ -11,17 +13,20 @@ module Swarm.App where
import Brick
import Brick.BChan
import Control.Concurrent (forkIO, threadDelay)
import Control.Lens ((&), (.~), (^.))
import Control.Lens ((%~), (&), (?~), (^.))
import Control.Monad.Except
import Data.IORef (newIORef, writeIORef)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Graphics.Vty qualified as V
import Network.Wai.Handler.Warp (Port)
import Swarm.Game.Robot (LogSource (ErrorTrace, Said))
import Swarm.Game.State
import Swarm.TUI.Attr
import Swarm.TUI.Controller
import Swarm.TUI.Model
import Swarm.TUI.View
import Swarm.Version (getNewerReleaseVersion)
import Swarm.Web
type EventHandler = BrickEvent Name AppEvent -> EventM Name AppState ()
@ -65,11 +70,21 @@ appMain port mseed scenario toRun cheat = do
threadDelay 33_333 -- cap maximum framerate at 30 FPS
writeBChan chan Frame
_ <- forkIO $ do
upRel <- getNewerReleaseVersion
writeBChan chan (UpstreamVersion upRel)
-- Start the web service with a reference to the game state
gsRef <- newIORef (s ^. gameState)
mport <- Swarm.Web.startWebThread port gsRef
eport <- Swarm.Web.startWebThread port gsRef
let s' = s & uiState . uiPort .~ mport
let logP p = logEvent Said ("Web API", -2) ("started on :" <> T.pack (show p))
let logE e = logEvent ErrorTrace ("Web API", -2) (T.pack e)
let s' =
s & runtimeState
%~ case eport of
Right p -> (webPort ?~ p) . (eventLog %~ logP p)
Left e -> eventLog %~ logE e
-- Update the reference for every event
let eventHandler e = do

46
src/Swarm/TUI/Controller.hs
View File

@ -102,19 +102,27 @@ pattern FKey c = VtyEvent (V.EvKey (V.KFun c) [])
-- | The top-level event handler for the TUI.
handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()
handleEvent e = do
s <- get
if s ^. uiState . uiPlaying
then handleMainEvent e
else
e & case s ^. uiState . uiMenu of
-- If we reach the NoMenu case when uiPlaying is False, just
-- quit the app. We should actually never reach this code (the
-- quitGame function would have already halted the app).
NoMenu -> const halt
MainMenu l -> handleMainMenuEvent l
NewGameMenu l -> handleNewGameMenuEvent l
AboutMenu -> pressAnyKey (MainMenu (mainMenu About))
handleEvent = \case
-- the query for upstream version could finish at any time, so we have to handle it here
AppEvent (UpstreamVersion ev) -> do
case ev of
Left e -> runtimeState . eventLog %= logEvent Said ("Release", -7) (T.pack $ show e)
Right _ -> pure ()
runtimeState . upstreamRelease .= ev
e -> do
s <- get
if s ^. uiState . uiPlaying
then handleMainEvent e
else
e & case s ^. uiState . uiMenu of
-- If we reach the NoMenu case when uiPlaying is False, just
-- quit the app. We should actually never reach this code (the
-- quitGame function would have already halted the app).
NoMenu -> const halt
MainMenu l -> handleMainMenuEvent l
NewGameMenu l -> handleNewGameMenuEvent l
MessagesMenu -> handleMainMessagesEvent
AboutMenu -> pressAnyKey (MainMenu (mainMenu About))
-- | The event handler for the main menu.
handleMainMenuEvent ::
@ -148,6 +156,9 @@ handleMainMenuEvent menu = \case
_ -> error "No first tutorial found!"
_ -> error "No first tutorial found!"
uncurry startGame firstTutorial Nothing
Messages -> do
runtimeState . eventLog . notificationsCount .= 0
uiState . uiMenu .= MessagesMenu
About -> uiState . uiMenu .= AboutMenu
Quit -> halt
CharKey 'q' -> halt
@ -166,6 +177,15 @@ getTutorials sc = case M.lookup "Tutorials" (scMap sc) of
advanceMenu :: Menu -> Menu
advanceMenu = _NewGameMenu . lens NE.head (\(_ :| t) a -> a :| t) %~ BL.listMoveDown
handleMainMessagesEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()
handleMainMessagesEvent = \case
Key V.KEsc -> returnToMainMenu
CharKey 'q' -> returnToMainMenu
ControlKey 'q' -> returnToMainMenu
_ -> return ()
where
returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages)
handleNewGameMenuEvent :: NonEmpty (BL.List Name ScenarioItem) -> BrickEvent Name AppEvent -> EventM Name AppState ()
handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case
Key V.KEnter ->

103
src/Swarm/TUI/Model.hs
View File

@ -68,7 +68,6 @@ module Swarm.TUI.Model (
-- ** UI Model
UIState,
uiPort,
uiMenu,
uiPlaying,
uiCheatMode,
@ -112,12 +111,18 @@ module Swarm.TUI.Model (
infoScroll,
modalScroll,
-- * Runtime state
RuntimeState,
webPort,
upstreamRelease,
eventLog,
logEvent,
-- * App state
AppState,
-- ** Fields
gameState,
uiState,
runtimeState,
-- ** Initialization
initAppState,
@ -129,6 +134,7 @@ module Swarm.TUI.Model (
focusedItem,
focusedEntity,
nextScenario,
initRuntimeState,
) where
import Brick
@ -154,6 +160,7 @@ import Data.Text (Text)
import Data.Text qualified as T
import Data.Time (getZonedTime)
import Data.Vector qualified as V
import Linear (zero)
import Network.Wai.Handler.Warp (Port)
import Swarm.Game.Entity as E
import Swarm.Game.Robot
@ -175,6 +182,7 @@ import Swarm.Game.State
import Swarm.Game.World qualified as W
import Swarm.Language.Types
import Swarm.Util
import Swarm.Version (NewReleaseFailure (NoUpstreamRelease))
import System.Clock
import System.FilePath (dropTrailingPathSeparator, splitPath, takeFileName)
import Witch (into)
@ -190,7 +198,9 @@ import Witch (into)
-- receive. At the moment, we only have one custom event, but it's
-- very important: a separate thread sends 'Frame' events as fast as
-- it can, telling the TUI to render a new frame.
data AppEvent = Frame
data AppEvent
= Frame
| UpstreamVersion (Either NewReleaseFailure String)
deriving (Show)
-- | 'Name' represents names to uniquely identify various components
@ -436,13 +446,14 @@ data Modal = Modal
makeLenses ''Modal
data MainMenuEntry = NewGame | Tutorial | About | Quit
data MainMenuEntry = NewGame | Tutorial | Messages | About | Quit
deriving (Eq, Ord, Show, Read, Bounded, Enum)
data Menu
= NoMenu -- We started playing directly from command line, no menu to show
| MainMenu (BL.List Name MainMenuEntry)
| NewGameMenu (NonEmpty (BL.List Name ScenarioItem)) -- stack of scenario item lists
| MessagesMenu
| AboutMenu
mainMenu :: MainMenuEntry -> BL.List Name MainMenuEntry
@ -495,14 +506,13 @@ data InventoryListEntry
makePrisms ''InventoryListEntry
------------------------------------------------------------
-- UI state + AppState
-- UI state
------------------------------------------------------------
-- | The main record holding the UI state. For access to the fields,
-- see the lenses below.
data UIState = UIState
{ _uiPort :: Maybe Port
, _uiMenu :: Menu
{ _uiMenu :: Menu
, _uiPlaying :: Bool
, _uiCheatMode :: Bool
, _uiFocusRing :: FocusRing Name
@ -533,12 +543,6 @@ data UIState = UIState
, _appData :: Map Text Text
}
-- | The 'AppState' just stores together the game state and UI state.
data AppState = AppState
{ _gameState :: GameState
, _uiState :: UIState
}
--------------------------------------------------
-- Lenses for UIState
@ -551,9 +555,6 @@ let exclude = ['_lgTicksPerSecond]
)
''UIState
-- | The port on which the HTTP debug service is running.
uiPort :: Lens' UIState (Maybe Port)
-- | The current menu state.
uiMenu :: Lens' UIState Menu
@ -691,6 +692,63 @@ promptUpdateL = lens g s
CmdPrompt _ _ -> mkReplForm $ mkCmdPrompt inputText
SearchPrompt _ _ -> mkReplForm $ SearchPrompt inputText (ui ^. uiReplHistory)
-- ----------------------------------------------------------------------------
-- Runtime state --
-- ----------------------------------------------------------------------------
data RuntimeState = RuntimeState
{ _webPort :: Maybe Port
, _upstreamRelease :: Either NewReleaseFailure String
, _eventLog :: Notifications LogEntry
}
initRuntimeState :: RuntimeState
initRuntimeState =
RuntimeState
{ _webPort = Nothing
, _upstreamRelease = Left NoUpstreamRelease
, _eventLog = mempty
}
makeLensesWith (lensRules & generateSignatures .~ False) ''RuntimeState
-- | The port on which the HTTP debug service is running.
webPort :: Lens' RuntimeState (Maybe Port)
-- | The upstream release version.
upstreamRelease :: Lens' RuntimeState (Either NewReleaseFailure String)
-- | A log of runtime events.
--
-- This logging is separate from the logging done during game-play.
-- If some error happens before a game is even selected, this is the
-- place to log it.
eventLog :: Lens' RuntimeState (Notifications LogEntry)
-- | Simply log to the runtime event log.
logEvent :: LogSource -> (Text, RID) -> Text -> Notifications LogEntry -> Notifications LogEntry
logEvent src (who, rid) msg el =
el
& notificationsCount %~ succ
& notificationsContent %~ (l :)
where
l = LogEntry 0 src who rid zero msg
-- ----------------------------------------------------------------------------
-- APPSTATE --
-- ----------------------------------------------------------------------------
-- | The 'AppState' just stores together the other states.
--
-- This is so you can use a smaller state when e.g. writing some game logic
-- or updating the UI. Also consider that GameState can change when loading
-- a new scenario - if the state should persist games, use RuntimeState.
data AppState = AppState
{ _gameState :: GameState
, _uiState :: UIState
, _runtimeState :: RuntimeState
}
--------------------------------------------------
-- Lenses for AppState
@ -702,6 +760,9 @@ gameState :: Lens' AppState GameState
-- | The 'UIState' record.
uiState :: Lens' AppState UIState
-- | The 'RuntimeState' record
runtimeState :: Lens' AppState RuntimeState
--------------------------------------------------
-- Utility functions
@ -754,8 +815,7 @@ initUIState showMainMenu cheatMode = liftIO $ do
startTime <- getTime Monotonic
return $
UIState
{ _uiPort = Nothing
, _uiMenu = if showMainMenu then MainMenu (mainMenu NewGame) else NoMenu
{ _uiMenu = if showMainMenu then MainMenu (mainMenu NewGame) else NoMenu
, _uiPlaying = not showMainMenu
, _uiCheatMode = cheatMode
, _uiFocusRing = initFocusRing
@ -855,13 +915,14 @@ initAppState userSeed scenarioName toRun cheatMode = do
let skipMenu = isJust scenarioName || isJust toRun || isJust userSeed
gs <- initGameState
ui <- initUIState (not skipMenu) cheatMode
let rs = initRuntimeState
case skipMenu of
False -> return $ AppState gs ui
False -> return $ AppState gs ui rs
True -> do
(scenario, path) <- loadScenario (fromMaybe "classic" scenarioName) (gs ^. entityMap)
execStateT
(startGame scenario (ScenarioInfo path NotStarted NotStarted NotStarted) toRun)
(AppState gs ui)
(AppState gs ui rs)
-- | Load a 'Scenario' and start playing the game.
startGame :: (MonadIO m, MonadState AppState m) => Scenario -> ScenarioInfo -> Maybe FilePath -> m ()

56
src/Swarm/TUI/View.hs
View File

@ -96,6 +96,7 @@ import Swarm.TUI.Border
import Swarm.TUI.Model
import Swarm.TUI.Panel
import Swarm.Util
import Swarm.Version (NewReleaseFailure (..))
import System.Clock (TimeSpec (..))
import Text.Printf
import Text.Wrap
@ -109,18 +110,38 @@ drawUI s
| otherwise = case s ^. uiState . uiMenu of
-- We should never reach the NoMenu case if uiPlaying is false; we would have
-- quit the app instead. But just in case, we display the main menu anyway.
NoMenu -> [drawMainMenuUI (s ^. uiState . appData . at "logo") (mainMenu NewGame)]
MainMenu l -> [drawMainMenuUI (s ^. uiState . appData . at "logo") l]
NoMenu -> [drawMainMenuUI s (mainMenu NewGame)]
MainMenu l -> [drawMainMenuUI s l]
NewGameMenu stk -> [drawNewGameMenuUI stk]
MessagesMenu -> [drawMainMessages s]
AboutMenu -> [drawAboutMenuUI (s ^. uiState . appData . at "about")]
drawMainMenuUI :: Maybe Text -> BL.List Name MainMenuEntry -> Widget Name
drawMainMenuUI logo l =
vBox
[ maybe emptyWidget drawLogo logo
, centerLayer . vLimit 5 . hLimit 20 $
BL.renderList (const (hCenter . drawMainMenuEntry)) True l
drawMainMessages :: AppState -> Widget Name
drawMainMessages s = renderDialog dial . padBottom Max . scrollList $ drawLogs ls
where
ls = reverse $ s ^. runtimeState . eventLog . notificationsContent
dial = dialog (Just "Messages") Nothing maxModalWindowWidth
scrollList = withVScrollBars OnRight . vBox
drawLogs = map (drawLogEntry True)
drawMainMenuUI :: AppState -> BL.List Name MainMenuEntry -> Widget Name
drawMainMenuUI s l =
vBox . catMaybes $
[ drawLogo <$> logo
, hCenter . padTopBottom 2 <$> newVersionWidget version
, Just . centerLayer . vLimit 5 . hLimit 20 $
BL.renderList (const (hCenter . drawMainMenuEntry s)) True l
]
where
logo = s ^. uiState . appData . at "logo"
version = s ^. runtimeState . upstreamRelease
newVersionWidget :: Either NewReleaseFailure String -> Maybe (Widget n)
newVersionWidget = \case
Right ver -> Just . txt $ "New version " <> T.pack ver <> " is available!"
Left (OnDevelopmentBranch _b) -> Just . txt $ "Good luck developing!"
Left NoUpstreamRelease -> Nothing
Left (OldUpstreamRelease _up _my) -> Nothing
drawLogo :: Text -> Widget Name
drawLogo = centerLayer . vBox . map (hBox . T.foldr (\c ws -> drawThing c : ws) []) . T.lines
@ -211,11 +232,18 @@ drawNewGameMenuUI (l :| ls) =
nonBlank "" = " "
nonBlank t = t
drawMainMenuEntry :: MainMenuEntry -> Widget Name
drawMainMenuEntry NewGame = txt "New game"
drawMainMenuEntry Tutorial = txt "Tutorial"
drawMainMenuEntry About = txt "About"
drawMainMenuEntry Quit = txt "Quit"
drawMainMenuEntry :: AppState -> MainMenuEntry -> Widget Name
drawMainMenuEntry s = \case
NewGame -> txt "New game"
Tutorial -> txt "Tutorial"
About -> txt "About"
Messages -> highlightMessages $ txt "Messages"
Quit -> txt "Quit"
where
highlightMessages =
if s ^. runtimeState . eventLog . notificationsCount > 0
then withAttr notifAttr
else id
drawAboutMenuUI :: Maybe Text -> Widget Name
drawAboutMenuUI Nothing = centerLayer $ txt "About swarm!"
@ -401,7 +429,7 @@ maybeScroll vpName contents =
-- | Draw one of the various types of modal dialog.
drawModal :: AppState -> ModalType -> Widget Name
drawModal s = \case
HelpModal -> helpWidget (s ^. gameState . seed) (s ^. uiState . uiPort)
HelpModal -> helpWidget (s ^. gameState . seed) (s ^. runtimeState . webPort)
RobotsModal -> robotsListWidget s
RecipesModal -> availableListWidget (s ^. gameState) RecipeList
CommandsModal -> availableListWidget (s ^. gameState) CommandList

171
src/Swarm/Version.hs Normal file
View File

@ -0,0 +1,171 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-- |
-- Module : Swarm.Version
-- Copyright : Brent Yorgey
-- Maintainer : byorgey@gmail.com
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Query current and upstream Swarm version.
module Swarm.Version (
-- * Git info
gitInfo,
commitInfo,
CommitHash,
tagVersion,
-- * PVP version
isSwarmReleaseTag,
version,
-- ** Upstream release
tagToVersion,
upstreamReleaseVersion,
getNewerReleaseVersion,
NewReleaseFailure (..),
) where
import Control.Monad (forM)
import Data.Aeson (Array, Value (..), (.:))
import Data.Aeson.Types (parseMaybe)
import Data.Bifunctor (first)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Char (isDigit)
import Data.Foldable (find, toList)
import Data.List.Extra (breakOnEnd)
import Data.Maybe (catMaybes)
import Data.Version (Version (..), parseVersion, showVersion)
import Data.Yaml (ParseException, decodeEither')
import GitHash (GitInfo, giBranch, giHash, giTag, tGitInfoCwdTry)
import Network.HTTP.Client (
Request (requestHeaders),
Response (responseBody),
httpLbs,
newManager,
parseRequest,
)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (hUserAgent)
import Paths_swarm qualified
import Text.ParserCombinators.ReadP (readP_to_S)
-- $setup
-- >>> import Data.Bifunctor (first)
-- >>> import Data.Version (Version (..), parseVersion)
-- >>> import Text.ParserCombinators.ReadP (readP_to_S)
gitInfo :: Either String GitInfo
gitInfo = $$tGitInfoCwdTry
commitInfo :: String
commitInfo = case gitInfo of
Left _ -> ""
Right git -> " (" <> giBranch git <> "@" <> take 10 (giHash git) <> ")"
type CommitHash = String
-- | Check that the tag follows the PVP versioning policy.
--
-- Note that this filters out VS Code plugin releases.
isSwarmReleaseTag :: String -> Bool
isSwarmReleaseTag = all (\c -> isDigit c || c == '.')
tagVersion :: Maybe (CommitHash, String)
tagVersion = case gitInfo of
Left _ -> Nothing
Right gi ->
let t = giTag gi
((ta, _num), ghash) = first (first init . breakOnEnd "-" . init) $ breakOnEnd "-" t
in if isSwarmReleaseTag ta
then Just (ghash, ta)
else Nothing
version :: String
version =
let v = showVersion Paths_swarm.version
in if v == "0.0.0.1" then "pre-alpha version" else v
-- | Get the current upstream release version if any.
upstreamReleaseVersion :: IO (Maybe String)
upstreamReleaseVersion = do
manager <- newManager tlsManagerSettings
-- -------------------------------------------------------------------------------
-- SEND REQUEST
request <- parseRequest "https://api.github.com/repos/swarm-game/swarm/releases"
response <-
httpLbs
request {requestHeaders = [(hUserAgent, "swarm-game/swarm-swarmversion")]}
manager
-- -------------------------------------------------------------------------------
-- PARSE RESPONSE
-- putStrLn $ "The status code was: " ++ show (statusCode $ responseStatus response)
let result = decodeEither' (BS.pack . BSL.unpack $ responseBody response) :: Either ParseException Array
case result of
Left _e -> do
-- print e
return Nothing
Right rs -> do
ts <- forM (toList rs) $ \r -> do
return . flip parseMaybe r $ \case
Object o -> do
pre <- o .: "prerelease"
if pre
then fail "Not a real release!"
else o .: "tag_name"
_ -> fail "The JSON list does not contain structures!"
return $ find isSwarmReleaseTag . catMaybes $ ts
data NewReleaseFailure where
NoUpstreamRelease :: NewReleaseFailure
OnDevelopmentBranch :: String -> NewReleaseFailure
OldUpstreamRelease :: Version -> Version -> NewReleaseFailure
instance Show NewReleaseFailure where
show = \case
NoUpstreamRelease -> "No upstream releases found."
OnDevelopmentBranch br -> "Currently on development branch '" <> br <> "', skipping release query."
OldUpstreamRelease up my ->
"Upstream release '"
<> showVersion up
<> "' is not newer than mine ('"
<> showVersion my
<> "')."
-- | Read Swarm tag as Version.
--
-- Swarm tags follow the PVP versioning scheme, so comparing them makes sense.
--
-- >>> map (first versionBranch) $ readP_to_S parseVersion "0.1.0.0"
-- [([0],".1.0.0"),([0,1],".0.0"),([0,1,0],".0"),([0,1,0,0],"")]
-- >>> Version [0,0,0,1] [] < tagToVersion "0.1.0.0"
-- True
tagToVersion :: String -> Version
tagToVersion = fst . last . readP_to_S parseVersion
-- | Get a newer upstream release version.
--
-- This function can fail if the current branch is not main,
-- if there is no Internet connection or no newer release.
getNewerReleaseVersion :: IO (Either NewReleaseFailure String)
getNewerReleaseVersion =
case gitInfo of
-- when using cabal install, the git info is unavailable, which is of no interest to players
Left _e -> maybe (Left NoUpstreamRelease) Right <$> upstreamReleaseVersion
Right gi ->
if giBranch gi /= "main"
then return . Left . OnDevelopmentBranch $ giBranch gi
else getUpVer <$> upstreamReleaseVersion
where
myVer :: Version
myVer = Paths_swarm.version
getUpVer :: Maybe String -> Either NewReleaseFailure String
getUpVer = \case
Nothing -> Left NoUpstreamRelease
Just upTag ->
let upVer = tagToVersion upTag
in if myVer >= upVer
then Left $ OldUpstreamRelease upVer myVer
else Right upTag

29
src/Swarm/Web.hs
View File

@ -21,6 +21,7 @@ module Swarm.Web where
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Exception (Exception (displayException), IOException, catch, throwIO)
import Control.Lens ((^.))
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
@ -50,16 +51,19 @@ mkApp gsRef =
g <- liftIO (readIORef gsRef)
pure $ IM.lookup rid (g ^. robotMap)
webMain :: Maybe (MVar ()) -> Warp.Port -> IORef GameState -> IO ()
webMain baton port gsRef = do
let settings = Warp.setPort port $ onReady Warp.defaultSettings
Warp.runSettings settings app
webMain :: Maybe (MVar (Either String ())) -> Warp.Port -> IORef GameState -> IO ()
webMain baton port gsRef = catch (Warp.runSettings settings app) handleErr
where
settings = Warp.setPort port $ onReady Warp.defaultSettings
onReady = case baton of
Just mv -> Warp.setBeforeMainLoop $ putMVar mv ()
Just mv -> Warp.setBeforeMainLoop $ putMVar mv (Right ())
Nothing -> id
app :: Network.Wai.Application
app = Servant.serve (Proxy @SwarmApi) (mkApp gsRef)
handleErr :: IOException -> IO ()
handleErr e = case baton of
Just mv -> putMVar mv (Left $ displayException e)
Nothing -> throwIO e
defaultPort :: Warp.Port
defaultPort = 5357
@ -70,9 +74,9 @@ defaultPort = 5357
-- startup doesn't work. Otherwise, ignore the failure. In any
-- case, return a @Maybe Port@ value representing whether a web
-- server is actually running, and if so, what port it is on.
startWebThread :: Maybe Warp.Port -> IORef GameState -> IO (Maybe Warp.Port)
startWebThread :: Maybe Warp.Port -> IORef GameState -> IO (Either String Warp.Port)
-- User explicitly provided port '0': don't run the web server
startWebThread (Just 0) _ = pure Nothing
startWebThread (Just 0) _ = pure $ Left "The web port has been turned off."
startWebThread portM gsRef = do
baton <- newEmptyMVar
let port = fromMaybe defaultPort portM
@ -80,6 +84,11 @@ startWebThread portM gsRef = do
res <- timeout 500_000 (takeMVar baton)
case (portM, res) of
-- User requested explicit port but server didn't start: fail
(Just _, Nothing) -> fail $ "Failed to start the web API on :" <> show port
-- Otherwise, just report whether the server is running, and if so, on what port
_ -> return (port <$ res)
(Just _, Nothing) -> fail $ failMsg port
-- If we are using the default port, we just report the timeout
(Nothing, Nothing) -> return . Left $ failMsg port <> " (timeout)"
(_, Just (Left e)) -> return . Left $ failMsg port <> " - " <> e
-- If all works, we report on what port the web server is running
(_, Just _) -> return (Right port)
where
failMsg p = "Failed to start the web API on :" <> show p

27
swarm.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 2.4
name: swarm
version: 0.1.0.0
version: 0.0.0.1
synopsis: 2D resource gathering game with programmable robots
description: Swarm is a 2D programming and resource gathering
@ -116,6 +116,7 @@ library
Swarm.TUI.View
Swarm.TUI.Controller
Swarm.App
Swarm.Version
Swarm.Web
Swarm.Util
Swarm.DocGen
@ -127,28 +128,34 @@ library
aeson >= 2 && < 2.1,
array >= 0.5.4 && < 0.6,
brick >= 1.0 && < 1.1,
bytestring >= 0.10 && < 0.12,
clock >= 0.8.2 && < 0.9,
containers >= 0.6.2 && < 0.7,
directory >= 1.3 && < 1.4,
dotgen >= 0.4 && < 0.5,
either >= 5.0 && < 5.1,
extra >= 1.7 && < 1.8,
filepath >= 1.4 && < 1.5,
fused-effects >= 1.1.1.1 && < 1.2,
fused-effects-lens >= 1.2.0.1 && < 1.3,
githash >= 0.1.6 && < 0.2,
hashable >= 1.3.4 && < 1.5,
megaparsec >= 9.0 && < 9.3,
hsnoise >= 0.0.2 && < 0.1,
http-client >= 0.7 && < 0.8,
http-client-tls >= 0.3 && < 0.4,
http-types >= 0.12 && < 0.13,
lens >= 4.19 && < 5.2,
linear >= 1.21.6 && < 1.22,
lsp >= 1.2 && < 1.5,
mtl >= 2.2.2 && < 2.3,
megaparsec >= 9.0 && < 9.3,
minimorph >= 0.3 && < 0.4,
mtl >= 2.2.2 && < 2.3,
murmur3 >= 1.0.4 && < 1.1,
parser-combinators >= 1.2 && < 1.4,
prettyprinter >= 1.7.0 && < 1.8,
random >= 1.2.0 && < 1.3,
servant >= 0.19,
servant-server >= 0.19,
servant >= 0.19 && < 0.20,
servant-server >= 0.19 && < 0.20,
simple-enumeration >= 0.2 && < 0.3,
split >= 0.2.3 && < 0.3,
stm >= 2.5.0 && < 2.6,
@ -160,8 +167,8 @@ library
unordered-containers >= 0.2.14 && < 0.3,
vector >= 0.12 && < 0.13,
vty >= 5.33 && < 5.37,
warp >= 3.2,
wai >= 3.2,
wai >= 3.2 && < 3.3,
warp >= 3.2 && < 3.4,
witch >= 0.3.4 && < 1.1,
word-wrap >= 0.5 && < 0.6,
yaml >= 0.11 && < 0.12,
@ -242,8 +249,8 @@ test-suite swarm-integration
swarm,
text,
transformers,
yaml,
witch
witch,
yaml
hs-source-dirs: test/integration
default-language: Haskell2010
ghc-options: -threaded
@ -253,7 +260,7 @@ benchmark benchmark
main-is: Benchmark.hs
hs-source-dirs: bench
type: exitcode-stdio-1.0
build-depends: criterion >= 1.5.10.0 && < 1.6,
build-depends: criterion >= 1.6.0.0 && < 1.7,
-- Import shared with the library don't need bounds
base,
lens,