{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-}

-- | Work with SQLite database used for caches across an entire user account.

module Stack.Storage.User
  ( initUserStorage
  , PrecompiledCacheKey
  , precompiledCacheKey
  , loadPrecompiledCache
  , savePrecompiledCache
  , loadDockerImageExeCache
  , saveDockerImageExeCache
  , loadCompilerPaths
  , saveCompilerPaths
  , upgradeChecksSince
  , logUpgradeCheck
  ) where

import qualified Data.Set as Set
import qualified Data.Text as T
import           Data.Time.Clock ( UTCTime )
import           Database.Persist.Sqlite
                   ( Entity (..), SqlBackend, Unique, (=.), (==.), (>=.), count
                   , deleteBy, getBy, insert, insert_, selectList, update
                   , upsert
                   )
import           Database.Persist.TH
                   ( mkMigrate, mkPersist, persistLowerCase, share
                   , sqlSettings
                   )
import           Distribution.Text ( simpleParse, display )
import           Foreign.C.Types ( CTime (..) )
import           Pantry.SQLite ( initStorage, withStorage_ )
import           Path ( (</>), mkRelFile, parseRelFile )
import           Path.IO ( resolveFile', resolveDir' )
import qualified RIO.FilePath as FP
import           Stack.Prelude
import           Stack.Storage.Util ( handleMigrationException, updateSet )
import           Stack.Types.Build ( PrecompiledCache (..) )
import           Stack.Types.Cache ( Action (..) )
import           Stack.Types.Compiler ( ActualCompiler, compilerVersionText )
import           Stack.Types.CompilerBuild ( CompilerBuild )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), GhcPkgExe (..) )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.Storage ( UserStorage (..) )
import           System.Posix.Types ( COff (..) )
import           System.PosixCompat.Files
                   ( fileSize, getFileStatus, modificationTime )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Storage.User" module.

data StorageUserException
  = CompilerFileMetadataMismatch
  | GlobalPackageCacheFileMetadataMismatch
  | GlobalDumpParseFailure
  | CompilerCacheArchitectureInvalid Text
  deriving (Int -> StorageUserException -> ShowS
[StorageUserException] -> ShowS
StorageUserException -> String
(Int -> StorageUserException -> ShowS)
-> (StorageUserException -> String)
-> ([StorageUserException] -> ShowS)
-> Show StorageUserException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StorageUserException -> ShowS
showsPrec :: Int -> StorageUserException -> ShowS
$cshow :: StorageUserException -> String
show :: StorageUserException -> String
$cshowList :: [StorageUserException] -> ShowS
showList :: [StorageUserException] -> ShowS
Show, Typeable)

instance Exception StorageUserException where
  displayException :: StorageUserException -> String
displayException StorageUserException
CompilerFileMetadataMismatch =
    String
"Error: [S-8196]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Compiler file metadata mismatch, ignoring cache."
  displayException StorageUserException
GlobalPackageCacheFileMetadataMismatch =
    String
"Error: [S-5378]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Global package cache file metadata mismatch, ignoring cache."
  displayException StorageUserException
GlobalDumpParseFailure =
    String
"Error: [S-2673]\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Global dump did not parse correctly."
  displayException
    (CompilerCacheArchitectureInvalid Text
compilerCacheArch) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"Error: [S-8441]\n"
      , String
"Invalid arch: "
      , Text -> String
forall a. Show a => a -> String
show Text
compilerCacheArch
      ]

share [ mkPersist sqlSettings
      , mkMigrate "migrateAll"
      ]
      [persistLowerCase|
PrecompiledCacheParent sql="precompiled_cache"
  platformGhcDir FilePath "default=(hex(randomblob(16)))"
  compiler Text
  cabalVersion Text
  packageKey Text
  optionsHash ByteString
  haddock Bool default=0
  library FilePath Maybe
  UniquePrecompiledCacheParent platformGhcDir compiler cabalVersion packageKey optionsHash haddock sql="unique_precompiled_cache"
  deriving Show

PrecompiledCacheSubLib
  parent PrecompiledCacheParentId sql="precompiled_cache_id" OnDeleteCascade
  value FilePath sql="sub_lib"
  UniquePrecompiledCacheSubLib parent value
  deriving Show

PrecompiledCacheExe
  parent PrecompiledCacheParentId sql="precompiled_cache_id" OnDeleteCaseCascade
  value FilePath sql="exe"
  UniquePrecompiledCacheExe parent value
  deriving Show

DockerImageExeCache
  imageHash Text
  exePath FilePath
  exeTimestamp UTCTime
  compatible Bool
  DockerImageExeCacheUnique imageHash exePath exeTimestamp
  deriving Show

CompilerCache
  actualVersion ActualCompiler
  arch Text

  -- Include ghc executable size and modified time for sanity checking entries
  ghcPath FilePath
  ghcSize Int64
  ghcModified Int64

  ghcPkgPath FilePath
  runghcPath FilePath
  haddockPath FilePath

  cabalVersion Text
  globalDb FilePath
  globalDbCacheSize Int64
  globalDbCacheModified Int64
  info ByteString

  -- This is the ugliest part of this table, simply storing a Show/Read version of the
  -- data. We could do a better job with normalized data and proper table structure.
  -- However, recomputing this value in the future if the data representation changes
  -- is very cheap, so we'll take the easy way out for now.
  globalDump Text

  UniqueCompilerInfo ghcPath

-- Last time certain actions were performed
LastPerformed
  action Action
  timestamp UTCTime
  UniqueAction action
|]

-- | Initialize the database.

initUserStorage ::
     HasLogFunc env
  => Path Abs File -- ^ storage file

  -> (UserStorage -> RIO env a)
  -> RIO env a
initUserStorage :: forall env a.
HasLogFunc env =>
Path Abs File -> (UserStorage -> RIO env a) -> RIO env a
initUserStorage Path Abs File
fp UserStorage -> RIO env a
f = RIO env a -> RIO env a
forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException (RIO env a -> RIO env a) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$
  Text
-> Migration
-> Path Abs File
-> (Storage -> RIO env a)
-> RIO env a
forall env a.
HasLogFunc env =>
Text
-> Migration
-> Path Abs File
-> (Storage -> RIO env a)
-> RIO env a
initStorage Text
"Stack" Migration
migrateAll Path Abs File
fp ((Storage -> RIO env a) -> RIO env a)
-> (Storage -> RIO env a) -> RIO env a
forall a b. (a -> b) -> a -> b
$ UserStorage -> RIO env a
f (UserStorage -> RIO env a)
-> (Storage -> UserStorage) -> Storage -> RIO env a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Storage -> UserStorage
UserStorage

-- | Run an action in a database transaction

withUserStorage ::
     (HasConfig env, HasLogFunc env)
  => ReaderT SqlBackend (RIO env) a
  -> RIO env a
withUserStorage :: forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage ReaderT SqlBackend (RIO env) a
inner = do
  Storage
storage <- Getting Storage env Storage -> RIO env Storage
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Config -> Const Storage Config) -> env -> Const Storage env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL ((Config -> Const Storage Config) -> env -> Const Storage env)
-> ((Storage -> Const Storage Storage)
    -> Config -> Const Storage Config)
-> Getting Storage env Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> UserStorage) -> SimpleGetter Config UserStorage
forall s a. (s -> a) -> SimpleGetter s a
to Config -> UserStorage
configUserStorage Getting Storage Config UserStorage
-> ((Storage -> Const Storage Storage)
    -> UserStorage -> Const Storage UserStorage)
-> (Storage -> Const Storage Storage)
-> Config
-> Const Storage Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserStorage -> Storage) -> SimpleGetter UserStorage Storage
forall s a. (s -> a) -> SimpleGetter s a
to UserStorage -> Storage
unUserStorage)
  Storage
-> forall env a.
   HasLogFunc env =>
   ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage_ Storage
storage ReaderT SqlBackend (RIO env) a
inner

-- | Key used to retrieve the precompiled cache

type PrecompiledCacheKey = Unique PrecompiledCacheParent

-- | Build key used to retrieve the precompiled cache

precompiledCacheKey ::
     Path Rel Dir
  -> ActualCompiler
  -> Version
  -> Text
  -> ByteString
  -> Bool
  -> PrecompiledCacheKey
precompiledCacheKey :: Path Rel Dir
-> ActualCompiler
-> Version
-> Text
-> ByteString
-> Bool
-> Unique PrecompiledCacheParent
precompiledCacheKey Path Rel Dir
platformGhcDir ActualCompiler
compiler Version
cabalVersion =
  String
-> Text
-> Text
-> Text
-> ByteString
-> Bool
-> Unique PrecompiledCacheParent
UniquePrecompiledCacheParent
    (Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath Path Rel Dir
platformGhcDir)
    (ActualCompiler -> Text
compilerVersionText ActualCompiler
compiler)
    (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
cabalVersion)

-- | Internal helper to read the 'PrecompiledCache' from the database

readPrecompiledCache ::
     (HasConfig env, HasLogFunc env)
  => PrecompiledCacheKey
  -> ReaderT SqlBackend (RIO env) (Maybe ( PrecompiledCacheParentId
                                         , PrecompiledCache Rel))
readPrecompiledCache :: forall env.
(HasConfig env, HasLogFunc env) =>
Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
readPrecompiledCache Unique PrecompiledCacheParent
key = do
  Maybe (Entity PrecompiledCacheParent)
mparent <- Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend (RIO env) (Maybe (Entity PrecompiledCacheParent))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy Unique PrecompiledCacheParent
key
  Maybe (Entity PrecompiledCacheParent)
-> (Entity PrecompiledCacheParent
    -> ReaderT
         SqlBackend
         (RIO env)
         (Key PrecompiledCacheParent, PrecompiledCache Rel))
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Entity PrecompiledCacheParent)
mparent ((Entity PrecompiledCacheParent
  -> ReaderT
       SqlBackend
       (RIO env)
       (Key PrecompiledCacheParent, PrecompiledCache Rel))
 -> ReaderT
      SqlBackend
      (RIO env)
      (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)))
-> (Entity PrecompiledCacheParent
    -> ReaderT
         SqlBackend
         (RIO env)
         (Key PrecompiledCacheParent, PrecompiledCache Rel))
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
forall a b. (a -> b) -> a -> b
$ \(Entity Key PrecompiledCacheParent
parentId PrecompiledCacheParent {Bool
String
Maybe String
ByteString
Text
precompiledCacheParentPlatformGhcDir :: PrecompiledCacheParent -> String
precompiledCacheParentCompiler :: PrecompiledCacheParent -> Text
precompiledCacheParentCabalVersion :: PrecompiledCacheParent -> Text
precompiledCacheParentPackageKey :: PrecompiledCacheParent -> Text
precompiledCacheParentOptionsHash :: PrecompiledCacheParent -> ByteString
precompiledCacheParentHaddock :: PrecompiledCacheParent -> Bool
precompiledCacheParentLibrary :: PrecompiledCacheParent -> Maybe String
precompiledCacheParentPlatformGhcDir :: String
precompiledCacheParentCompiler :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentPackageKey :: Text
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentHaddock :: Bool
precompiledCacheParentLibrary :: Maybe String
..}) -> do
    Maybe (Path Rel File)
pcLibrary <- (String -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> Maybe String
-> ReaderT SqlBackend (RIO env) (Maybe (Path Rel File))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM String -> ReaderT SqlBackend (RIO env) (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile Maybe String
precompiledCacheParentLibrary
    [Path Rel File]
pcSubLibs <-
      (Entity PrecompiledCacheSubLib
 -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> [Entity PrecompiledCacheSubLib]
-> ReaderT SqlBackend (RIO env) [Path Rel File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> ReaderT SqlBackend (RIO env) (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> (Entity PrecompiledCacheSubLib -> String)
-> Entity PrecompiledCacheSubLib
-> ReaderT SqlBackend (RIO env) (Path Rel File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCacheSubLib -> String
precompiledCacheSubLibValue (PrecompiledCacheSubLib -> String)
-> (Entity PrecompiledCacheSubLib -> PrecompiledCacheSubLib)
-> Entity PrecompiledCacheSubLib
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PrecompiledCacheSubLib -> PrecompiledCacheSubLib
forall record. Entity record -> record
entityVal) ([Entity PrecompiledCacheSubLib]
 -> ReaderT SqlBackend (RIO env) [Path Rel File])
-> ReaderT SqlBackend (RIO env) [Entity PrecompiledCacheSubLib]
-> ReaderT SqlBackend (RIO env) [Path Rel File]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      [Filter PrecompiledCacheSubLib]
-> [SelectOpt PrecompiledCacheSubLib]
-> ReaderT SqlBackend (RIO env) [Entity PrecompiledCacheSubLib]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibParent EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent -> Filter PrecompiledCacheSubLib
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PrecompiledCacheParent
parentId] []
    [Path Rel File]
pcExes <-
      (Entity PrecompiledCacheExe
 -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> [Entity PrecompiledCacheExe]
-> ReaderT SqlBackend (RIO env) [Path Rel File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> ReaderT SqlBackend (RIO env) (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> ReaderT SqlBackend (RIO env) (Path Rel File))
-> (Entity PrecompiledCacheExe -> String)
-> Entity PrecompiledCacheExe
-> ReaderT SqlBackend (RIO env) (Path Rel File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCacheExe -> String
precompiledCacheExeValue (PrecompiledCacheExe -> String)
-> (Entity PrecompiledCacheExe -> PrecompiledCacheExe)
-> Entity PrecompiledCacheExe
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity PrecompiledCacheExe -> PrecompiledCacheExe
forall record. Entity record -> record
entityVal) ([Entity PrecompiledCacheExe]
 -> ReaderT SqlBackend (RIO env) [Path Rel File])
-> ReaderT SqlBackend (RIO env) [Entity PrecompiledCacheExe]
-> ReaderT SqlBackend (RIO env) [Path Rel File]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      [Filter PrecompiledCacheExe]
-> [SelectOpt PrecompiledCacheExe]
-> ReaderT SqlBackend (RIO env) [Entity PrecompiledCacheExe]
forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheExe typ
PrecompiledCacheExeParent EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent -> Filter PrecompiledCacheExe
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PrecompiledCacheParent
parentId] []
    (Key PrecompiledCacheParent, PrecompiledCache Rel)
-> ReaderT
     SqlBackend
     (RIO env)
     (Key PrecompiledCacheParent, PrecompiledCache Rel)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key PrecompiledCacheParent
parentId, PrecompiledCache {[Path Rel File]
Maybe (Path Rel File)
pcLibrary :: Maybe (Path Rel File)
pcSubLibs :: [Path Rel File]
pcExes :: [Path Rel File]
pcLibrary :: Maybe (Path Rel File)
pcSubLibs :: [Path Rel File]
pcExes :: [Path Rel File]
..})

-- | Load 'PrecompiledCache' from the database.

loadPrecompiledCache ::
     (HasConfig env, HasLogFunc env)
  => PrecompiledCacheKey
  -> RIO env (Maybe (PrecompiledCache Rel))
loadPrecompiledCache :: forall env.
(HasConfig env, HasLogFunc env) =>
Unique PrecompiledCacheParent
-> RIO env (Maybe (PrecompiledCache Rel))
loadPrecompiledCache Unique PrecompiledCacheParent
key =
  ReaderT SqlBackend (RIO env) (Maybe (PrecompiledCache Rel))
-> RIO env (Maybe (PrecompiledCache Rel))
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) (Maybe (PrecompiledCache Rel))
 -> RIO env (Maybe (PrecompiledCache Rel)))
-> ReaderT SqlBackend (RIO env) (Maybe (PrecompiledCache Rel))
-> RIO env (Maybe (PrecompiledCache Rel))
forall a b. (a -> b) -> a -> b
$ ((Key PrecompiledCacheParent, PrecompiledCache Rel)
 -> PrecompiledCache Rel)
-> Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
-> Maybe (PrecompiledCache Rel)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key PrecompiledCacheParent, PrecompiledCache Rel)
-> PrecompiledCache Rel
forall a b. (a, b) -> b
snd (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
 -> Maybe (PrecompiledCache Rel))
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
-> ReaderT SqlBackend (RIO env) (Maybe (PrecompiledCache Rel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
forall env.
(HasConfig env, HasLogFunc env) =>
Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
readPrecompiledCache Unique PrecompiledCacheParent
key

-- | Insert or update 'PrecompiledCache' to the database.

savePrecompiledCache ::
     (HasConfig env, HasLogFunc env)
  => PrecompiledCacheKey
  -> PrecompiledCache Rel
  -> RIO env ()
savePrecompiledCache :: forall env.
(HasConfig env, HasLogFunc env) =>
Unique PrecompiledCacheParent -> PrecompiledCache Rel -> RIO env ()
savePrecompiledCache
  key :: Unique PrecompiledCacheParent
key@( UniquePrecompiledCacheParent
          String
precompiledCacheParentPlatformGhcDir
          Text
precompiledCacheParentCompiler
          Text
precompiledCacheParentCabalVersion
          Text
precompiledCacheParentPackageKey
          ByteString
precompiledCacheParentOptionsHash
          Bool
precompiledCacheParentHaddock
      )
  PrecompiledCache Rel
new
  = ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
      let precompiledCacheParentLibrary :: Maybe String
precompiledCacheParentLibrary = (Path Rel File -> String) -> Maybe (Path Rel File) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Rel File -> String
forall b t. Path b t -> String
toFilePath (PrecompiledCache Rel -> Maybe (Path Rel File)
forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary PrecompiledCache Rel
new)
      Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
mIdOld <- Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
forall env.
(HasConfig env, HasLogFunc env) =>
Unique PrecompiledCacheParent
-> ReaderT
     SqlBackend
     (RIO env)
     (Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel))
readPrecompiledCache Unique PrecompiledCacheParent
key
      (Key PrecompiledCacheParent
parentId, Maybe (PrecompiledCache Rel)
mold) <-
        case Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
mIdOld of
          Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
Nothing -> (, Maybe (PrecompiledCache Rel)
forall a. Maybe a
Nothing) (Key PrecompiledCacheParent
 -> (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel)))
-> ReaderT SqlBackend (RIO env) (Key PrecompiledCacheParent)
-> ReaderT
     SqlBackend
     (RIO env)
     (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrecompiledCacheParent
-> ReaderT SqlBackend (RIO env) (Key PrecompiledCacheParent)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend m (Key record)
insert PrecompiledCacheParent {Bool
String
Maybe String
ByteString
Text
precompiledCacheParentPlatformGhcDir :: String
precompiledCacheParentCompiler :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentPackageKey :: Text
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentHaddock :: Bool
precompiledCacheParentLibrary :: Maybe String
precompiledCacheParentPlatformGhcDir :: String
precompiledCacheParentCompiler :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentPackageKey :: Text
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentHaddock :: Bool
precompiledCacheParentLibrary :: Maybe String
..}
          Just (Key PrecompiledCacheParent
parentId, PrecompiledCache Rel
old) -> do
            Key PrecompiledCacheParent
-> [Update PrecompiledCacheParent]
-> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Key record -> [Update record] -> ReaderT SqlBackend m ()
update
              Key PrecompiledCacheParent
parentId
              [ EntityField PrecompiledCacheParent (Maybe String)
forall typ.
(typ ~ Maybe String) =>
EntityField PrecompiledCacheParent typ
PrecompiledCacheParentLibrary EntityField PrecompiledCacheParent (Maybe String)
-> Maybe String -> Update PrecompiledCacheParent
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.
                Maybe String
precompiledCacheParentLibrary
              ]
            (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel))
-> ReaderT
     SqlBackend
     (RIO env)
     (Key PrecompiledCacheParent, Maybe (PrecompiledCache Rel))
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key PrecompiledCacheParent
parentId, PrecompiledCache Rel -> Maybe (PrecompiledCache Rel)
forall a. a -> Maybe a
Just PrecompiledCache Rel
old)
      (Key PrecompiledCacheParent -> String -> PrecompiledCacheSubLib)
-> EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent
-> EntityField PrecompiledCacheSubLib String
-> Set String
-> Set String
-> ReaderT SqlBackend (RIO env) ()
forall record backend parentid value (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistField parentid, PersistField value, Ord value,
 PersistEntity record, MonadIO m, PersistQueryWrite backend,
 SafeToInsert record) =>
(parentid -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record value
-> Set value
-> Set value
-> ReaderT backend m ()
updateSet
        Key PrecompiledCacheParent -> String -> PrecompiledCacheSubLib
PrecompiledCacheSubLib
        EntityField PrecompiledCacheSubLib (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibParent
        Key PrecompiledCacheParent
parentId
        EntityField PrecompiledCacheSubLib String
forall typ.
(typ ~ String) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibValue
        (Set String
-> (PrecompiledCache Rel -> Set String)
-> Maybe (PrecompiledCache Rel)
-> Set String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set String
forall a. Set a
Set.empty ([Path Rel File] -> Set String
forall {b} {t}. [Path b t] -> Set String
toFilePathSet ([Path Rel File] -> Set String)
-> (PrecompiledCache Rel -> [Path Rel File])
-> PrecompiledCache Rel
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCache Rel -> [Path Rel File]
forall base. PrecompiledCache base -> [Path base File]
pcSubLibs) Maybe (PrecompiledCache Rel)
mold)
        ([Path Rel File] -> Set String
forall {b} {t}. [Path b t] -> Set String
toFilePathSet ([Path Rel File] -> Set String) -> [Path Rel File] -> Set String
forall a b. (a -> b) -> a -> b
$ PrecompiledCache Rel -> [Path Rel File]
forall base. PrecompiledCache base -> [Path base File]
pcSubLibs PrecompiledCache Rel
new)
      (Key PrecompiledCacheParent -> String -> PrecompiledCacheExe)
-> EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
-> Key PrecompiledCacheParent
-> EntityField PrecompiledCacheExe String
-> Set String
-> Set String
-> ReaderT SqlBackend (RIO env) ()
forall record backend parentid value (m :: * -> *).
(PersistEntityBackend record ~ BaseBackend backend,
 PersistField parentid, PersistField value, Ord value,
 PersistEntity record, MonadIO m, PersistQueryWrite backend,
 SafeToInsert record) =>
(parentid -> value -> record)
-> EntityField record parentid
-> parentid
-> EntityField record value
-> Set value
-> Set value
-> ReaderT backend m ()
updateSet
        Key PrecompiledCacheParent -> String -> PrecompiledCacheExe
PrecompiledCacheExe
        EntityField PrecompiledCacheExe (Key PrecompiledCacheParent)
forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheExe typ
PrecompiledCacheExeParent
        Key PrecompiledCacheParent
parentId
        EntityField PrecompiledCacheExe String
forall typ. (typ ~ String) => EntityField PrecompiledCacheExe typ
PrecompiledCacheExeValue
        (Set String
-> (PrecompiledCache Rel -> Set String)
-> Maybe (PrecompiledCache Rel)
-> Set String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set String
forall a. Set a
Set.empty ([Path Rel File] -> Set String
forall {b} {t}. [Path b t] -> Set String
toFilePathSet ([Path Rel File] -> Set String)
-> (PrecompiledCache Rel -> [Path Rel File])
-> PrecompiledCache Rel
-> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCache Rel -> [Path Rel File]
forall base. PrecompiledCache base -> [Path base File]
pcExes) Maybe (PrecompiledCache Rel)
mold)
        ([Path Rel File] -> Set String
forall {b} {t}. [Path b t] -> Set String
toFilePathSet ([Path Rel File] -> Set String) -> [Path Rel File] -> Set String
forall a b. (a -> b) -> a -> b
$ PrecompiledCache Rel -> [Path Rel File]
forall base. PrecompiledCache base -> [Path base File]
pcExes PrecompiledCache Rel
new)
 where
  toFilePathSet :: [Path b t] -> Set String
toFilePathSet = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String)
-> ([Path b t] -> [String]) -> [Path b t] -> Set String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path b t -> String) -> [Path b t] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Path b t -> String
forall b t. Path b t -> String
toFilePath

-- | Get the record of whether an executable is compatible with a Docker image

loadDockerImageExeCache ::
     (HasConfig env, HasLogFunc env)
  => Text
  -> Path Abs File
  -> UTCTime
  -> RIO env (Maybe Bool)
loadDockerImageExeCache :: forall env.
(HasConfig env, HasLogFunc env) =>
Text -> Path Abs File -> UTCTime -> RIO env (Maybe Bool)
loadDockerImageExeCache Text
imageId Path Abs File
exePath UTCTime
exeTimestamp = ReaderT SqlBackend (RIO env) (Maybe Bool) -> RIO env (Maybe Bool)
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) (Maybe Bool) -> RIO env (Maybe Bool))
-> ReaderT SqlBackend (RIO env) (Maybe Bool)
-> RIO env (Maybe Bool)
forall a b. (a -> b) -> a -> b
$
  (Entity DockerImageExeCache -> Bool)
-> Maybe (Entity DockerImageExeCache) -> Maybe Bool
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DockerImageExeCache -> Bool
dockerImageExeCacheCompatible (DockerImageExeCache -> Bool)
-> (Entity DockerImageExeCache -> DockerImageExeCache)
-> Entity DockerImageExeCache
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity DockerImageExeCache -> DockerImageExeCache
forall record. Entity record -> record
entityVal) (Maybe (Entity DockerImageExeCache) -> Maybe Bool)
-> ReaderT
     SqlBackend (RIO env) (Maybe (Entity DockerImageExeCache))
-> ReaderT SqlBackend (RIO env) (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  Unique DockerImageExeCache
-> ReaderT
     SqlBackend (RIO env) (Maybe (Entity DockerImageExeCache))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy (Text -> String -> UTCTime -> Unique DockerImageExeCache
DockerImageExeCacheUnique Text
imageId (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
exePath) UTCTime
exeTimestamp)

-- | Sets the record of whether an executable is compatible with a Docker image

saveDockerImageExeCache ::
     (HasConfig env, HasLogFunc env)
  => Text
  -> Path Abs File
  -> UTCTime
  -> Bool
  -> RIO env ()
saveDockerImageExeCache :: forall env.
(HasConfig env, HasLogFunc env) =>
Text -> Path Abs File -> UTCTime -> Bool -> RIO env ()
saveDockerImageExeCache Text
imageId Path Abs File
exePath UTCTime
exeTimestamp Bool
compatible = RIO env (Entity DockerImageExeCache) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env (Entity DockerImageExeCache) -> RIO env ())
-> RIO env (Entity DockerImageExeCache) -> RIO env ()
forall a b. (a -> b) -> a -> b
$
  ReaderT SqlBackend (RIO env) (Entity DockerImageExeCache)
-> RIO env (Entity DockerImageExeCache)
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) (Entity DockerImageExeCache)
 -> RIO env (Entity DockerImageExeCache))
-> ReaderT SqlBackend (RIO env) (Entity DockerImageExeCache)
-> RIO env (Entity DockerImageExeCache)
forall a b. (a -> b) -> a -> b
$
    DockerImageExeCache
-> [Update DockerImageExeCache]
-> ReaderT SqlBackend (RIO env) (Entity DockerImageExeCache)
forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, OnlyOneUniqueKey record,
 SafeToInsert record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 OnlyOneUniqueKey record, SafeToInsert record) =>
record -> [Update record] -> ReaderT SqlBackend m (Entity record)
upsert
      ( Text -> String -> UTCTime -> Bool -> DockerImageExeCache
DockerImageExeCache
          Text
imageId
          (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
exePath)
          UTCTime
exeTimestamp
          Bool
compatible
      )
      []

-- | Type-restricted version of 'fromIntegral' to ensure we're making the value

-- bigger, not smaller.

sizeToInt64 :: COff -> Int64
sizeToInt64 :: COff -> Int64
sizeToInt64 (COff Int64
i) = Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i -- fromIntegral added for 32-bit systems


-- | Type-restricted version of 'fromIntegral' to ensure we're making the value

-- bigger, not smaller.

timeToInt64 :: CTime -> Int64
timeToInt64 :: CTime -> Int64
timeToInt64 (CTime Int64
i) = Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i -- fromIntegral added for 32-bit systems


-- | Load compiler information, if available, and confirm that the referenced

-- files are unchanged. May throw exceptions!

loadCompilerPaths ::
     HasConfig env
  => Path Abs File -- ^ compiler executable

  -> CompilerBuild
  -> Bool -- ^ sandboxed?

  -> RIO env (Maybe CompilerPaths)
loadCompilerPaths :: forall env.
HasConfig env =>
Path Abs File
-> CompilerBuild -> Bool -> RIO env (Maybe CompilerPaths)
loadCompilerPaths Path Abs File
compiler CompilerBuild
build Bool
sandboxed = do
  Maybe (Entity CompilerCache)
mres <- ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
-> RIO env (Maybe (Entity CompilerCache))
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
 -> RIO env (Maybe (Entity CompilerCache)))
-> ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
-> RIO env (Maybe (Entity CompilerCache))
forall a b. (a -> b) -> a -> b
$ Unique CompilerCache
-> ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m (Maybe (Entity record))
getBy (Unique CompilerCache
 -> ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache)))
-> Unique CompilerCache
-> ReaderT SqlBackend (RIO env) (Maybe (Entity CompilerCache))
forall a b. (a -> b) -> a -> b
$ String -> Unique CompilerCache
UniqueCompilerInfo (String -> Unique CompilerCache) -> String -> Unique CompilerCache
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
compiler
  Maybe (Entity CompilerCache)
-> (Entity CompilerCache -> RIO env CompilerPaths)
-> RIO env (Maybe CompilerPaths)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (Entity CompilerCache)
mres ((Entity CompilerCache -> RIO env CompilerPaths)
 -> RIO env (Maybe CompilerPaths))
-> (Entity CompilerCache -> RIO env CompilerPaths)
-> RIO env (Maybe CompilerPaths)
forall a b. (a -> b) -> a -> b
$ \(Entity Key CompilerCache
_ CompilerCache {Int64
String
ByteString
Text
ActualCompiler
compilerCacheActualVersion :: CompilerCache -> ActualCompiler
compilerCacheArch :: CompilerCache -> Text
compilerCacheGhcPath :: CompilerCache -> String
compilerCacheGhcSize :: CompilerCache -> Int64
compilerCacheGhcModified :: CompilerCache -> Int64
compilerCacheGhcPkgPath :: CompilerCache -> String
compilerCacheRunghcPath :: CompilerCache -> String
compilerCacheHaddockPath :: CompilerCache -> String
compilerCacheCabalVersion :: CompilerCache -> Text
compilerCacheGlobalDb :: CompilerCache -> String
compilerCacheGlobalDbCacheSize :: CompilerCache -> Int64
compilerCacheGlobalDbCacheModified :: CompilerCache -> Int64
compilerCacheInfo :: CompilerCache -> ByteString
compilerCacheGlobalDump :: CompilerCache -> Text
compilerCacheActualVersion :: ActualCompiler
compilerCacheArch :: Text
compilerCacheGhcPath :: String
compilerCacheGhcSize :: Int64
compilerCacheGhcModified :: Int64
compilerCacheGhcPkgPath :: String
compilerCacheRunghcPath :: String
compilerCacheHaddockPath :: String
compilerCacheCabalVersion :: Text
compilerCacheGlobalDb :: String
compilerCacheGlobalDbCacheSize :: Int64
compilerCacheGlobalDbCacheModified :: Int64
compilerCacheInfo :: ByteString
compilerCacheGlobalDump :: Text
..}) -> do
    FileStatus
compilerStatus <- IO FileStatus -> RIO env FileStatus
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> RIO env FileStatus)
-> IO FileStatus -> RIO env FileStatus
forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus (String -> IO FileStatus) -> String -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
compiler
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (  Int64
compilerCacheGhcSize Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
compilerStatus)
      Bool -> Bool -> Bool
|| Int64
compilerCacheGhcModified Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/=
           CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
compilerStatus)
      )
      (StorageUserException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StorageUserException
CompilerFileMetadataMismatch)
    FileStatus
globalDbStatus <-
      IO FileStatus -> RIO env FileStatus
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> RIO env FileStatus)
-> IO FileStatus -> RIO env FileStatus
forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus (String -> IO FileStatus) -> String -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ String
compilerCacheGlobalDb String -> ShowS
FP.</> String
"package.cache"
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (  Int64
compilerCacheGlobalDbCacheSize Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
globalDbStatus)
      Bool -> Bool -> Bool
|| Int64
compilerCacheGlobalDbCacheModified Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/=
           CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
globalDbStatus)
      )
      (StorageUserException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StorageUserException
GlobalPackageCacheFileMetadataMismatch)

    -- We could use parseAbsFile instead of resolveFile' below to bypass some

    -- system calls, at the cost of some really wonky error messages in case

    -- someone screws up their GHC installation

    Path Abs File
pkgexe <- String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
compilerCacheGhcPkgPath
    Path Abs File
runghc <- String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
compilerCacheRunghcPath
    Path Abs File
haddock <- String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
compilerCacheHaddockPath
    Path Abs Dir
globaldb <- String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
compilerCacheGlobalDb

    Version
cabalVersion <- String -> RIO env Version
forall (m :: * -> *). MonadThrow m => String -> m Version
parseVersionThrowing (String -> RIO env Version) -> String -> RIO env Version
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
compilerCacheCabalVersion
    Map PackageName DumpPackage
globalDump <-
      case String -> Maybe (Map PackageName DumpPackage)
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe (Map PackageName DumpPackage))
-> String -> Maybe (Map PackageName DumpPackage)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
compilerCacheGlobalDump of
        Maybe (Map PackageName DumpPackage)
Nothing -> StorageUserException -> RIO env (Map PackageName DumpPackage)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StorageUserException
GlobalDumpParseFailure
        Just Map PackageName DumpPackage
globalDump -> Map PackageName DumpPackage
-> RIO env (Map PackageName DumpPackage)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName DumpPackage
globalDump
    Arch
arch <-
      case String -> Maybe Arch
forall a. Parsec a => String -> Maybe a
simpleParse (String -> Maybe Arch) -> String -> Maybe Arch
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
compilerCacheArch of
        Maybe Arch
Nothing -> StorageUserException -> RIO env Arch
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (StorageUserException -> RIO env Arch)
-> StorageUserException -> RIO env Arch
forall a b. (a -> b) -> a -> b
$ Text -> StorageUserException
CompilerCacheArchitectureInvalid Text
compilerCacheArch
        Just Arch
arch -> Arch -> RIO env Arch
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Arch
arch

    CompilerPaths -> RIO env CompilerPaths
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompilerPaths
      { cpCompiler :: Path Abs File
cpCompiler = Path Abs File
compiler
      , cpCompilerVersion :: ActualCompiler
cpCompilerVersion = ActualCompiler
compilerCacheActualVersion
      , cpArch :: Arch
cpArch = Arch
arch
      , cpBuild :: CompilerBuild
cpBuild = CompilerBuild
build
      , cpPkg :: GhcPkgExe
cpPkg = Path Abs File -> GhcPkgExe
GhcPkgExe Path Abs File
pkgexe
      , cpInterpreter :: Path Abs File
cpInterpreter = Path Abs File
runghc
      , cpHaddock :: Path Abs File
cpHaddock = Path Abs File
haddock
      , cpSandboxed :: Bool
cpSandboxed = Bool
sandboxed
      , cpCabalVersion :: Version
cpCabalVersion = Version
cabalVersion
      , cpGlobalDB :: Path Abs Dir
cpGlobalDB = Path Abs Dir
globaldb
      , cpGhcInfo :: ByteString
cpGhcInfo = ByteString
compilerCacheInfo
      , cpGlobalDump :: Map PackageName DumpPackage
cpGlobalDump = Map PackageName DumpPackage
globalDump
      }

-- | Save compiler information. May throw exceptions!

saveCompilerPaths ::
     HasConfig env
  => CompilerPaths
  -> RIO env ()
saveCompilerPaths :: forall env. HasConfig env => CompilerPaths -> RIO env ()
saveCompilerPaths CompilerPaths {Bool
Version
Map PackageName DumpPackage
Arch
ByteString
Path Abs Dir
Path Abs File
CompilerBuild
ActualCompiler
GhcPkgExe
cpCompiler :: CompilerPaths -> Path Abs File
cpCompilerVersion :: CompilerPaths -> ActualCompiler
cpArch :: CompilerPaths -> Arch
cpBuild :: CompilerPaths -> CompilerBuild
cpPkg :: CompilerPaths -> GhcPkgExe
cpInterpreter :: CompilerPaths -> Path Abs File
cpHaddock :: CompilerPaths -> Path Abs File
cpSandboxed :: CompilerPaths -> Bool
cpCabalVersion :: CompilerPaths -> Version
cpGlobalDB :: CompilerPaths -> Path Abs Dir
cpGhcInfo :: CompilerPaths -> ByteString
cpGlobalDump :: CompilerPaths -> Map PackageName DumpPackage
cpCompilerVersion :: ActualCompiler
cpArch :: Arch
cpBuild :: CompilerBuild
cpCompiler :: Path Abs File
cpPkg :: GhcPkgExe
cpInterpreter :: Path Abs File
cpHaddock :: Path Abs File
cpSandboxed :: Bool
cpCabalVersion :: Version
cpGlobalDB :: Path Abs Dir
cpGhcInfo :: ByteString
cpGlobalDump :: Map PackageName DumpPackage
..} = ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
  Unique CompilerCache -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend) =>
Unique record -> ReaderT SqlBackend m ()
deleteBy (Unique CompilerCache -> ReaderT SqlBackend (RIO env) ())
-> Unique CompilerCache -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ String -> Unique CompilerCache
UniqueCompilerInfo (String -> Unique CompilerCache) -> String -> Unique CompilerCache
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
cpCompiler
  FileStatus
compilerStatus <- IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall a. IO a -> ReaderT SqlBackend (RIO env) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus)
-> IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus (String -> IO FileStatus) -> String -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
cpCompiler
  FileStatus
globalDbStatus <-
    IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall a. IO a -> ReaderT SqlBackend (RIO env) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus)
-> IO FileStatus -> ReaderT SqlBackend (RIO env) FileStatus
forall a b. (a -> b) -> a -> b
$
      String -> IO FileStatus
getFileStatus (String -> IO FileStatus) -> String -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String) -> Path Abs File -> String
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
cpGlobalDB Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelFile "package.cache")
  let GhcPkgExe Path Abs File
pkgexe = GhcPkgExe
cpPkg
  CompilerCache -> ReaderT SqlBackend (RIO env) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend m ()
insert_ CompilerCache
    { compilerCacheActualVersion :: ActualCompiler
compilerCacheActualVersion = ActualCompiler
cpCompilerVersion
    , compilerCacheGhcPath :: String
compilerCacheGhcPath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
cpCompiler
    , compilerCacheGhcSize :: Int64
compilerCacheGhcSize = COff -> Int64
sizeToInt64 (COff -> Int64) -> COff -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
compilerStatus
    , compilerCacheGhcModified :: Int64
compilerCacheGhcModified = CTime -> Int64
timeToInt64 (CTime -> Int64) -> CTime -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
compilerStatus
    , compilerCacheGhcPkgPath :: String
compilerCacheGhcPkgPath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
pkgexe
    , compilerCacheRunghcPath :: String
compilerCacheRunghcPath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
cpInterpreter
    , compilerCacheHaddockPath :: String
compilerCacheHaddockPath = Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
cpHaddock
    , compilerCacheCabalVersion :: Text
compilerCacheCabalVersion = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
cpCabalVersion
    , compilerCacheGlobalDb :: String
compilerCacheGlobalDb = Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
cpGlobalDB
    , compilerCacheGlobalDbCacheSize :: Int64
compilerCacheGlobalDbCacheSize = COff -> Int64
sizeToInt64 (COff -> Int64) -> COff -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
globalDbStatus
    , compilerCacheGlobalDbCacheModified :: Int64
compilerCacheGlobalDbCacheModified =
        CTime -> Int64
timeToInt64 (CTime -> Int64) -> CTime -> Int64
forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
globalDbStatus
    , compilerCacheInfo :: ByteString
compilerCacheInfo = ByteString
cpGhcInfo
    , compilerCacheGlobalDump :: Text
compilerCacheGlobalDump = Map PackageName DumpPackage -> Text
forall a. Show a => a -> Text
tshow Map PackageName DumpPackage
cpGlobalDump
    , compilerCacheArch :: Text
compilerCacheArch = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Arch -> String
forall a. Pretty a => a -> String
Distribution.Text.display Arch
cpArch
    }

-- | How many upgrade checks have occurred since the given timestamp?

upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int
upgradeChecksSince :: forall env. HasConfig env => UTCTime -> RIO env Int
upgradeChecksSince UTCTime
since = ReaderT SqlBackend (RIO env) Int -> RIO env Int
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) Int -> RIO env Int)
-> ReaderT SqlBackend (RIO env) Int -> RIO env Int
forall a b. (a -> b) -> a -> b
$ [Filter LastPerformed] -> ReaderT SqlBackend (RIO env) Int
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
forall (m :: * -> *) record.
(MonadIO m, PersistRecordBackend record SqlBackend) =>
[Filter record] -> ReaderT SqlBackend m Int
count
  [ EntityField LastPerformed Action
forall typ. (typ ~ Action) => EntityField LastPerformed typ
LastPerformedAction EntityField LastPerformed Action -> Action -> Filter LastPerformed
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Action
UpgradeCheck
  , EntityField LastPerformed UTCTime
forall typ. (typ ~ UTCTime) => EntityField LastPerformed typ
LastPerformedTimestamp EntityField LastPerformed UTCTime
-> UTCTime -> Filter LastPerformed
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
>=. UTCTime
since
  ]

-- | Log in the database that an upgrade check occurred at the given time.

logUpgradeCheck :: HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck :: forall env. HasConfig env => UTCTime -> RIO env ()
logUpgradeCheck UTCTime
time = ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ReaderT SqlBackend (RIO env) (Entity LastPerformed)
-> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT SqlBackend (RIO env) (Entity LastPerformed)
 -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) (Entity LastPerformed)
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ LastPerformed
-> [Update LastPerformed]
-> ReaderT SqlBackend (RIO env) (Entity LastPerformed)
forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, OnlyOneUniqueKey record,
 SafeToInsert record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 OnlyOneUniqueKey record, SafeToInsert record) =>
record -> [Update record] -> ReaderT SqlBackend m (Entity record)
upsert
  (Action -> UTCTime -> LastPerformed
LastPerformed Action
UpgradeCheck UTCTime
time)
  [EntityField LastPerformed UTCTime
forall typ. (typ ~ UTCTime) => EntityField LastPerformed typ
LastPerformedTimestamp EntityField LastPerformed UTCTime
-> UTCTime -> Update LastPerformed
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
time]