start-os/agent/src/Lib/Database.hs

module Lib.Database where

import           Startlude               hiding ( throwIO
                                                , Reader
                                                )

import           Control.Effect.Reader.Labelled
import           Control.Monad.Logger
import           Database.Persist.Sql
import           System.Directory

import           Constants
import           Lib.Migration
import           Lib.SystemPaths
import           Lib.Types.Emver
import           Model
import           Util.Function

------------------------------------------------------------------------------------------------------------------------
-- Migrations
------------------------------------------------------------------------------------------------------------------------

data UpMigrationHistory = UpMigrationHistory (Maybe Version) (Maybe Version) -- previous db version, current db version.

type Logger = Loc -> LogSource -> LogLevel -> LogStr -> IO ()

ensureCoherentDbVersion :: (HasFilesystemBase sig m, HasLabelled "sqlDatabase" (Reader Text) sig m, MonadIO m)
                        => ConnectionPool
                        -> Logger
                        -> m UpMigrationHistory
ensureCoherentDbVersion pool logFunc = do
    db         <- dbPath
    mDbVersion <- liftIO $ doesFileExist (toS db) >>= \case
        True  -> runSqlPool getCurrentDbVersion pool -- get db version if db exists
        False -> pure Nothing

    liftIO $ case mDbVersion of
        Nothing        -> initializeDb agentVersion pool logFunc
        Just dbVersion -> upMigration pool dbVersion agentVersion

initializeDb :: Version -> ConnectionPool -> Logger -> IO UpMigrationHistory
initializeDb av = runLoggingT .* runSqlPool $ do
    now <- liftIO getCurrentTime
    runMigration migrateAll
    void . insertEntity $ ExecutedMigration now now av av
    pure $ UpMigrationHistory Nothing (Just agentVersion)

upMigration :: ConnectionPool -> Version -> Version -> IO UpMigrationHistory
upMigration pool dbVersion currentAgentVersion = if dbVersion < currentAgentVersion
    then do
        ioMigrationDbVersion pool dbVersion currentAgentVersion
        pure $ UpMigrationHistory (Just dbVersion) (Just currentAgentVersion)
    else pure $ UpMigrationHistory (Just dbVersion) Nothing