mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-24 16:03:37 +03:00
647231b685
Manually enables: * EmptyCase * ExistentialQuantification * QuantifiedConstraints * QuasiQuotes * TemplateHaskell * TypeFamilyDependencies ...in the following components: * 'graphql-engine' library * 'graphql-engine' 'src-test' * 'graphql-engine' 'tests/integration' * 'graphql-engine' tests-hspec' Additionally, performs some light refactoring and documentation. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3991 GitOrigin-RevId: 514477d3466b01f60eca8935d0fef60dd0756838
68 lines
2.2 KiB
Haskell
68 lines
2.2 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
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 A
|
|
import Data.Aeson.Casing qualified as A
|
|
import Data.Aeson.TH qualified as A
|
|
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
|
|
{ _uiLatest :: Version
|
|
}
|
|
deriving (Show)
|
|
|
|
-- note that this is erroneous and should drop three characters or use
|
|
-- aesonPrefix, but needs to remain like this for backwards compatibility
|
|
$(A.deriveJSON (A.aesonDrop 2 A.snakeCase) ''UpdateInfo)
|
|
|
|
checkForUpdates :: LoggerCtx a -> HTTP.Manager -> IO void
|
|
checkForUpdates (LoggerCtx loggerSet _ _ _) manager = do
|
|
let options = wreqOptions manager []
|
|
url <- getUrl
|
|
forever $ do
|
|
resp <- try $ Wreq.getWith options $ T.unpack url
|
|
case resp of
|
|
Left ex -> ignoreHttpErr ex
|
|
Right bs -> do
|
|
UpdateInfo latestVersion <- decodeResp $ bs ^. Wreq.responseBody
|
|
when (latestVersion /= currentVersion) $
|
|
FL.pushLogStrLn loggerSet $ FL.toLogStr $ updateMsg latestVersion
|
|
|
|
C.sleep $ days 1
|
|
where
|
|
updateMsg v = "Update: A new version is available: " <> toText v
|
|
getUrl = do
|
|
let buildUrl agent =
|
|
"https://releases.hasura.io/graphql-engine?agent="
|
|
<> agent
|
|
<> "&version="
|
|
<> URI.encodeText (toText currentVersion)
|
|
ciM <- CI.getCI
|
|
return . buildUrl $ case ciM of
|
|
Nothing -> "server"
|
|
Just ci -> "server-" <> T.toLower (tshow ci)
|
|
|
|
-- ignoring if there is any error in response and returning the current version
|
|
decodeResp = pure . fromRight (UpdateInfo currentVersion) . A.eitherDecode
|
|
|
|
ignoreHttpErr :: HTTP.HttpException -> IO ()
|
|
ignoreHttpErr _ = return ()
|