{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Headroom.Updater
( checkUpdates
, fetchLatestVersion
, parseLatestVersion
, 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
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
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"
parseLatestVersion :: MonadThrow m
=> Value
-> m 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"
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}.
|]