content: {-# 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.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.Maybe (listToMaybe)
  import Data.Text (Text)
  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.Log
  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 = all (\c -> isDigit c || c == '.')
  
  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 (Either NewReleaseFailure String)
  upstreamReleaseVersion =
    catch
      (either parseFailure getRelease . decodeResp <$> sendRequest)
      (return . Left . queryFailure)
   where
    -- ------------------------------
    -- send request to GitHub API
    sendRequest :: IO (Response BSL.ByteString)
    sendRequest = do
      manager <- newManager tlsManagerSettings
      request <- parseRequest "https://api.github.com/repos/swarm-game/swarm/releases"
      httpLbs
        request {requestHeaders = [(hUserAgent, "swarm-game/swarm-swarmversion")]}
        manager
    -- ------------------------------
    -- get the latest actual release
    getRelease :: Array -> Either NewReleaseFailure String
    getRelease rs =
      let ts = parseReleases rs
          maybeRel = listToMaybe $ rights ts
       in case maybeRel of
            Nothing -> Left $ NoMainUpstreamRelease (lefts ts)
            Just rel -> Right rel
    -- ------------------------------
    -- pretty print failures
    parseFailure :: ParseException -> Either NewReleaseFailure String
    parseFailure e = Left . FailedReleaseQuery $ "Failure during response parsing: " <> displayException e
    queryFailure :: HttpException -> NewReleaseFailure
    queryFailure e = FailedReleaseQuery $ "Failure requesting GitHub releases: " <> displayException e
    -- ------------------------------
    -- parsing helpers
    decodeResp :: Response BSL.ByteString -> Either ParseException Array
    decodeResp resp = decodeEither' (BS.pack . BSL.unpack $ responseBody resp)
    parseReleases :: Array -> [Either String String]
    parseReleases = map (parseEither parseRelease) . toList
  
  parseRelease :: Value -> Parser String
  parseRelease = \case
    Object o -> do
      pre <- o .: "prerelease"
      if pre
        then fail "Not a real release!"
        else do
          t <- o .: "tag_name"
          if isSwarmReleaseTag t
            then return t
            else failT ["The release", quote $ T.pack t, "is not main Swarm release!"]
    _otherValue -> fail "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 = \case
      FailedReleaseQuery e -> "Failed to query upstream release: " <> e
      NoMainUpstreamRelease fs ->
        "No upstream releases found."
          <> if null fs
            then ""
            else " Rejected:\n" <> unlines (zipWith ((<>) . show @Int) [1 ..] fs)
      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
  
  -- | Drop trailing zeros from versions so that we can compare them.
  normalize :: Version -> Version
  normalize (Version ns tags) = Version (dropTrailing0 ns) tags
   where
    dropTrailing0 = reverse . dropWhile (== 0) . 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 (Severity, Text) String)
  getNewerReleaseVersion mgi = first errToPair <$> getVer
   where
    myVer :: Version
    myVer = Paths_swarm.version
    getVer :: IO (Either NewReleaseFailure String)
    getVer =
      case mgi of
        -- when using cabal install, the git info is unavailable, which is of no interest to players
        Nothing -> (>>= getUpVer) <$> upstreamReleaseVersion
        Just gi ->
          if giBranch gi /= "main"
            then return . Left . OnDevelopmentBranch $ giBranch gi
            else (>>= getUpVer) <$> upstreamReleaseVersion
    getUpVer :: String -> Either NewReleaseFailure String
    getUpVer upTag =
      let upVer = tagToVersion upTag
       in if normalize myVer >= normalize upVer
            then Left $ OldUpstreamRelease upVer myVer
            else Right upTag
    errToPair :: NewReleaseFailure -> (Severity, Text)
    errToPair e = (toSev e, T.pack $ show e)
    toSev :: NewReleaseFailure -> Severity
    toSev = \case
      FailedReleaseQuery {} -> Error
      NoMainUpstreamRelease {} -> Warning
      OnDevelopmentBranch {} -> Info
      OldUpstreamRelease {} -> Warning
  