{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE TypeApplications    #-}

{-|
Module      : Headroom.Updater
Description : Update Manager for Headroom
Copyright   : (c) 2019-2022 Vaclav Svejcar
License     : BSD-3-Clause
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

/Update Manager (Updater)/ is responsible for fetching data about latest version
of /Headroom/ and informing user about available updates. In future versions, it
might be capable to update /Headroom/ binaries automatically.
-}

module Headroom.Updater
  ( checkUpdates
  , fetchLatestVersion
  , parseLatestVersion
    -- * Error Data Types
  , UpdaterError(..)
  )
where

import           Data.Aeson                          ( Value(String) )
import qualified Data.Aeson                         as A
import           Data.String.Interpolate             ( iii )
import           Data.Time                           ( UTCTime(utctDay) )
import           Headroom.Config.Global              ( UpdaterConfig(..) )
import           Headroom.Data.Has                   ( Has(..)
                                                     , HasRIO
                                                     )
import           Headroom.IO.KVStore                 ( KVStore(..)
                                                     , valueKey
                                                     )
import           Headroom.IO.Network                 ( Network(..) )
import           Headroom.Meta                       ( buildVersion )
import           Headroom.Meta.Version               ( Version
                                                     , parseVersion
                                                     )
import           Headroom.Types                      ( fromHeadroomError
                                                     , toHeadroomError
                                                     )
import           Lens.Micro.Aeson                    ( key )
import           RIO
import qualified RIO.ByteString.Lazy                as BL
import qualified RIO.Text                           as T
import           RIO.Time                            ( diffDays
                                                     , getCurrentTime
                                                     )
import qualified Text.URI                           as URI


-- | Check whether newer version is available (if enabled by configuration).
checkUpdates :: (HasRIO KVStore env, HasRIO Network env)
             => UpdaterConfig
             -> RIO env (Maybe Version)
checkUpdates :: UpdaterConfig -> RIO env (Maybe Version)
checkUpdates UpdaterConfig {Bool
Integer
ucUpdateIntervalDays :: UpdaterConfig -> Integer
ucCheckForUpdates :: UpdaterConfig -> Bool
ucUpdateIntervalDays :: Integer
ucCheckForUpdates :: Bool
..} = do
  KVStore {GetValueFn (RIO env)
PutValueFn (RIO env)
kvPutValue :: forall (m :: * -> *).
KVStore m -> forall a. ValueCodec a => ValueKey a -> a -> m ()
kvGetValue :: forall (m :: * -> *).
KVStore m -> forall a. ValueCodec a => ValueKey a -> m (Maybe a)
kvPutValue :: PutValueFn (RIO env)
kvGetValue :: GetValueFn (RIO env)
..}       <- RIO env (KVStore (RIO env))
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  UTCTime
now                <- RIO env UTCTime
forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
  Maybe UTCTime
maybeLastCheckDate <- ValueKey UTCTime -> RIO env (Maybe UTCTime)
GetValueFn (RIO env)
kvGetValue ValueKey UTCTime
lastCheckDateKey
  let today :: Day
today       = UTCTime -> Day
utctDay UTCTime
now
      shouldCheck :: Bool
shouldCheck = Bool
ucCheckForUpdates Bool -> Bool -> Bool
&& case UTCTime -> Day
utctDay (UTCTime -> Day) -> Maybe UTCTime -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
maybeLastCheckDate of
        Just Day
lastCheck
          | Integer -> Integer
forall a. Num a => a -> a
abs (Day -> Day -> Integer
diffDays Day
lastCheck Day
today) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
ucUpdateIntervalDays -> Bool
True
          | Bool
otherwise -> Bool
False
        Maybe Day
Nothing -> Bool
True
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldCheck (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ValueKey UTCTime -> UTCTime -> RIO env ()
PutValueFn (RIO env)
kvPutValue ValueKey UTCTime
lastCheckDateKey UTCTime
now
  if Bool
shouldCheck then Version -> Maybe Version
isNewer (Version -> Maybe Version)
-> RIO env Version -> RIO env (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env Version
forall env. HasRIO Network env => RIO env Version
fetchLatestVersion else Maybe Version -> RIO env (Maybe Version)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Version
forall a. Maybe a
Nothing
 where
  lastCheckDateKey :: ValueKey UTCTime
lastCheckDateKey = Text -> ValueKey UTCTime
forall a. Text -> ValueKey a
valueKey @UTCTime Text
"updater/last-check-date"
  isNewer :: Version -> Maybe Version
isNewer Version
version | Version
version Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
buildVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
version
                  | Bool
otherwise              = Maybe Version
forall a. Maybe a
Nothing


-- | Fetches and parses latest version from update server.
fetchLatestVersion :: (HasRIO Network env) => RIO env Version
fetchLatestVersion :: RIO env Version
fetchLatestVersion = do
  Network {DownloadContentFn (RIO env)
nDownloadContent :: forall (m :: * -> *). Network m -> DownloadContentFn m
nDownloadContent :: DownloadContentFn (RIO env)
..} <- RIO env (Network (RIO env))
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  URI
apiURI       <- RIO env URI
latestVersionApiURI
  ByteString
resp         <- RIO env ByteString
-> (SomeException -> RIO env ByteString) -> RIO env ByteString
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny (DownloadContentFn (RIO env)
nDownloadContent URI
apiURI) SomeException -> RIO env ByteString
forall a. SomeException -> RIO env a
handleError
  case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
A.decode (ByteString -> ByteString
BL.fromStrict ByteString
resp) of
    Just Value
json -> Value -> RIO env Version
forall (m :: * -> *). MonadThrow m => Value -> m Version
parseLatestVersion Value
json
    Maybe Value
_         -> UpdaterError -> RIO env Version
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UpdaterError -> RIO env Version)
-> UpdaterError -> RIO env Version
forall a b. (a -> b) -> a -> b
$ Text -> UpdaterError
CannotDetectVersion Text
"cannot fetch response"
 where
  handleError :: SomeException -> RIO env a
handleError         = UpdaterError -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UpdaterError -> RIO env a)
-> (SomeException -> UpdaterError) -> SomeException -> RIO env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UpdaterError
CannotDetectVersion (Text -> UpdaterError)
-> (SomeException -> Text) -> SomeException -> UpdaterError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
displayException
  latestVersionApiURI :: RIO env URI
latestVersionApiURI = Text -> RIO env URI
forall (m :: * -> *). MonadThrow m => Text -> m URI
URI.mkURI
    Text
"https://api.github.com/repos/vaclavsvejcar/headroom/releases/latest"



-- | Parses latest version number from /GitHub/ API response.
parseLatestVersion :: MonadThrow m
                   => Value     -- ^ raw JSON response from /GitHub/
                   -> m Version -- ^ parsed version
parseLatestVersion :: Value -> m Version
parseLatestVersion Value
json = case Value
json Value -> Getting (First Value) Value Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"name" of
  Just (String Text
rawValue) -> case Text -> Maybe Version
parseVersion Text
rawValue of
    Just Version
version -> Version -> m Version
forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
version
    Maybe Version
_            -> UpdaterError -> m Version
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UpdaterError -> m Version) -> UpdaterError -> m Version
forall a b. (a -> b) -> a -> b
$ Text -> UpdaterError
CannotDetectVersion Text
"cannot parse version"
  Maybe Value
_ -> UpdaterError -> m Version
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UpdaterError -> m Version) -> UpdaterError -> m Version
forall a b. (a -> b) -> a -> b
$ Text -> UpdaterError
CannotDetectVersion Text
"cannot parse response"


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

-- | Error during processing updates.
data UpdaterError = CannotDetectVersion Text
  deriving (UpdaterError -> UpdaterError -> Bool
(UpdaterError -> UpdaterError -> Bool)
-> (UpdaterError -> UpdaterError -> Bool) -> Eq UpdaterError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UpdaterError -> UpdaterError -> Bool
$c/= :: UpdaterError -> UpdaterError -> Bool
== :: UpdaterError -> UpdaterError -> Bool
$c== :: UpdaterError -> UpdaterError -> Bool
Eq, Int -> UpdaterError -> ShowS
[UpdaterError] -> ShowS
UpdaterError -> String
(Int -> UpdaterError -> ShowS)
-> (UpdaterError -> String)
-> ([UpdaterError] -> ShowS)
-> Show UpdaterError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UpdaterError] -> ShowS
$cshowList :: [UpdaterError] -> ShowS
show :: UpdaterError -> String
$cshow :: UpdaterError -> String
showsPrec :: Int -> UpdaterError -> ShowS
$cshowsPrec :: Int -> UpdaterError -> ShowS
Show, Typeable)

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


displayException' :: UpdaterError -> String
displayException' :: UpdaterError -> String
displayException' = \case
  CannotDetectVersion Text
reason -> [iii|
    Cannot get latest Headroom version from update servers, reason: #{reason}.
  |]