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

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

Logic for running shared code and bootstrapping all /Headroom/ command /RIO/
applications.
-}

module Headroom.Command.Bootstrap
  ( BootstrapEnv(..)
  , bootstrap
  , runRIO'
  , globalKVStore
  )
where

import           Data.String.Interpolate             ( iii )
import           Headroom.Config.Global              ( GlobalConfig(..)
                                                     , globalConfigPath
                                                     , initGlobalConfigIfNeeded
                                                     , loadGlobalConfig
                                                     )
import           Headroom.Data.Has                   ( Has(..)
                                                     , HasRIO
                                                     )
import           Headroom.IO.FileSystem              ( FileSystem(..) )
import           Headroom.IO.KVStore                 ( KVStore
                                                     , StorePath(..)
                                                     , sqliteKVStore
                                                     )
import           Headroom.IO.Network                 ( Network )
import           Headroom.Meta                       ( cacheFileName
                                                     , globalConfigDirName
                                                     , productInfo
                                                     , webRepo
                                                     )
import           Headroom.Meta.Version               ( Version
                                                     , printVersionP
                                                     )
import           Headroom.UI.Message                 ( messageInfo )
import           Headroom.Updater                    ( UpdaterError(..)
                                                     , checkUpdates
                                                     )
import           RIO
import           RIO.FilePath                        ( (</>) )
import qualified RIO.Text                           as T


-- | Bootstrap environment, containing pieces shared between all commands.
data BootstrapEnv = BootstrapEnv
  { BootstrapEnv -> GlobalConfig
beGlobalConfig :: GlobalConfig -- ^ loaded global configuration
  }


-- | Runs /RIO/ application using provided environment data and flag
-- whether to run in debug mode.
runRIO' :: (LogFunc -> IO env)
        -- ^ function returning environment data
        -> Bool
        -- ^ whether to run in debug mode
        -> RIO env a
        -- ^ /RIO/ application to execute
        -> IO a
        -- ^ execution result
runRIO' :: (LogFunc -> IO env) -> Bool -> RIO env a -> IO a
runRIO' LogFunc -> IO env
enfFn Bool
isDebug RIO env a
logic = do
  LogOptions
defLogOptions <- Handle -> Bool -> IO LogOptions
forall (m :: * -> *). MonadIO m => Handle -> Bool -> m LogOptions
logOptionsHandle Handle
stderr Bool
isDebug
  LogOptions -> (LogFunc -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
LogOptions -> (LogFunc -> m a) -> m a
withLogFunc (Bool -> LogOptions -> LogOptions
setLogUseLoc Bool
False LogOptions
defLogOptions) ((LogFunc -> IO a) -> IO a) -> (LogFunc -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \LogFunc
logFunc -> do
    env
env <- IO env -> IO env
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO env -> IO env) -> IO env -> IO env
forall a b. (a -> b) -> a -> b
$ LogFunc -> IO env
enfFn LogFunc
logFunc
    env -> RIO env a -> IO a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO env
env RIO env a
logic


-- | Executes the initialization logic that should be performed before any other
-- code is executed. During this bootstrap, for example /global configuration/
-- is initialized and loaded, welcome message is printed to console and updates
-- are checked.
bootstrap :: ( HasRIO FileSystem env
             , HasRIO KVStore env
             , HasRIO Network env
             , HasLogFunc env
             )
          => RIO env BootstrapEnv
bootstrap :: RIO env BootstrapEnv
bootstrap = do
  RIO env ()
forall env. HasLogFunc env => RIO env ()
welcomeMessage
  RIO env ()
forall env. HasRIO FileSystem env => RIO env ()
initGlobalConfigIfNeeded
  globalConfig :: GlobalConfig
globalConfig@GlobalConfig {UpdaterConfig
gcUpdates :: GlobalConfig -> UpdaterConfig
gcUpdates :: UpdaterConfig
..} <- RIO env GlobalConfig
forall env. HasRIO FileSystem env => RIO env GlobalConfig
loadGlobalConfig
  RIO env (Maybe Version)
-> (UpdaterError -> RIO env (Maybe Version))
-> RIO env (Maybe Version)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (UpdaterConfig -> RIO env (Maybe Version)
forall env.
(HasRIO KVStore env, HasRIO Network env) =>
UpdaterConfig -> RIO env (Maybe Version)
checkUpdates UpdaterConfig
gcUpdates) UpdaterError -> RIO env (Maybe Version)
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
UpdaterError -> m (Maybe a)
onError RIO env (Maybe Version)
-> (Maybe Version -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Version
Nothing         -> () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Version
newVersion -> Version -> RIO env ()
forall env.
(HasRIO FileSystem env, HasLogFunc env) =>
Version -> RIO env ()
displayUpdate Version
newVersion
  BootstrapEnv -> RIO env BootstrapEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure BootstrapEnv :: GlobalConfig -> BootstrapEnv
BootstrapEnv { beGlobalConfig :: GlobalConfig
beGlobalConfig = GlobalConfig
globalConfig }
 where
  onError :: UpdaterError -> m (Maybe a)
onError UpdaterError
err = do
    Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ()) -> (String -> Utf8Builder) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> (String -> Text) -> String -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ UpdaterError -> String
forall e. Exception e => e -> String
displayException (UpdaterError
err :: UpdaterError)
    Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing


-- | Shared /SQLite/-based 'KVStore'.
globalKVStore :: (HasRIO FileSystem env) => RIO env (KVStore (RIO env))
globalKVStore :: RIO env (KVStore (RIO env))
globalKVStore = do
  FileSystem {GetUserDirectoryFn (RIO env)
DoesFileExistFn (RIO env)
ListFilesFn (RIO env)
CreateDirectoryFn (RIO env)
LoadFileFn (RIO env)
FindFilesByExtsFn (RIO env)
WriteFileFn (RIO env)
FindFilesFn (RIO env)
FindFilesByTypesFn (RIO env)
fsWriteFile :: forall (m :: * -> *). FileSystem m -> WriteFileFn m
fsLoadFile :: forall (m :: * -> *). FileSystem m -> LoadFileFn m
fsListFiles :: forall (m :: * -> *). FileSystem m -> ListFilesFn m
fsGetUserDirectory :: forall (m :: * -> *). FileSystem m -> GetCurrentDirectoryFn m
fsGetCurrentDirectory :: forall (m :: * -> *). FileSystem m -> GetCurrentDirectoryFn m
fsFindFilesByTypes :: forall (m :: * -> *). FileSystem m -> FindFilesByTypesFn m
fsFindFilesByExts :: forall (m :: * -> *). FileSystem m -> FindFilesByExtsFn m
fsFindFiles :: forall (m :: * -> *). FileSystem m -> FindFilesFn m
fsDoesFileExist :: forall (m :: * -> *). FileSystem m -> DoesFileExistFn m
fsCreateDirectory :: forall (m :: * -> *). FileSystem m -> CreateDirectoryFn m
fsWriteFile :: WriteFileFn (RIO env)
fsLoadFile :: LoadFileFn (RIO env)
fsListFiles :: ListFilesFn (RIO env)
fsGetUserDirectory :: GetUserDirectoryFn (RIO env)
fsGetCurrentDirectory :: GetUserDirectoryFn (RIO env)
fsFindFilesByTypes :: FindFilesByTypesFn (RIO env)
fsFindFilesByExts :: FindFilesByExtsFn (RIO env)
fsFindFiles :: FindFilesFn (RIO env)
fsDoesFileExist :: DoesFileExistFn (RIO env)
fsCreateDirectory :: CreateDirectoryFn (RIO env)
..} <- RIO env (FileSystem (RIO env))
forall a t (m :: * -> *). (Has a t, MonadReader t m) => m a
viewL
  String
userDir         <- GetUserDirectoryFn (RIO env)
fsGetUserDirectory
  KVStore (RIO env) -> RIO env (KVStore (RIO env))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (KVStore (RIO env) -> RIO env (KVStore (RIO env)))
-> (String -> KVStore (RIO env))
-> String
-> RIO env (KVStore (RIO env))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   StorePath -> KVStore (RIO env)
forall (m :: * -> *). MonadIO m => StorePath -> KVStore m
sqliteKVStore
    (StorePath -> KVStore (RIO env))
-> (String -> StorePath) -> String -> KVStore (RIO env)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   Text -> StorePath
StorePath
    (Text -> StorePath) -> (String -> Text) -> String -> StorePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   String -> Text
T.pack
    (String -> RIO env (KVStore (RIO env)))
-> String -> RIO env (KVStore (RIO env))
forall a b. (a -> b) -> a -> b
$   String
userDir
    String -> String -> String
</> String
forall a. IsString a => a
globalConfigDirName
    String -> String -> String
</> String
forall a. IsString a => a
cacheFileName


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

welcomeMessage :: HasLogFunc env => RIO env ()
welcomeMessage :: RIO env ()
welcomeMessage = Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ())
-> (Text -> Utf8Builder) -> Text -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> RIO env ()) -> Text -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text
productInfo


displayUpdate :: (HasRIO FileSystem env, HasLogFunc env)
              => Version
              -> RIO env ()
displayUpdate :: Version -> RIO env ()
displayUpdate Version
version = do
  String
configPath <- RIO env String
forall env. HasRIO FileSystem env => RIO env String
globalConfigPath
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ())
-> (Text -> Utf8Builder) -> Text -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Message -> Utf8Builder)
-> (Text -> Message) -> Text -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Message
messageInfo (Text -> RIO env ()) -> Text -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> Text
forall dst src.
(Interpolatable (IsCustomSink dst) src dst,
 Interpolatable (IsCustomSink dst) Text dst) =>
src -> dst
message String
configPath
 where
  message :: src -> dst
message src
configPath = [iii|
      New version #{printVersionP version} is available for download, you can
      get it from #{webRepo}.\n\t
      Tired of seeing this message? You can change the behaviour in global
      config file here:\n\t
      #{configPath}
    |]