{-# LANGUAGE TemplateHaskell #-}

module Hasura.Server.Version
  ( Version (..),
    currentVersion,
    consoleAssetsVersion,
    versionToAssetsVersion,
  )
where

import Control.Exception
import Control.Lens ((^.), (^?))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.FileEmbed (makeRelativeToProject)
import Data.SemVer qualified as V
import Data.Text qualified as T
import Data.Text.Conversions (FromText (..), ToText (..))
import Hasura.Prelude
import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (makeRelativeToProject) -- TODO can we ditch file-embed?
import Text.Regex.TDFA ((=~~))

data Version
  = VersionDev Text
  | VersionRelease V.Version
  | VersionCE Text
  deriving (Int -> Version -> ShowS
[Version] -> ShowS
Version -> String
(Int -> Version -> ShowS)
-> (Version -> String) -> ([Version] -> ShowS) -> Show Version
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Version -> ShowS
showsPrec :: Int -> Version -> ShowS
$cshow :: Version -> String
show :: Version -> String
$cshowList :: [Version] -> ShowS
showList :: [Version] -> ShowS
Show, Version -> Version -> Bool
(Version -> Version -> Bool)
-> (Version -> Version -> Bool) -> Eq Version
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Version -> Version -> Bool
== :: Version -> Version -> Bool
$c/= :: Version -> Version -> Bool
/= :: Version -> Version -> Bool
Eq)

instance ToText Version where
  toText :: Version -> Text
toText = \case
    VersionDev Text
txt -> Text
txt
    VersionRelease Version
version -> Text
"v" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
V.toText Version
version
    VersionCE Text
txt -> Text
txt

instance FromText Version where
  -- Ensure that a -ce suffix is *not* interpreted as the release type of a
  -- Data.SemVer-style semantic version
  fromText :: Text -> Version
fromText Text
txt | Int -> Text -> Text
T.takeEnd Int
3 Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"-ce" = Text -> Version
VersionCE Text
txt
  fromText Text
txt = case Text -> Either String Version
V.fromText (Text -> Either String Version) -> Text -> Either String Version
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'v') Text
txt of
    Left String
_ -> Text -> Version
VersionDev Text
txt
    Right Version
version -> Version -> Version
VersionRelease Version
version

instance ToJSON Version where
  toJSON :: Version -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Version -> Text) -> Version -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
forall a. ToText a => a -> Text
toText

instance FromJSON Version where
  parseJSON :: Value -> Parser Version
parseJSON = (Text -> Version) -> Parser Text -> Parser Version
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Version
forall a. FromText a => Text -> a
fromText (Parser Text -> Parser Version)
-> (Value -> Parser Text) -> Value -> Parser Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON

currentVersion :: Version
currentVersion :: Version
currentVersion =
  Text -> Version
forall a. FromText a => Text -> a
fromText
    (Text -> Version) -> Text -> Version
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')
    (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack
    (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
    -- NOTE: This must work correctly in the presence of a caching! See
    -- graphql-engine.cabal (search for “CURRENT_VERSION”) for details
    -- about our approach here. We could use embedFile but want a nice
    -- error message
    $( do
         versionFileName <- makeRelativeToProject "CURRENT_VERSION"
         addDependentFile versionFileName
         let noFileErr =
               "\n==========================================================================="
                 <> "\n>>> DEAR HASURIAN: The way we bake versions into the server has "
                 <> "\n>>> changed; You'll need to run the following once in your repo to proceed: "
                 <> "\n>>>  $ echo 12345 > \"$(git rev-parse --show-toplevel)/server/CURRENT_VERSION\""
                 <> "\n===========================================================================\n"
         runIO (readFile versionFileName `onException` error noFileErr) >>= stringE
     )

versionToAssetsVersion :: Version -> Text
versionToAssetsVersion :: Version -> Text
versionToAssetsVersion = \case
  VersionDev Text
txt -> Text
"versioned/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt
  VersionRelease Version
v -> case Version -> Maybe Text
getReleaseChannel Version
v of
    Maybe Text
Nothing -> Text
"versioned/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
vMajMin
    Just Text
c -> Text
"channel/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
vMajMin
    where
      vMajMin :: Text
vMajMin = String -> Text
T.pack (String
"v" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Version
v Version -> Getting Int Version Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Version Int
forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> Version -> f Version
V.major) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Version
v Version -> Getting Int Version Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Version Int
forall (f :: * -> *).
Functor f =>
(Int -> f Int) -> Version -> f Version
V.minor))
  VersionCE Text
txt -> Text
"channel/versioned/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt
  where
    getReleaseChannel :: V.Version -> Maybe Text
    getReleaseChannel :: Version -> Maybe Text
getReleaseChannel Version
sv = case Version
sv Version
-> Getting [Identifier] Version [Identifier] -> [Identifier]
forall s a. s -> Getting a s a -> a
^. Getting [Identifier] Version [Identifier]
forall (f :: * -> *).
Functor f =>
([Identifier] -> f [Identifier]) -> Version -> f Version
V.release of
      [] -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"stable"
      (Identifier
mr : [Identifier]
_) -> case Identifier -> Maybe Text
getTextFromId Identifier
mr of
        Maybe Text
Nothing -> Maybe Text
forall a. Maybe a
Nothing
        Just Text
r ->
          if
            | Text -> Bool
T.null Text
r -> Maybe Text
forall a. Maybe a
Nothing
            | Bool
otherwise -> String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String
getChannelFromPreRelease (Text -> String
T.unpack Text
r)

    getChannelFromPreRelease :: String -> Maybe String
    getChannelFromPreRelease :: String -> Maybe String
getChannelFromPreRelease String
sv = String
sv String -> String -> Maybe String
forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ (String
"^([a-z]+)" :: String)

    getTextFromId :: V.Identifier -> Maybe Text
    getTextFromId :: Identifier -> Maybe Text
getTextFromId Identifier
i = Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
i Maybe Identifier
-> Getting (First Text) (Maybe Identifier) Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? ((Identifier -> Const (First Text) (Maybe Identifier))
-> Maybe Identifier -> Const (First Text) (Maybe Identifier)
forall {f :: * -> *} {t} {a}.
Applicative f =>
(t -> f (Maybe a)) -> Maybe t -> f (Maybe a)
toTextualM ((Identifier -> Const (First Text) (Maybe Identifier))
 -> Maybe Identifier -> Const (First Text) (Maybe Identifier))
-> ((Text -> Const (First Text) Text)
    -> Identifier -> Const (First Text) (Maybe Identifier))
-> Getting (First Text) (Maybe Identifier) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Identifier -> Const (First Text) (Maybe Identifier)
forall (f :: * -> *).
Applicative f =>
(Text -> f Text) -> Identifier -> f (Maybe Identifier)
V._Textual)
      where
        toTextualM :: (t -> f (Maybe a)) -> Maybe t -> f (Maybe a)
toTextualM t -> f (Maybe a)
_ Maybe t
Nothing = Maybe a -> f (Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        toTextualM t -> f (Maybe a)
f (Just t
a) = t -> f (Maybe a)
f t
a

-- | A version-based string used to form the CDN URL for fetching console assets.
consoleAssetsVersion :: Text
consoleAssetsVersion :: Text
consoleAssetsVersion = Version -> Text
versionToAssetsVersion Version
currentVersion