diff --git a/embedded/default-global-config.yaml b/embedded/default-global-config.yaml index 546f8da..fc1fc37 100644 --- a/embedded/default-global-config.yaml +++ b/embedded/default-global-config.yaml @@ -1,5 +1,11 @@ ## This is the global configuration file for Headroom. ## See https://github.com/vaclavsvejcar/headroom for more details. -## Whether Headroom should automatically check for available updates. -check-for-updates: true \ No newline at end of file +## Configuration for Headroom Updater. +updates: + + ## Whether Headroom should automatically check for available updates. + check-for-updates: true + + ## How often (in days) should Headroom check for updates. + update-interval-days: 1 \ No newline at end of file diff --git a/src/Headroom/Configuration/GlobalConfig.hs b/src/Headroom/Configuration/GlobalConfig.hs index f9653bb..cf75f5b 100644 --- a/src/Headroom/Configuration/GlobalConfig.hs +++ b/src/Headroom/Configuration/GlobalConfig.hs @@ -19,8 +19,10 @@ and it's located in user's home directory. module Headroom.Configuration.GlobalConfig ( GlobalConfig(..) + , UpdaterConfig(..) , initGlobalConfigIfNeeded , loadGlobalConfig + , parseGlobalConfig ) where @@ -44,9 +46,19 @@ import RIO.FilePath ( () ) --------------------------------- DATA TYPES --------------------------------- +-- | Data type representing updater configuration. +data UpdaterConfig = UpdaterConfig + { ucCheckForUpdates :: Bool -- ^ whether to check for updates + , ucUpdateIntervalDays :: Integer -- ^ how ofter check for updates + } + deriving (Eq, Generic, Show) + +instance FromJSON UpdaterConfig where + parseJSON = genericParseJSON aesonOptions + -- | Data type representing global configuration options. data GlobalConfig = GlobalConfig - { gcCheckForUpdates :: Bool -- ^ whether to check for updates + { gcUpdates :: UpdaterConfig -- ^ config for updater } deriving (Eq, Generic, Show) @@ -76,6 +88,11 @@ loadGlobalConfig = do Y.decodeThrow content +-- | Parses global configuration /YAML/ file. +parseGlobalConfig :: (MonadThrow m) => ByteString -> m GlobalConfig +parseGlobalConfig = Y.decodeThrow + + ------------------------------ PRIVATE FUNCTIONS ----------------------------- configPath :: FilePath diff --git a/src/Headroom/IO/KVStore.hs b/src/Headroom/IO/KVStore.hs index ced81b4..a2e701e 100644 --- a/src/Headroom/IO/KVStore.hs +++ b/src/Headroom/IO/KVStore.hs @@ -41,7 +41,7 @@ module Headroom.IO.KVStore , ValueKey(..) , StorePath(..) -- * Public Functions - , mkKVStore + , sqliteKVStore , valueKey , getValue , putValue @@ -109,10 +109,11 @@ data KVStore m = KVStore -- | Constructs the default 'KVStore' that uses /SQLite/ as a backend. -mkKVStore :: MonadIO m - => StorePath -- ^ path of the store location - -> KVStore m -- ^ store instance -mkKVStore sp = KVStore { kvGetValue = getValue sp, kvPutValue = putValue sp } +sqliteKVStore :: MonadIO m + => StorePath -- ^ path of the store location + -> KVStore m -- ^ store instance +sqliteKVStore sp = + KVStore { kvGetValue = getValue sp, kvPutValue = putValue sp } -------------------------------- TYPE CLASSES -------------------------------- diff --git a/src/Headroom/Updater.hs b/src/Headroom/Updater.hs index 42430b3..7d4dae8 100644 --- a/src/Headroom/Updater.hs +++ b/src/Headroom/Updater.hs @@ -22,7 +22,8 @@ might be capable to update /Headroom/ binaries automatically. -} module Headroom.Updater - ( fetchLatestVersion + ( checkUpdates + , fetchLatestVersion , parseLatestVersion -- * Error Data Types , UpdaterError(..) @@ -32,10 +33,16 @@ where import Data.Aeson ( Value(String) ) import qualified Data.Aeson as A import Data.String.Interpolate ( iii ) +import Data.Time ( UTCTime(utctDay) ) +import Headroom.Configuration.GlobalConfig ( 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 ) @@ -46,10 +53,32 @@ import Lens.Micro.Aeson ( key ) import RIO import qualified RIO.ByteString.Lazy as BL import qualified RIO.Text as T -import Text.URI ( URI ) +import RIO.Time ( diffDays + , getCurrentTime + ) import qualified Text.URI as URI +-- | Check whether newer version is available (if enabled by configuration). +checkUpdates :: (Has UpdaterConfig env, HasRIO KVStore env, HasRIO Network env) + => RIO env (Maybe Version) +checkUpdates = do + KVStore {..} <- viewL + UpdaterConfig {..} <- viewL + now <- getCurrentTime + maybeLastCheckDate <- kvGetValue lastCheckDateKey + let today = utctDay now + shouldCheck = ucCheckForUpdates && case utctDay <$> maybeLastCheckDate of + Just lastCheck | diffDays lastCheck today > ucUpdateIntervalDays -> True + _ -> False + when shouldCheck $ kvPutValue lastCheckDateKey now + if shouldCheck then isNewer <$> fetchLatestVersion else pure Nothing + where + lastCheckDateKey = valueKey @UTCTime "updater/last-check-date" + isNewer version | version > buildVersion = Just version + | otherwise = Nothing + + -- | Fetches and parses latest version from update server. fetchLatestVersion :: (HasRIO Network env) => RIO env Version fetchLatestVersion = do @@ -59,7 +88,11 @@ fetchLatestVersion = do case A.decode (BL.fromStrict resp) of Just json -> parseLatestVersion json _ -> throwM $ CannotDetectVersion "cannot fetch response" - where handleError = throwM . CannotDetectVersion . T.pack . displayException + where + handleError = throwM . CannotDetectVersion . T.pack . displayException + latestVersionApiURI = URI.mkURI + "https://api.github.com/repos/vaclavsvejcar/headroom/releases/latest" + -- | Parses latest version number from /GitHub/ API response. @@ -73,11 +106,6 @@ parseLatestVersion json = case json ^? key "name" of _ -> throwM $ CannotDetectVersion "cannot parse response" -latestVersionApiURI :: MonadThrow m => m URI -latestVersionApiURI = URI.mkURI - "https://api.github.com/repos/vaclavsvejcar/headroom/releases/latest" - - --------------------------------- ERROR TYPES -------------------------------- -- | Error during processing updates. diff --git a/test/Headroom/Configuration/GlobalConfigSpec.hs b/test/Headroom/Configuration/GlobalConfigSpec.hs index c863a66..eedd6dd 100644 --- a/test/Headroom/Configuration/GlobalConfigSpec.hs +++ b/test/Headroom/Configuration/GlobalConfigSpec.hs @@ -5,7 +5,6 @@ {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} - module Headroom.Configuration.GlobalConfigSpec ( spec ) @@ -16,6 +15,7 @@ import Headroom.Data.Has ( Has(..) ) import Headroom.Data.Lens ( suffixLenses , suffixLensesFor ) +import Headroom.Embedded ( defaultGlobalConfig ) import Headroom.IO.FileSystem ( FileSystem(..) , mkFileSystem ) @@ -28,6 +28,7 @@ import RIO.FilePath ( () ) import Test.Hspec + data TestEnv = TestEnv { envFileSystem :: FileSystem (RIO TestEnv) } @@ -78,3 +79,8 @@ spec = do _ <- runRIO env' initGlobalConfigIfNeeded result <- doesFileExist cfgPath result `shouldBe` True + + + describe "parseGlobalConfig" $ do + it "parses embedded default config YAML" $ do + parseGlobalConfig defaultGlobalConfig `shouldSatisfy` isRight diff --git a/test/Headroom/IO/KvStoreSpec.hs b/test/Headroom/IO/KvStoreSpec.hs index 5511a5e..afa3a7e 100644 --- a/test/Headroom/IO/KvStoreSpec.hs +++ b/test/Headroom/IO/KvStoreSpec.hs @@ -25,7 +25,7 @@ spec = do let path = StorePath . T.pack $ dir "test-db.sqlite" fstKey = valueKey @Text "fst-key" sndKey = valueKey @Text "snd-key" - KVStore {..} = mkKVStore path + KVStore {..} = sqliteKVStore path maybeFst <- kvGetValue fstKey _ <- kvPutValue sndKey "foo" _ <- kvPutValue sndKey "bar" diff --git a/test/Headroom/UpdaterSpec.hs b/test/Headroom/UpdaterSpec.hs index 65d3bdc..176a7c8 100644 --- a/test/Headroom/UpdaterSpec.hs +++ b/test/Headroom/UpdaterSpec.hs @@ -4,7 +4,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -15,14 +14,20 @@ where import Data.Aeson ( Value ) import qualified Data.Aeson as A +import Data.String.Interpolate ( i ) +import Headroom.Configuration.GlobalConfig ( UpdaterConfig(..) ) import Headroom.Data.Has ( Has(..) ) import Headroom.Data.Lens ( suffixLenses , suffixLensesFor ) +import Headroom.IO.KVStore ( KVStore(..) ) import Headroom.IO.Network ( Network(..) , NetworkError(..) ) -import Headroom.Meta.Version ( pvp ) +import Headroom.Meta ( buildVersion ) +import Headroom.Meta.Version ( printVersionP + , pvp + ) import Headroom.Updater import RIO import qualified RIO.ByteString as B @@ -32,21 +37,47 @@ import RIO.Partial ( fromJust ) import Test.Hspec + data TestEnv = TestEnv - { envNetwork :: Network (RIO TestEnv) + { envKVStore :: KVStore (RIO TestEnv) + , envNetwork :: Network (RIO TestEnv) + , envUpdaterConfig :: UpdaterConfig } suffixLenses ''TestEnv suffixLensesFor ["nDownloadContent"] ''Network +instance Has (KVStore (RIO TestEnv)) TestEnv where + hasLens = envKVStoreL + instance Has (Network (RIO TestEnv)) TestEnv where hasLens = envNetworkL +instance Has UpdaterConfig TestEnv where + hasLens = envUpdaterConfigL + spec :: Spec spec = do let testFile = "test-data" "updater" "github-resp.json" + describe "checkUpdates" $ do + it "returns Nothing if current version is the latest" $ do + let json = [i|{"name": "#{printVersionP buildVersion}"}|] + env = + env0 + & (envKVStoreL .~ kvStore') + & (envNetworkL . nDownloadContentL .~ nDownloadContent') + & (envUpdaterConfigL .~ updaterConfig') + nDownloadContent' = const . pure $ json + updaterConfig' = UpdaterConfig True 1 + kvStore' = KVStore { kvGetValue = const . pure $ Nothing + , kvPutValue = const . const . pure $ () + } + actual <- runRIO env checkUpdates + actual `shouldBe` Nothing + + describe "fetchLatestVersion" $ do it "gets latest version info" $ do raw <- B.readFile testFile @@ -61,11 +92,17 @@ spec = do runRIO env fetchLatestVersion `shouldThrow` \case (CannotDetectVersion _) -> True + describe "parseLatestVersion" $ do it "parses latest version from raw JSON input" $ do raw <- BL.readFile testFile actual <- parseLatestVersion (fromJust . A.decode @Value $ raw) actual `shouldBe` [pvp|0.4.2.0|] + env0 :: TestEnv -env0 = TestEnv { envNetwork = Network { nDownloadContent = undefined } } +env0 = TestEnv + { envKVStore = KVStore { kvGetValue = undefined, kvPutValue = undefined } + , envNetwork = Network { nDownloadContent = undefined } + , envUpdaterConfig = undefined + }