{-# LANGUAGE OverloadedStrings #-}

-- |
-- 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 (
  -- * 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.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 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 => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"The release '" forall a. Semigroup a => a -> a -> a
<> String
t forall a. Semigroup a => a -> a -> a
<> String
"' 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

-- | 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
myVer forall a. Ord a => a -> a -> Bool
>= 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