module Hasura.Server.CheckUpdates
  ( checkForUpdates,
  )
where

import CI qualified
import Control.Concurrent.Extended qualified as C
import Control.Exception (try)
import Control.Lens
import Data.Aeson qualified as J
import Data.Aeson.Casing qualified as J
import Data.Either (fromRight)
import Data.Text qualified as T
import Data.Text.Conversions (toText)
import Hasura.HTTP
import Hasura.Logging (LoggerCtx (..))
import Hasura.Prelude
import Hasura.Server.Version (Version, currentVersion)
import Network.HTTP.Client qualified as HTTP
import Network.URI.Encode qualified as URI
import Network.Wreq qualified as Wreq
import System.Log.FastLogger qualified as FL

newtype UpdateInfo = UpdateInfo
  { UpdateInfo -> Version
_uiLatest :: Version
  }
  deriving (Int -> UpdateInfo -> ShowS
[UpdateInfo] -> ShowS
UpdateInfo -> String
(Int -> UpdateInfo -> ShowS)
-> (UpdateInfo -> String)
-> ([UpdateInfo] -> ShowS)
-> Show UpdateInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpdateInfo -> ShowS
showsPrec :: Int -> UpdateInfo -> ShowS
$cshow :: UpdateInfo -> String
show :: UpdateInfo -> String
$cshowList :: [UpdateInfo] -> ShowS
showList :: [UpdateInfo] -> ShowS
Show, (forall x. UpdateInfo -> Rep UpdateInfo x)
-> (forall x. Rep UpdateInfo x -> UpdateInfo) -> Generic UpdateInfo
forall x. Rep UpdateInfo x -> UpdateInfo
forall x. UpdateInfo -> Rep UpdateInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UpdateInfo -> Rep UpdateInfo x
from :: forall x. UpdateInfo -> Rep UpdateInfo x
$cto :: forall x. Rep UpdateInfo x -> UpdateInfo
to :: forall x. Rep UpdateInfo x -> UpdateInfo
Generic)

-- note that this is erroneous and should drop three characters or use
-- aesonPrefix, but needs to remain like this for backwards compatibility
instance J.FromJSON UpdateInfo where
  parseJSON :: Value -> Parser UpdateInfo
parseJSON = Options -> Value -> Parser UpdateInfo
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
J.genericParseJSON (Int -> ShowS -> Options
J.aesonDrop Int
2 ShowS
J.snakeCase)

instance J.ToJSON UpdateInfo where
  toJSON :: UpdateInfo -> Value
toJSON = Options -> UpdateInfo -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON (Int -> ShowS -> Options
J.aesonDrop Int
2 ShowS
J.snakeCase)
  toEncoding :: UpdateInfo -> Encoding
toEncoding = Options -> UpdateInfo -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding (Int -> ShowS -> Options
J.aesonDrop Int
2 ShowS
J.snakeCase)

checkForUpdates :: LoggerCtx a -> HTTP.Manager -> IO void
checkForUpdates :: forall a void. LoggerCtx a -> Manager -> IO void
checkForUpdates (LoggerCtx LoggerSet
loggerSet LogLevel
_ IO FormattedTime
_ HashSet (EngineLogType a)
_) Manager
manager = do
  let options :: Options
options = Manager -> [Header] -> Options
wreqOptions Manager
manager []
  Text
url <- IO Text
getUrl
  IO () -> IO void
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO void) -> IO () -> IO void
forall a b. (a -> b) -> a -> b
$ do
    Either HttpException (Response ByteString)
resp <- IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Options -> String -> IO (Response ByteString)
Wreq.getWith Options
options (String -> IO (Response ByteString))
-> String -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
url
    case Either HttpException (Response ByteString)
resp of
      Left HttpException
ex -> HttpException -> IO ()
ignoreHttpErr HttpException
ex
      Right Response ByteString
bs -> do
        UpdateInfo Version
latestVersion <- ByteString -> IO UpdateInfo
decodeResp (ByteString -> IO UpdateInfo) -> ByteString -> IO UpdateInfo
forall a b. (a -> b) -> a -> b
$ Response ByteString
bs Response ByteString
-> Getting ByteString (Response ByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Response ByteString) ByteString
forall body0 body1 (f :: * -> *).
Functor f =>
(body0 -> f body1) -> Response body0 -> f (Response body1)
Wreq.responseBody
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
latestVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
currentVersion)
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerSet -> LogStr -> IO ()
FL.pushLogStrLn LoggerSet
loggerSet
          (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
FL.toLogStr
          (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Version -> Text
forall {a}. ToText a => a -> Text
updateMsg Version
latestVersion

    DiffTime -> IO ()
C.sleep (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ Days -> DiffTime
days Days
1
  where
    updateMsg :: a -> Text
updateMsg a
v = Text
"Update: A new version is available: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall {a}. ToText a => a -> Text
toText a
v
    getUrl :: IO Text
getUrl = do
      let buildUrl :: Text -> Text
buildUrl Text
agent =
            Text
"https://releases.hasura.io/graphql-engine?agent="
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
agent
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"&version="
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
URI.encodeText (Version -> Text
forall {a}. ToText a => a -> Text
toText Version
currentVersion)
      Maybe CI
ciM <- IO (Maybe CI)
CI.getCI
      Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> (Text -> Text) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
buildUrl (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ case Maybe CI
ciM of
        Maybe CI
Nothing -> Text
"server"
        Just CI
ci -> Text
"server-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.toLower (CI -> Text
forall a. Show a => a -> Text
tshow CI
ci)

    -- ignoring if there is any error in response and returning the current version
    decodeResp :: ByteString -> IO UpdateInfo
decodeResp = UpdateInfo -> IO UpdateInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateInfo -> IO UpdateInfo)
-> (ByteString -> UpdateInfo) -> ByteString -> IO UpdateInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateInfo -> Either String UpdateInfo -> UpdateInfo
forall b a. b -> Either a b -> b
fromRight (Version -> UpdateInfo
UpdateInfo Version
currentVersion) (Either String UpdateInfo -> UpdateInfo)
-> (ByteString -> Either String UpdateInfo)
-> ByteString
-> UpdateInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String UpdateInfo
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecode

    ignoreHttpErr :: HTTP.HttpException -> IO ()
    ignoreHttpErr :: HttpException -> IO ()
ignoreHttpErr HttpException
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()