{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE StrictData        #-}

{-|
Module      : Headroom.Configuration.Compat
Description : Compatibility checks for YAML configuration
Copyright   : (c) 2019-2021 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

This module contains functions and data types used for checking compatibility of
user's YAML configuration with current version of Headroom.
-}

module Headroom.Configuration.Compat
  ( VersionError(..)
  , checkCompatibility
  )
where

import           Data.Aeson                          ( FromJSON(..)
                                                     , withObject
                                                     , (.:)
                                                     )
import           Data.String.Interpolate             ( iii )
import qualified Data.Yaml                          as Y
import           Headroom.Meta                       ( buildVersion
                                                     , configFileName
                                                     , productName
                                                     , webDocMigration
                                                     )
import           Headroom.Meta.Version               ( Version(..)
                                                     , printVersionP
                                                     , pvp
                                                     )
import           Headroom.Types                      ( fromHeadroomError
                                                     , toHeadroomError
                                                     )
import           RIO
import qualified RIO.List                           as L


---------------------------------  DATA TYPES  ---------------------------------

newtype VersionObj = VersionObj Version deriving (VersionObj -> VersionObj -> Bool
(VersionObj -> VersionObj -> Bool)
-> (VersionObj -> VersionObj -> Bool) -> Eq VersionObj
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VersionObj -> VersionObj -> Bool
$c/= :: VersionObj -> VersionObj -> Bool
== :: VersionObj -> VersionObj -> Bool
$c== :: VersionObj -> VersionObj -> Bool
Eq, Int -> VersionObj -> ShowS
[VersionObj] -> ShowS
VersionObj -> String
(Int -> VersionObj -> ShowS)
-> (VersionObj -> String)
-> ([VersionObj] -> ShowS)
-> Show VersionObj
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VersionObj] -> ShowS
$cshowList :: [VersionObj] -> ShowS
show :: VersionObj -> String
$cshow :: VersionObj -> String
showsPrec :: Int -> VersionObj -> ShowS
$cshowsPrec :: Int -> VersionObj -> ShowS
Show)

instance FromJSON VersionObj where
  parseJSON :: Value -> Parser VersionObj
parseJSON = String
-> (Object -> Parser VersionObj) -> Value -> Parser VersionObj
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"VersionObj" ((Object -> Parser VersionObj) -> Value -> Parser VersionObj)
-> (Object -> Parser VersionObj) -> Value -> Parser VersionObj
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Version
version <- Object
obj Object -> Text -> Parser Version
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"version"
    VersionObj -> Parser VersionObj
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VersionObj -> Parser VersionObj)
-> VersionObj -> Parser VersionObj
forall a b. (a -> b) -> a -> b
$ Version -> VersionObj
VersionObj Version
version


---------------------------------  ERROR TYPES  --------------------------------

-- | Exception specific to the "Headroom.Configuration.Compat" module.
data VersionError
  = CannotParseVersion
  -- ^ cannot parse version info from given YAML configuration
  | NewerVersionDetected Version
  -- ^ configuration has newer version than Headroom
  | UnsupportedVersion [Version] Version
  -- ^ given YAML configuration is not compatible
  deriving (VersionError -> VersionError -> Bool
(VersionError -> VersionError -> Bool)
-> (VersionError -> VersionError -> Bool) -> Eq VersionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VersionError -> VersionError -> Bool
$c/= :: VersionError -> VersionError -> Bool
== :: VersionError -> VersionError -> Bool
$c== :: VersionError -> VersionError -> Bool
Eq, Int -> VersionError -> ShowS
[VersionError] -> ShowS
VersionError -> String
(Int -> VersionError -> ShowS)
-> (VersionError -> String)
-> ([VersionError] -> ShowS)
-> Show VersionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VersionError] -> ShowS
$cshowList :: [VersionError] -> ShowS
show :: VersionError -> String
$cshow :: VersionError -> String
showsPrec :: Int -> VersionError -> ShowS
$cshowsPrec :: Int -> VersionError -> ShowS
Show)


instance Exception VersionError where
  displayException :: VersionError -> String
displayException = VersionError -> String
displayException'
  toException :: VersionError -> SomeException
toException      = VersionError -> SomeException
forall e. Exception e => e -> SomeException
toHeadroomError
  fromException :: SomeException -> Maybe VersionError
fromException    = SomeException -> Maybe VersionError
forall e. Exception e => SomeException -> Maybe e
fromHeadroomError


------------------------------  PUBLIC FUNCTIONS  ------------------------------

-- | Checks whether the given not yet parsed YAML configuration is compatible,
-- using list of versions that caused breaking changes into configuration.
checkCompatibility :: MonadThrow m
                   => [Version]
                   -- ^ list of versions with breaking changes in configuration
                   -> Version
                   -- ^ current Headroom version
                   -> ByteString
                   -- ^ raw, not yet parsed YAML configuration
                   -> m Version
                   -- ^ detected compatible version or error
checkCompatibility :: [Version] -> Version -> ByteString -> m Version
checkCompatibility [Version]
breakingVersions Version
current ByteString
raw = do
  VersionObj Version
version <- m VersionObj
parseObj
  ()
_                  <- [Version] -> Version -> m ()
forall (m :: * -> *). MonadThrow m => [Version] -> Version -> m ()
checkBreakingChanges [Version]
breakingVersions Version
version
  ()
_                  <- Version -> Version -> m ()
forall (m :: * -> *). MonadThrow m => Version -> Version -> m ()
checkNewerVersion Version
current Version
version
  Version -> m Version
forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
version
 where
  parseObj :: m VersionObj
parseObj = (ParseException -> m VersionObj)
-> (VersionObj -> m VersionObj)
-> Either ParseException VersionObj
-> m VersionObj
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m VersionObj -> ParseException -> m VersionObj
forall a b. a -> b -> a
const (m VersionObj -> ParseException -> m VersionObj)
-> (VersionError -> m VersionObj)
-> VersionError
-> ParseException
-> m VersionObj
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionError -> m VersionObj
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VersionError -> ParseException -> m VersionObj)
-> VersionError -> ParseException -> m VersionObj
forall a b. (a -> b) -> a -> b
$ VersionError
CannotParseVersion) VersionObj -> m VersionObj
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either ParseException VersionObj
decoded
  decoded :: Either ParseException VersionObj
decoded  = ByteString -> Either ParseException VersionObj
forall a. FromJSON a => ByteString -> Either ParseException a
Y.decodeEither' ByteString
raw


------------------------------  PRIVATE FUNCTIONS  -----------------------------

checkBreakingChanges :: MonadThrow m => [Version] -> Version -> m ()
checkBreakingChanges :: [Version] -> Version -> m ()
checkBreakingChanges [Version]
vs Version
v = case (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<) ([Version] -> [Version])
-> ([Version] -> [Version]) -> [Version] -> [Version]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Version] -> [Version]
forall a. Ord a => [a] -> [a]
L.sort ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ [Version]
vs of
  []    -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  [Version]
newer -> VersionError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VersionError -> m ()) -> VersionError -> m ()
forall a b. (a -> b) -> a -> b
$ [Version] -> Version -> VersionError
UnsupportedVersion [Version]
newer Version
v


checkNewerVersion :: MonadThrow m => Version -> Version -> m ()
checkNewerVersion :: Version -> Version -> m ()
checkNewerVersion Version
current Version
checked =
  if Version
current Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
checked then VersionError -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VersionError -> m ()) -> VersionError -> m ()
forall a b. (a -> b) -> a -> b
$ Version -> VersionError
NewerVersionDetected Version
checked else () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


displayException' :: VersionError -> String
displayException' :: VersionError -> String
displayException' = \case
  VersionError
CannotParseVersion -> [iii|
      Cannot find 'version' key in #{configFileName :: String} configuration
      file. This field is required to check whether your current configuration
      is compatible with installed version of #{productName}. This functionality
      has been added in version 0.4.0.0, please see following migration guide
      for more details on how to proceed:
      #{"\n\t" <> webDocMigration v0400}
    |]
  NewerVersionDetected Version
version -> [iii|
      The version set in your #{configFileName :: String} configuration file
      (#{printVersionP version}) is newer than version of installed
      #{productName} (#{printVersionP buildVersion}). Please upgrade
      #{productName} first.
    |]
  UnsupportedVersion [Version]
versions Version
version -> [iii|
      Your #{configFileName :: String} configuration file has version
      #{printVersionP version}, which is incompatible with current version of
      #{productName} (#{printVersionP buildVersion}). Please perform steps
      described in these migration guides first (in given order):
      #{migrationGuides versions}
    |]
 where
  v0400 :: Version
v0400           = [pvp|0.4.0.0|]
  migrationGuides :: [Version] -> Text
migrationGuides = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> ([Version] -> [Text]) -> [Version] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version -> Text) -> [Version] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Version
v -> Text
"\n\t- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
webDocMigration Version
v)