[#78] Add 'checkUpdates' function to Updater

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
+## 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

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

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  --------------------------------
 

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.

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

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"

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
+  }