{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Swarm.Version (
gitInfo,
commitInfo,
CommitHash,
tagVersion,
isSwarmReleaseTag,
version,
tagToVersion,
upstreamReleaseVersion,
getNewerReleaseVersion,
NewReleaseFailure (..),
) where
import Control.Exception (catch, displayException)
import Data.Aeson (Array, Value (..), (.:))
import Data.Bifunctor (first)
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.List.Extra (breakOnEnd)
import Data.Maybe (listToMaybe)
import Data.Version (Version (..), parseVersion, showVersion)
import Data.Yaml (ParseException, Parser, decodeEither', parseEither)
import GitHash (GitInfo, giBranch, giHash, giTag, tGitInfoCwdTry)
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)
gitInfo :: Either String GitInfo
gitInfo :: Either String GitInfo
gitInfo = $$String
forall a b. a -> Either a b
tGitInfoCwdTry
commitInfo :: String
commitInfo :: String
commitInfo = case Either String GitInfo
gitInfo of
Left String
_ -> String
""
Right GitInfo
git -> String
" (" forall a. Semigroup a => a -> a -> a
<> GitInfo -> String
giBranch GitInfo
git forall a. Semigroup a => a -> a -> a
<> String
"@" forall a. Semigroup a => a -> a -> a
<> forall a. Int -> [a] -> [a]
take Int
10 (GitInfo -> String
giHash GitInfo
git) forall a. Semigroup a => a -> a -> a
<> String
")"
type CommitHash = String
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
'.')
tagVersion :: Maybe (CommitHash, String)
tagVersion :: Maybe (String, String)
tagVersion = case Either String GitInfo
gitInfo of
Left String
_ -> forall a. Maybe a
Nothing
Right GitInfo
gi ->
let t :: String
t = GitInfo -> String
giTag GitInfo
gi
((String
ta, String
_num), String
ghash) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> ([a], [a])
breakOnEnd String
"-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> ([a], [a])
breakOnEnd String
"-" String
t
in if String -> Bool
isSwarmReleaseTag String
ta
then forall a. a -> Maybe a
Just (String
ghash, String
ta)
else forall a. Maybe a
Nothing
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
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
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
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
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
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
"')."
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
getNewerReleaseVersion :: IO (Either NewReleaseFailure String)
getNewerReleaseVersion :: IO (Either NewReleaseFailure String)
getNewerReleaseVersion =
case Either String GitInfo
gitInfo of
Left String
_e -> (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
Right 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