{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Query current and upstream Swarm version.
module Swarm.Version (
  -- * PVP version
  isSwarmReleaseTag,
  version,

  -- ** Upstream release
  tagToVersion,
  upstreamReleaseVersion,
  getNewerReleaseVersion,
  NewReleaseFailure (..),
) where

import Control.Exception (catch, displayException)
import Data.Aeson (Array, Value (..), (.:))
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.Char (isDigit)
import Data.Either (lefts, rights)
import Data.Foldable (toList)
import Data.Maybe (listToMaybe)
import Data.Text qualified as T
import Data.Version (Version (..), parseVersion, showVersion)
import Data.Yaml (ParseException, Parser, decodeEither', parseEither)
import GitHash (GitInfo, giBranch)
import Network.HTTP.Client (
  HttpException,
  Request (requestHeaders),
  Response (responseBody),
  httpLbs,
  newManager,
  parseRequest,
 )
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (hUserAgent)
import Paths_swarm qualified
import Swarm.Util (failT, quote)
import Text.ParserCombinators.ReadP (readP_to_S)

-- $setup
-- >>> import Data.Bifunctor (first)
-- >>> import Data.Version (Version (..), parseVersion)
-- >>> import Text.ParserCombinators.ReadP (readP_to_S)

-- | Check that the tag follows the PVP versioning policy.
--
-- Note that this filters out VS Code plugin releases.
isSwarmReleaseTag :: String -> Bool
isSwarmReleaseTag :: String -> Bool
isSwarmReleaseTag = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'.')

version :: String
version :: String
version =
  let v :: String
v = Version -> String
showVersion Version
Paths_swarm.version
   in if String
v forall a. Eq a => a -> a -> Bool
== String
"0.0.0.1" then String
"pre-alpha version" else String
v

-- | Get the current upstream release version if any.
upstreamReleaseVersion :: IO (Either NewReleaseFailure String)
upstreamReleaseVersion :: IO (Either NewReleaseFailure String)
upstreamReleaseVersion =
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
    (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> Either NewReleaseFailure String
parseFailure Array -> Either NewReleaseFailure String
getRelease forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> Either ParseException Array
decodeResp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Response ByteString)
sendRequest)
    (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> NewReleaseFailure
queryFailure)
 where
  -- ------------------------------
  -- send request to GitHub API
  sendRequest :: IO (Response BSL.ByteString)
  sendRequest :: IO (Response ByteString)
sendRequest = do
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    Request
request <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
"https://api.github.com/repos/swarm-game/swarm/releases"
    Request -> Manager -> IO (Response ByteString)
httpLbs
      Request
request {requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
hUserAgent, ByteString
"swarm-game/swarm-swarmversion")]}
      Manager
manager
  -- ------------------------------
  -- get the latest actual release
  getRelease :: Array -> Either NewReleaseFailure String
  getRelease :: Array -> Either NewReleaseFailure String
getRelease Array
rs =
    let ts :: [Either String String]
ts = Array -> [Either String String]
parseReleases Array
rs
        maybeRel :: Maybe String
maybeRel = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights [Either String String]
ts
     in case Maybe String
maybeRel of
          Maybe String
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [String] -> NewReleaseFailure
NoMainUpstreamRelease (forall a b. [Either a b] -> [a]
lefts [Either String String]
ts)
          Just String
rel -> forall a b. b -> Either a b
Right String
rel
  -- ------------------------------
  -- pretty print failures
  parseFailure :: ParseException -> Either NewReleaseFailure String
  parseFailure :: ParseException -> Either NewReleaseFailure String
parseFailure ParseException
e = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NewReleaseFailure
FailedReleaseQuery forall a b. (a -> b) -> a -> b
$ String
"Failure during response parsing: " forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> String
displayException ParseException
e
  queryFailure :: HttpException -> NewReleaseFailure
  queryFailure :: HttpException -> NewReleaseFailure
queryFailure HttpException
e = String -> NewReleaseFailure
FailedReleaseQuery forall a b. (a -> b) -> a -> b
$ String
"Failure requesting GitHub releases: " forall a. Semigroup a => a -> a -> a
<> forall e. Exception e => e -> String
displayException HttpException
e
  -- ------------------------------
  -- parsing helpers
  decodeResp :: Response BSL.ByteString -> Either ParseException Array
  decodeResp :: Response ByteString -> Either ParseException Array
decodeResp Response ByteString
resp = forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' ([Word8] -> ByteString
BS.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BSL.unpack forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
responseBody Response ByteString
resp)
  parseReleases :: Array -> [Either String String]
  parseReleases :: Array -> [Either String String]
parseReleases = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser String
parseRelease) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

parseRelease :: Value -> Parser String
parseRelease :: Value -> Parser String
parseRelease = \case
  Object Object
o -> do
    Bool
pre <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"prerelease"
    if Bool
pre
      then forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a real release!"
      else do
        String
t <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag_name"
        if String -> Bool
isSwarmReleaseTag String
t
          then forall (m :: * -> *) a. Monad m => a -> m a
return String
t
          else forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text
"The release", Text -> Text
quote forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
t, Text
"is not main Swarm release!"]
  Value
_otherValue -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The JSON release is not an Object!"

data NewReleaseFailure where
  FailedReleaseQuery :: String -> NewReleaseFailure
  NoMainUpstreamRelease :: [String] -> NewReleaseFailure
  OnDevelopmentBranch :: String -> NewReleaseFailure
  OldUpstreamRelease :: Version -> Version -> NewReleaseFailure

instance Show NewReleaseFailure where
  show :: NewReleaseFailure -> String
show = \case
    FailedReleaseQuery String
e -> String
"Failed to query upstream release: " forall a. Semigroup a => a -> a -> a
<> String
e
    NoMainUpstreamRelease [String]
fs ->
      String
"No upstream releases found."
        forall a. Semigroup a => a -> a -> a
<> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
fs
          then String
""
          else String
" Rejected:\n" forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a. Semigroup a => a -> a -> a
(<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show @Int) [Int
1 ..] [String]
fs)
    OnDevelopmentBranch String
br -> String
"Currently on development branch '" forall a. Semigroup a => a -> a -> a
<> String
br forall a. Semigroup a => a -> a -> a
<> String
"', skipping release query."
    OldUpstreamRelease Version
up Version
my ->
      String
"Upstream release '"
        forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
up
        forall a. Semigroup a => a -> a -> a
<> String
"' is not newer than mine ('"
        forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
my
        forall a. Semigroup a => a -> a -> a
<> String
"')."

-- | 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 :: String -> Version
tagToVersion = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
parseVersion

-- | Drop trailing zeros from versions so that we can compare them.
normalize :: Version -> Version
normalize :: Version -> Version
normalize (Version [Int]
ns [String]
tags) = [Int] -> [String] -> Version
Version ([Int] -> [Int]
dropTrailing0 [Int]
ns) [String]
tags
 where
  dropTrailing0 :: [Int] -> [Int]
dropTrailing0 = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

-- | 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 :: Maybe GitInfo -> IO (Either NewReleaseFailure String)
getNewerReleaseVersion :: Maybe GitInfo -> IO (Either NewReleaseFailure String)
getNewerReleaseVersion Maybe GitInfo
mgi =
  case Maybe GitInfo
mgi of
    -- when using cabal install, the git info is unavailable, which is of no interest to players
    Maybe GitInfo
Nothing -> (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Either NewReleaseFailure String
getUpVer) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either NewReleaseFailure String)
upstreamReleaseVersion
    Just GitInfo
gi ->
      if GitInfo -> String
giBranch GitInfo
gi forall a. Eq a => a -> a -> Bool
/= String
"main"
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NewReleaseFailure
OnDevelopmentBranch forall a b. (a -> b) -> a -> b
$ GitInfo -> String
giBranch GitInfo
gi
        else (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Either NewReleaseFailure String
getUpVer) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either NewReleaseFailure String)
upstreamReleaseVersion
 where
  myVer :: Version
  myVer :: Version
myVer = Version
Paths_swarm.version
  getUpVer :: String -> Either NewReleaseFailure String
  getUpVer :: String -> Either NewReleaseFailure String
getUpVer String
upTag =
    let upVer :: Version
upVer = String -> Version
tagToVersion String
upTag
     in if Version -> Version
normalize Version
myVer forall a. Ord a => a -> a -> Bool
>= Version -> Version
normalize Version
upVer
          then forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Version -> Version -> NewReleaseFailure
OldUpstreamRelease Version
upVer Version
myVer
          else forall a b. b -> Either a b
Right String
upTag