Project.hs

{-# LANGUAGE NoImplicitPrelude    #-}
{-# LANGUAGE OverloadedRecordDot  #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE QuasiQuotes          #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-}

{-|
Module      : Stack.Storage.Project
Description : Work with the SQLite database for a project's caches.
License     : BSD-3-Clause

Work with the SQLite database used for a project's caches.
-}

module Stack.Storage.Project
  ( initProjectStorage
  , ConfigCacheKey
  , ConfigCacheParent (..)
  , ConfigCacheParentId
  , configCacheKey
  , loadConfigCache
  , saveConfigCache
  , deactiveConfigCache
  ) where

import qualified Data.ByteString as S
import qualified Data.Set as Set
import           Database.Persist.Sqlite
                   ( Entity (..), SelectOpt (..), SqlBackend, Unique, (=.)
                   , (==.), getBy, insert, selectList, update, updateWhere
                   )
import           Database.Persist.TH
                   ( mkMigrate, mkPersist, persistLowerCase, share
                   , sqlSettings
                   )
import           Pantry.SQLite ( initStorage, withStorage_ )
import           Stack.ConfigureOpts ( configureOptsFromDb )
import           Stack.Prelude
import           Stack.Storage.Util
                   ( handleMigrationException, listUpdateDiff, setUpdateDiff
                   , updateCollection
                   )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.Cache
                   ( CachePkgSrc, ConfigCache (..), ConfigCacheType )
import           Stack.Types.ConfigureOpts ( ConfigureOpts (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.Storage ( ProjectStorage (..) )

-- Uses the Persistent entity syntax to generate entities for five tables in a
-- SQLite database:
--
-- config_cache
-- config_cache_dir_option
-- config_cache_no_dir_option
-- config_cache_dep
-- config_cache_component
--
-- The ID column for each table is automatically generated.
--
-- The other tables have a foreign key referring to the config_cache table, via:
--
--   parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade
--
-- The tables have UNIQUE constraints on multiple columns.
--
-- Creates a function migrateAll to perform all migrations for the generated
-- entities.
share [ mkPersist sqlSettings
      , mkMigrate "migrateAll"
      ]
      [persistLowerCase|
ConfigCacheParent sql="config_cache"
  directory FilePath default="(hex(randomblob(16)))"
  type ConfigCacheType
  pkgSrc CachePkgSrc
  active Bool
  pathEnvVar Text
  haddock Bool default=0
  UniqueConfigCacheParent directory type sql="unique_config_cache"
  deriving Show

ConfigCacheDirOption
  parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade
  index Int
  value String sql="option"
  UniqueConfigCacheDirOption parent index
  deriving Show

ConfigCacheNoDirOption
  parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade
  index Int
  value String sql="option"
  UniqueConfigCacheNoDirOption parent index
  deriving Show

ConfigCacheDep
  parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade
  value GhcPkgId sql="ghc_pkg_id"
  UniqueConfigCacheDep parent value
  deriving Show

ConfigCacheComponent
  parent ConfigCacheParentId sql="config_cache_id" OnDeleteCascade
  value S.ByteString sql="component"
  UniqueConfigCacheComponent parent value
  deriving Show
|]

-- | Initialize the project database for caches.
initProjectStorage ::
     HasLogFunc env
  => Path Abs File
     -- ^ The storage file.
  -> (ProjectStorage -> RIO env a)
     -- ^ Action, given a SQL database connection to the project database for
     -- caches.
  -> RIO env a
initProjectStorage fp f = handleMigrationException $
  initStorage "Stack" migrateAll fp $ f . ProjectStorage

-- | Run an action in a database transaction
withProjectStorage ::
     (HasBuildConfig env, HasLogFunc env)
  => ReaderT SqlBackend (RIO env) a
  -> RIO env a
withProjectStorage inner = do
  storage <- view (buildConfigL . to (.projectStorage.projectStorage))
  withStorage_ storage inner

-- | Type synonym representing keys used to retrieve a record from the Cabal
-- configuration cache or the library or executable Cabal flag cache.
type ConfigCacheKey = Unique ConfigCacheParent

-- | For the given directory and type of cache, yields the key used to retrieve
-- a record from the Cabal configuration cache or the library or executable
-- Cabal flag cache.
configCacheKey ::
     Path Abs Dir
     -- ^ Directory.
  -> ConfigCacheType
     -- ^ Type of cache.
  -> ConfigCacheKey
configCacheKey dir = UniqueConfigCacheParent (toFilePath dir)

-- | Internal helper to read the t'ConfigCache'
readConfigCache ::
     (HasBuildConfig env, HasLogFunc env)
  => Entity ConfigCacheParent
  -> ReaderT SqlBackend (RIO env) ConfigCache
readConfigCache (Entity parentId configCacheParent) = do
  let pkgSrc = configCacheParent.configCacheParentPkgSrc
  pathRelatedInfo <-
    selectList
      [ConfigCacheDirOptionParent ==. parentId]
      [Asc ConfigCacheDirOptionIndex]
  nonPathRelatedInfo <-
    selectList
      [ConfigCacheNoDirOptionParent ==. parentId]
      [Asc ConfigCacheNoDirOptionIndex]
  let configureOpts = configureOptsFromDb pathRelatedInfo nonPathRelatedInfo
  deps <-
    Set.fromList . map ((.configCacheDepValue) . entityVal) <$>
    selectList [ConfigCacheDepParent ==. parentId] []
  components <-
    Set.fromList . map ((.configCacheComponentValue) . entityVal) <$>
    selectList [ConfigCacheComponentParent ==. parentId] []
  let pathEnvVar = configCacheParent.configCacheParentPathEnvVar
  let buildHaddocks = configCacheParent.configCacheParentHaddock
  pure ConfigCache
    { configureOpts
    , deps
    , components
    , buildHaddocks
    , pkgSrc
    , pathEnvVar
    }

-- | Load a t'ConfigCache' value from the project database for caches.
loadConfigCache ::
     (HasBuildConfig env, HasLogFunc env)
  => ConfigCacheKey
  -> RIO env (Maybe ConfigCache)
loadConfigCache key =
  withProjectStorage $
    getBy key >>= \case
      Nothing -> pure Nothing
      Just parentEntity@(Entity _ configCacheParent)
        |  configCacheParent.configCacheParentActive ->
            Just <$> readConfigCache parentEntity
        | otherwise -> pure Nothing

-- | Insert or update a t'ConfigCache' value to the project database for caches.
saveConfigCache ::
     (HasBuildConfig env, HasLogFunc env)
  => ConfigCacheKey
  -> ConfigCache
  -> RIO env ()
saveConfigCache key@(UniqueConfigCacheParent dir type_) new =
  withProjectStorage $ do
    (parentId, mold) <- getBy key >>= \case
        Nothing ->
          (, Nothing) <$>
          insert
            ConfigCacheParent
              { configCacheParentDirectory = dir
              , configCacheParentType = type_
              , configCacheParentPkgSrc = new.pkgSrc
              , configCacheParentActive = True
              , configCacheParentPathEnvVar = new.pathEnvVar
              , configCacheParentHaddock = new.buildHaddocks
              }
        Just parentEntity@(Entity parentId _) -> do
          old <- readConfigCache parentEntity
          update
            parentId
            [ ConfigCacheParentPkgSrc =. new.pkgSrc
            , ConfigCacheParentActive =. True
            , ConfigCacheParentPathEnvVar =. new.pathEnvVar
            ]
          pure (parentId, Just old)
    updateCollection
      (listUpdateDiff ConfigCacheDirOptionIndex)
      (uncurry $ ConfigCacheDirOption parentId)
      [ConfigCacheDirOptionParent ==. parentId]
      (maybe [] (.configureOpts.pathRelated) mold)
      new.configureOpts.pathRelated
    updateCollection
      (listUpdateDiff ConfigCacheNoDirOptionIndex)
      (uncurry $ ConfigCacheNoDirOption parentId)
      [ConfigCacheNoDirOptionParent ==. parentId]
      (maybe [] (.configureOpts.nonPathRelated) mold)
      new.configureOpts.nonPathRelated
    updateCollection
      (setUpdateDiff ConfigCacheDepValue)
      (ConfigCacheDep parentId)
      [ConfigCacheDepParent ==. parentId]
      (maybe Set.empty (.deps) mold)
      new.deps
    updateCollection
      (setUpdateDiff ConfigCacheComponentValue)
      (ConfigCacheComponent parentId)
      [ConfigCacheComponentParent ==. parentId]
      (maybe Set.empty (.components) mold)
      new.components

-- | Mark t'ConfigCache' as inactive in the database. We use a flag instead of
-- deleting the records since, in most cases, the same cache will be written
-- again within in a few seconds (after `cabal configure`), so this avoids
-- unnecessary database churn.
deactiveConfigCache :: HasBuildConfig env => ConfigCacheKey -> RIO env ()
deactiveConfigCache (UniqueConfigCacheParent dir type_) =
  withProjectStorage $
    updateWhere
      [ConfigCacheParentDirectory ==. dir, ConfigCacheParentType ==. type_]
      [ConfigCacheParentActive =. False]