{-# 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 qualified Pantry.Internal as SQLite
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StorageUserException] -> ShowS
$cshowList :: [StorageUserException] -> ShowS
show :: StorageUserException -> String
$cshow :: StorageUserException -> String
showsPrec :: Int -> StorageUserException -> ShowS
$cshowsPrec :: Int -> StorageUserException -> ShowS
Show, Typeable)

instance Exception StorageUserException where
  displayException :: StorageUserException -> String
displayException StorageUserException
CompilerFileMetadataMismatch =
    String
"Error: [S-8196]\n"
    forall a. [a] -> [a] -> [a]
++ String
"Compiler file metadata mismatch, ignoring cache."
  displayException StorageUserException
GlobalPackageCacheFileMetadataMismatch =
    String
"Error: [S-5378]\n"
    forall a. [a] -> [a] -> [a]
++ String
"Global package cache file metadata mismatch, ignoring cache."
  displayException StorageUserException
GlobalDumpParseFailure =
    String
"Error: [S-2673]\n"
    forall a. [a] -> [a] -> [a]
++ String
"Global dump did not parse correctly."
  displayException
    (CompilerCacheArchitectureInvalid Text
compilerCacheArch) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"Error: [S-8441]\n"
      , String
"Invalid arch: "
      , 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 = forall env a. HasLogFunc env => RIO env a -> RIO env a
handleMigrationException forall a b. (a -> b) -> a -> b
$
  forall env a.
HasLogFunc env =>
Text
-> Migration
-> Path Abs File
-> (Storage -> RIO env a)
-> RIO env a
SQLite.initStorage Text
"Stack" Migration
migrateAll Path Abs File
fp forall a b. (a -> b) -> a -> b
$ UserStorage -> RIO env a
f 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall env. HasConfig env => Lens' env Config
configL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Config -> UserStorage
configUserStorage forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
SQLite.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
    (forall b t. Path b t -> String
toFilePath Path Rel Dir
platformGhcDir)
    (ActualCompiler -> Text
compilerVersionText ActualCompiler
compiler)
    (String -> Text
T.pack 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 <- forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy Unique PrecompiledCacheParent
key
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (Entity PrecompiledCacheParent)
mparent forall a b. (a -> b) -> a -> b
$ \(Entity Key PrecompiledCacheParent
parentId PrecompiledCacheParent {Bool
String
Maybe String
ByteString
Text
precompiledCacheParentLibrary :: Maybe String
precompiledCacheParentHaddock :: Bool
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentPackageKey :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentCompiler :: Text
precompiledCacheParentPlatformGhcDir :: String
precompiledCacheParentLibrary :: PrecompiledCacheParent -> Maybe String
precompiledCacheParentHaddock :: PrecompiledCacheParent -> Bool
precompiledCacheParentOptionsHash :: PrecompiledCacheParent -> ByteString
precompiledCacheParentPackageKey :: PrecompiledCacheParent -> Text
precompiledCacheParentCabalVersion :: PrecompiledCacheParent -> Text
precompiledCacheParentCompiler :: PrecompiledCacheParent -> Text
precompiledCacheParentPlatformGhcDir :: PrecompiledCacheParent -> String
..}) -> do
    Maybe (Path Rel File)
pcLibrary <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile Maybe String
precompiledCacheParentLibrary
    [Path Rel File]
pcSubLibs <-
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCacheSubLib -> String
precompiledCacheSubLibValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibParent forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PrecompiledCacheParent
parentId] []
    [Path Rel File]
pcExes <-
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrecompiledCacheExe -> String
precompiledCacheExeValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList [forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheExe typ
PrecompiledCacheExeParent forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Key PrecompiledCacheParent
parentId] []
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key PrecompiledCacheParent
parentId, PrecompiledCache {[Path Rel File]
Maybe (Path Rel File)
pcExes :: [Path Rel File]
pcSubLibs :: [Path Rel File]
pcLibrary :: Maybe (Path Rel File)
pcExes :: [Path Rel File]
pcSubLibs :: [Path Rel File]
pcLibrary :: Maybe (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 =
  forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  = forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ do
      let precompiledCacheParentLibrary :: Maybe String
precompiledCacheParentLibrary = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b t. Path b t -> String
toFilePath (forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary PrecompiledCache Rel
new)
      Maybe (Key PrecompiledCacheParent, PrecompiledCache Rel)
mIdOld <- 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 -> (, forall a. Maybe a
Nothing) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert PrecompiledCacheParent {Bool
String
Maybe String
ByteString
Text
precompiledCacheParentLibrary :: Maybe String
precompiledCacheParentHaddock :: Bool
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentPackageKey :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentCompiler :: Text
precompiledCacheParentPlatformGhcDir :: String
precompiledCacheParentLibrary :: Maybe String
precompiledCacheParentHaddock :: Bool
precompiledCacheParentOptionsHash :: ByteString
precompiledCacheParentPackageKey :: Text
precompiledCacheParentCabalVersion :: Text
precompiledCacheParentCompiler :: Text
precompiledCacheParentPlatformGhcDir :: String
..}
          Just (Key PrecompiledCacheParent
parentId, PrecompiledCache Rel
old) -> do
            forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update
              Key PrecompiledCacheParent
parentId
              [ forall typ.
(typ ~ Maybe String) =>
EntityField PrecompiledCacheParent typ
PrecompiledCacheParentLibrary forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.
                Maybe String
precompiledCacheParentLibrary
              ]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key PrecompiledCacheParent
parentId, forall a. a -> Maybe a
Just PrecompiledCache Rel
old)
      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
        forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibParent
        Key PrecompiledCacheParent
parentId
        forall typ.
(typ ~ String) =>
EntityField PrecompiledCacheSubLib typ
PrecompiledCacheSubLibValue
        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty (forall {b} {t}. [Path b t] -> Set String
toFilePathSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall base. PrecompiledCache base -> [Path base File]
pcSubLibs) Maybe (PrecompiledCache Rel)
mold)
        (forall {b} {t}. [Path b t] -> Set String
toFilePathSet forall a b. (a -> b) -> a -> b
$ forall base. PrecompiledCache base -> [Path base File]
pcSubLibs PrecompiledCache Rel
new)
      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
        forall typ.
(typ ~ Key PrecompiledCacheParent) =>
EntityField PrecompiledCacheExe typ
PrecompiledCacheExeParent
        Key PrecompiledCacheParent
parentId
        forall typ. (typ ~ String) => EntityField PrecompiledCacheExe typ
PrecompiledCacheExeValue
        (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty (forall {b} {t}. [Path b t] -> Set String
toFilePathSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall base. PrecompiledCache base -> [Path base File]
pcExes) Maybe (PrecompiledCache Rel)
mold)
        (forall {b} {t}. [Path b t] -> Set String
toFilePathSet forall a b. (a -> b) -> a -> b
$ forall base. PrecompiledCache base -> [Path base File]
pcExes PrecompiledCache Rel
new)
 where
  toFilePathSet :: [Path b t] -> Set String
toFilePathSet = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map 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 = forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DockerImageExeCache -> Bool
dockerImageExeCacheCompatible forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall record. Entity record -> record
entityVal) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy (Text -> String -> UTCTime -> Unique DockerImageExeCache
DockerImageExeCacheUnique Text
imageId (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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
  forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$
    forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, OnlyOneUniqueKey record,
 SafeToInsert record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
upsert
      ( Text -> String -> UTCTime -> Bool -> DockerImageExeCache
DockerImageExeCache
          Text
imageId
          (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) = 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) = 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 <- forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy forall a b. (a -> b) -> a -> b
$ String -> Unique CompilerCache
UniqueCompilerInfo forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
compiler
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (Entity CompilerCache)
mres forall a b. (a -> b) -> a -> b
$ \(Entity Key CompilerCache
_ CompilerCache {Int64
String
ByteString
Text
ActualCompiler
compilerCacheGlobalDump :: Text
compilerCacheInfo :: ByteString
compilerCacheGlobalDbCacheModified :: Int64
compilerCacheGlobalDbCacheSize :: Int64
compilerCacheGlobalDb :: String
compilerCacheCabalVersion :: Text
compilerCacheHaddockPath :: String
compilerCacheRunghcPath :: String
compilerCacheGhcPkgPath :: String
compilerCacheGhcModified :: Int64
compilerCacheGhcSize :: Int64
compilerCacheGhcPath :: String
compilerCacheArch :: Text
compilerCacheActualVersion :: ActualCompiler
compilerCacheGlobalDump :: CompilerCache -> Text
compilerCacheInfo :: CompilerCache -> ByteString
compilerCacheGlobalDbCacheModified :: CompilerCache -> Int64
compilerCacheGlobalDbCacheSize :: CompilerCache -> Int64
compilerCacheGlobalDb :: CompilerCache -> String
compilerCacheCabalVersion :: CompilerCache -> Text
compilerCacheHaddockPath :: CompilerCache -> String
compilerCacheRunghcPath :: CompilerCache -> String
compilerCacheGhcPkgPath :: CompilerCache -> String
compilerCacheGhcModified :: CompilerCache -> Int64
compilerCacheGhcSize :: CompilerCache -> Int64
compilerCacheGhcPath :: CompilerCache -> String
compilerCacheArch :: CompilerCache -> Text
compilerCacheActualVersion :: CompilerCache -> ActualCompiler
..}) -> do
    FileStatus
compilerStatus <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
compiler
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (  Int64
compilerCacheGhcSize forall a. Eq a => a -> a -> Bool
/= COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
compilerStatus)
      Bool -> Bool -> Bool
|| Int64
compilerCacheGhcModified forall a. Eq a => a -> a -> Bool
/=
           CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
compilerStatus)
      )
      (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StorageUserException
CompilerFileMetadataMismatch)
    FileStatus
globalDbStatus <-
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus forall a b. (a -> b) -> a -> b
$ String
compilerCacheGlobalDb String -> ShowS
FP.</> String
"package.cache"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
      (  Int64
compilerCacheGlobalDbCacheSize forall a. Eq a => a -> a -> Bool
/= COff -> Int64
sizeToInt64 (FileStatus -> COff
fileSize FileStatus
globalDbStatus)
      Bool -> Bool -> Bool
|| Int64
compilerCacheGlobalDbCacheModified forall a. Eq a => a -> a -> Bool
/=
           CTime -> Int64
timeToInt64 (FileStatus -> CTime
modificationTime FileStatus
globalDbStatus)
      )
      (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 <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
compilerCacheGhcPkgPath
    Path Abs File
runghc <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
compilerCacheRunghcPath
    Path Abs File
haddock <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
compilerCacheHaddockPath
    Path Abs Dir
globaldb <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
compilerCacheGlobalDb

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

    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
Arch
Map PackageName DumpPackage
Version
ByteString
Path Abs File
Path Abs Dir
CompilerBuild
ActualCompiler
GhcPkgExe
cpGlobalDump :: Map PackageName DumpPackage
cpGhcInfo :: ByteString
cpGlobalDB :: Path Abs Dir
cpCabalVersion :: Version
cpSandboxed :: Bool
cpHaddock :: Path Abs File
cpInterpreter :: Path Abs File
cpPkg :: GhcPkgExe
cpCompiler :: Path Abs File
cpBuild :: CompilerBuild
cpArch :: Arch
cpCompilerVersion :: ActualCompiler
cpGlobalDump :: CompilerPaths -> Map PackageName DumpPackage
cpGhcInfo :: CompilerPaths -> ByteString
cpGlobalDB :: CompilerPaths -> Path Abs Dir
cpCabalVersion :: CompilerPaths -> Version
cpSandboxed :: CompilerPaths -> Bool
cpHaddock :: CompilerPaths -> Path Abs File
cpInterpreter :: CompilerPaths -> Path Abs File
cpPkg :: CompilerPaths -> GhcPkgExe
cpBuild :: CompilerPaths -> CompilerBuild
cpArch :: CompilerPaths -> Arch
cpCompilerVersion :: CompilerPaths -> ActualCompiler
cpCompiler :: CompilerPaths -> Path Abs File
..} = forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ do
  forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m ()
deleteBy forall a b. (a -> b) -> a -> b
$ String -> Unique CompilerCache
UniqueCompilerInfo forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
cpCompiler
  FileStatus
compilerStatus <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO FileStatus
getFileStatus forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
cpCompiler
  FileStatus
globalDbStatus <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      String -> IO FileStatus
getFileStatus forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ Path Abs Dir
cpGlobalDB forall b t. Path b Dir -> Path Rel t -> Path b t
</> $(mkRelFile "package.cache")
  let GhcPkgExe Path Abs File
pkgexe = GhcPkgExe
cpPkg
  forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m ()
insert_ CompilerCache
    { compilerCacheActualVersion :: ActualCompiler
compilerCacheActualVersion = ActualCompiler
cpCompilerVersion
    , compilerCacheGhcPath :: String
compilerCacheGhcPath = forall b t. Path b t -> String
toFilePath Path Abs File
cpCompiler
    , compilerCacheGhcSize :: Int64
compilerCacheGhcSize = COff -> Int64
sizeToInt64 forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
compilerStatus
    , compilerCacheGhcModified :: Int64
compilerCacheGhcModified = CTime -> Int64
timeToInt64 forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
compilerStatus
    , compilerCacheGhcPkgPath :: String
compilerCacheGhcPkgPath = forall b t. Path b t -> String
toFilePath Path Abs File
pkgexe
    , compilerCacheRunghcPath :: String
compilerCacheRunghcPath = forall b t. Path b t -> String
toFilePath Path Abs File
cpInterpreter
    , compilerCacheHaddockPath :: String
compilerCacheHaddockPath = forall b t. Path b t -> String
toFilePath Path Abs File
cpHaddock
    , compilerCacheCabalVersion :: Text
compilerCacheCabalVersion = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
cpCabalVersion
    , compilerCacheGlobalDb :: String
compilerCacheGlobalDb = forall b t. Path b t -> String
toFilePath Path Abs Dir
cpGlobalDB
    , compilerCacheGlobalDbCacheSize :: Int64
compilerCacheGlobalDbCacheSize = COff -> Int64
sizeToInt64 forall a b. (a -> b) -> a -> b
$ FileStatus -> COff
fileSize FileStatus
globalDbStatus
    , compilerCacheGlobalDbCacheModified :: Int64
compilerCacheGlobalDbCacheModified =
        CTime -> Int64
timeToInt64 forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime FileStatus
globalDbStatus
    , compilerCacheInfo :: ByteString
compilerCacheInfo = ByteString
cpGhcInfo
    , compilerCacheGlobalDump :: Text
compilerCacheGlobalDump = forall a. Show a => a -> Text
tshow Map PackageName DumpPackage
cpGlobalDump
    , compilerCacheArch :: Text
compilerCacheArch = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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 = forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
count
  [ forall typ. (typ ~ Action) => EntityField LastPerformed typ
LastPerformedAction forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Action
UpgradeCheck
  , forall typ. (typ ~ UTCTime) => EntityField LastPerformed typ
LastPerformedTimestamp 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 = forall env a.
(HasConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withUserStorage forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend, OnlyOneUniqueKey record,
 SafeToInsert record) =>
record -> [Update record] -> ReaderT backend m (Entity record)
upsert
  (Action -> UTCTime -> LastPerformed
LastPerformed Action
UpgradeCheck UTCTime
time)
  [forall typ. (typ ~ UTCTime) => EntityField LastPerformed typ
LastPerformedTimestamp forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
time]