1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DerivingStrategies #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE NoImplicitPrelude #-}
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE QuasiQuotes #-}
10{-# LANGUAGE RecordWildCards #-}
11{-# LANGUAGE StandaloneDeriving #-}
12{-# LANGUAGE TemplateHaskell #-}
13{-# LANGUAGE TupleSections #-}
14{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE UndecidableInstances #-}
16{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-identities #-}
17
18-- | Work with SQLite database used for caches across an entire user account.
19module Stack.Storage.User
20    ( initUserStorage
21    , PrecompiledCacheKey
22    , precompiledCacheKey
23    , loadPrecompiledCache
24    , savePrecompiledCache
25    , loadDockerImageExeCache
26    , saveDockerImageExeCache
27    , loadCompilerPaths
28    , saveCompilerPaths
29    , upgradeChecksSince
30    , logUpgradeCheck
31    ) where
32
33import qualified Data.Set as Set
34import qualified Data.Text as T
35import Data.Time.Clock (UTCTime)
36import Database.Persist.Sqlite
37import Database.Persist.TH
38import Distribution.Text (simpleParse, display)
39import Foreign.C.Types (CTime (..))
40import qualified Pantry.Internal as SQLite
41import Path
42import Path.IO (resolveFile', resolveDir')
43import qualified RIO.FilePath as FP
44import Stack.Prelude hiding (MigrationFailure)
45import Stack.Storage.Util
46import Stack.Types.Build
47import Stack.Types.Cache
48import Stack.Types.Compiler
49import Stack.Types.CompilerBuild (CompilerBuild)
50import Stack.Types.Config (HasConfig, configL, configUserStorage, CompilerPaths (..), GhcPkgExe (..), UserStorage (..))
51import System.Posix.Types (COff (..))
52import System.PosixCompat.Files (getFileStatus, fileSize, modificationTime)
53
54share [ mkPersist sqlSettings
55      , mkDeleteCascade sqlSettings
56      , mkMigrate "migrateAll"
57    ]
58    [persistLowerCase|
59PrecompiledCacheParent sql="precompiled_cache"
60  platformGhcDir FilePath "default=(hex(randomblob(16)))"
61  compiler Text
62  cabalVersion Text
63  packageKey Text
64  optionsHash ByteString
65  haddock Bool default=0
66  library FilePath Maybe
67  UniquePrecompiledCacheParent platformGhcDir compiler cabalVersion packageKey optionsHash haddock sql="unique_precompiled_cache"
68  deriving Show
69
70PrecompiledCacheSubLib
71  parent PrecompiledCacheParentId sql="precompiled_cache_id"
72  value FilePath sql="sub_lib"
73  UniquePrecompiledCacheSubLib parent value
74  deriving Show
75
76PrecompiledCacheExe
77  parent PrecompiledCacheParentId sql="precompiled_cache_id"
78  value FilePath sql="exe"
79  UniquePrecompiledCacheExe parent value
80  deriving Show
81
82DockerImageExeCache
83  imageHash Text
84  exePath FilePath
85  exeTimestamp UTCTime
86  compatible Bool
87  DockerImageExeCacheUnique imageHash exePath exeTimestamp
88  deriving Show
89
90CompilerCache
91  actualVersion ActualCompiler
92  arch Text
93
94  -- Include ghc executable size and modified time for sanity checking entries
95  ghcPath FilePath
96  ghcSize Int64
97  ghcModified Int64
98
99  ghcPkgPath FilePath
100  runghcPath FilePath
101  haddockPath FilePath
102
103  cabalVersion Text
104  globalDb FilePath
105  globalDbCacheSize Int64
106  globalDbCacheModified Int64
107  info ByteString
108
109  -- This is the ugliest part of this table, simply storing a Show/Read version of the
110  -- data. We could do a better job with normalized data and proper table structure.
111  -- However, recomputing this value in the future if the data representation changes
112  -- is very cheap, so we'll take the easy way out for now.
113  globalDump Text
114
115  UniqueCompilerInfo ghcPath
116
117-- Last time certain actions were performed
118LastPerformed
119  action Action
120  timestamp UTCTime
121  UniqueAction action
122|]
123
124-- | Initialize the database.
125initUserStorage ::
126       HasLogFunc env
127    => Path Abs File -- ^ storage file
128    -> (UserStorage -> RIO env a)
129    -> RIO env a
130initUserStorage fp f = SQLite.initStorage "Stack" migrateAll fp $ f . UserStorage
131
132-- | Run an action in a database transaction
133withUserStorage ::
134       (HasConfig env, HasLogFunc env)
135    => ReaderT SqlBackend (RIO env) a
136    -> RIO env a
137withUserStorage inner = do
138    storage <- view (configL . to configUserStorage . to unUserStorage)
139    SQLite.withStorage_ storage inner
140
141-- | Key used to retrieve the precompiled cache
142type PrecompiledCacheKey = Unique PrecompiledCacheParent
143
144-- | Build key used to retrieve the precompiled cache
145precompiledCacheKey ::
146       Path Rel Dir
147    -> ActualCompiler
148    -> Version
149    -> Text
150    -> ByteString
151    -> Bool
152    -> PrecompiledCacheKey
153precompiledCacheKey platformGhcDir compiler cabalVersion =
154    UniquePrecompiledCacheParent
155        (toFilePath platformGhcDir)
156        (compilerVersionText compiler)
157        (T.pack $ versionString cabalVersion)
158
159-- | Internal helper to read the 'PrecompiledCache' from the database
160readPrecompiledCache ::
161       (HasConfig env, HasLogFunc env)
162    => PrecompiledCacheKey
163    -> ReaderT SqlBackend (RIO env) (Maybe ( PrecompiledCacheParentId
164                                           , PrecompiledCache Rel))
165readPrecompiledCache key = do
166    mparent <- getBy key
167    forM mparent $ \(Entity parentId PrecompiledCacheParent {..}) -> do
168        pcLibrary <- mapM parseRelFile precompiledCacheParentLibrary
169        pcSubLibs <-
170            mapM (parseRelFile . precompiledCacheSubLibValue . entityVal) =<<
171            selectList [PrecompiledCacheSubLibParent ==. parentId] []
172        pcExes <-
173            mapM (parseRelFile . precompiledCacheExeValue . entityVal) =<<
174            selectList [PrecompiledCacheExeParent ==. parentId] []
175        return (parentId, PrecompiledCache {..})
176
177-- | Load 'PrecompiledCache' from the database.
178loadPrecompiledCache ::
179       (HasConfig env, HasLogFunc env)
180    => PrecompiledCacheKey
181    -> RIO env (Maybe (PrecompiledCache Rel))
182loadPrecompiledCache key = withUserStorage $ fmap snd <$> readPrecompiledCache key
183
184-- | Insert or update 'PrecompiledCache' to the database.
185savePrecompiledCache ::
186       (HasConfig env, HasLogFunc env)
187    => PrecompiledCacheKey
188    -> PrecompiledCache Rel
189    -> RIO env ()
190savePrecompiledCache key@(UniquePrecompiledCacheParent precompiledCacheParentPlatformGhcDir precompiledCacheParentCompiler precompiledCacheParentCabalVersion precompiledCacheParentPackageKey precompiledCacheParentOptionsHash precompiledCacheParentHaddock) new =
191    withUserStorage $ do
192        let precompiledCacheParentLibrary = fmap toFilePath (pcLibrary new)
193        mIdOld <- readPrecompiledCache key
194        (parentId, mold) <-
195            case mIdOld of
196                Nothing -> (, Nothing) <$> insert PrecompiledCacheParent {..}
197                Just (parentId, old) -> do
198                    update
199                        parentId
200                        [ PrecompiledCacheParentLibrary =.
201                          precompiledCacheParentLibrary
202                        ]
203                    return (parentId, Just old)
204        updateSet
205            PrecompiledCacheSubLib
206            PrecompiledCacheSubLibParent
207            parentId
208            PrecompiledCacheSubLibValue
209            (maybe Set.empty (toFilePathSet . pcSubLibs) mold)
210            (toFilePathSet $ pcSubLibs new)
211        updateSet
212            PrecompiledCacheExe
213            PrecompiledCacheExeParent
214            parentId
215            PrecompiledCacheExeValue
216            (maybe Set.empty (toFilePathSet . pcExes) mold)
217            (toFilePathSet $ pcExes new)
218  where
219    toFilePathSet = Set.fromList . map toFilePath
220
221-- | Get the record of whether an executable is compatible with a Docker image
222loadDockerImageExeCache ::
223       (HasConfig env, HasLogFunc env)
224    => Text
225    -> Path Abs File
226    -> UTCTime
227    -> RIO env (Maybe Bool)
228loadDockerImageExeCache imageId exePath exeTimestamp =
229    withUserStorage $
230    fmap (dockerImageExeCacheCompatible . entityVal) <$>
231    getBy (DockerImageExeCacheUnique imageId (toFilePath exePath) exeTimestamp)
232
233-- | Sest the record of whether an executable is compatible with a Docker image
234saveDockerImageExeCache ::
235       (HasConfig env, HasLogFunc env)
236    => Text
237    -> Path Abs File
238    -> UTCTime
239    -> Bool
240    -> RIO env ()
241saveDockerImageExeCache imageId exePath exeTimestamp compatible =
242    void $
243    withUserStorage $
244    upsert
245        (DockerImageExeCache
246             imageId
247             (toFilePath exePath)
248             exeTimestamp
249             compatible)
250        []
251
252-- | Type-restricted version of 'fromIntegral' to ensure we're making
253-- the value bigger, not smaller.
254sizeToInt64 :: COff -> Int64
255sizeToInt64 (COff i) = fromIntegral i -- fromIntegral added for 32-bit systems
256
257-- | Type-restricted version of 'fromIntegral' to ensure we're making
258-- the value bigger, not smaller.
259timeToInt64 :: CTime -> Int64
260timeToInt64 (CTime i) = fromIntegral i -- fromIntegral added for 32-bit systems
261
262-- | Load compiler information, if available, and confirm that the
263-- referenced files are unchanged. May throw exceptions!
264loadCompilerPaths
265  :: HasConfig env
266  => Path Abs File -- ^ compiler executable
267  -> CompilerBuild
268  -> Bool -- ^ sandboxed?
269  -> RIO env (Maybe CompilerPaths)
270loadCompilerPaths compiler build sandboxed = do
271  mres <- withUserStorage $ getBy $ UniqueCompilerInfo $ toFilePath compiler
272  for mres $ \(Entity _ CompilerCache {..}) -> do
273    compilerStatus <- liftIO $ getFileStatus $ toFilePath compiler
274    when
275      (compilerCacheGhcSize /= sizeToInt64 (fileSize compilerStatus) ||
276       compilerCacheGhcModified /= timeToInt64 (modificationTime compilerStatus))
277      (throwString "Compiler file metadata mismatch, ignoring cache")
278    globalDbStatus <- liftIO $ getFileStatus $ compilerCacheGlobalDb FP.</> "package.cache"
279    when
280      (compilerCacheGlobalDbCacheSize /= sizeToInt64 (fileSize globalDbStatus) ||
281       compilerCacheGlobalDbCacheModified /= timeToInt64 (modificationTime globalDbStatus))
282      (throwString "Global package cache file metadata mismatch, ignoring cache")
283
284    -- We could use parseAbsFile instead of resolveFile' below to
285    -- bypass some system calls, at the cost of some really wonky
286    -- error messages in case someone screws up their GHC installation
287    pkgexe <- resolveFile' compilerCacheGhcPkgPath
288    runghc <- resolveFile' compilerCacheRunghcPath
289    haddock <- resolveFile' compilerCacheHaddockPath
290    globaldb <- resolveDir' compilerCacheGlobalDb
291
292    cabalVersion <- parseVersionThrowing $ T.unpack compilerCacheCabalVersion
293    globalDump <-
294      case readMaybe $ T.unpack compilerCacheGlobalDump of
295        Nothing -> throwString "Global dump did not parse correctly"
296        Just globalDump -> pure globalDump
297    arch <-
298      case simpleParse $ T.unpack compilerCacheArch of
299        Nothing -> throwString $ "Invalid arch: " ++ show compilerCacheArch
300        Just arch -> pure arch
301
302    pure CompilerPaths
303      { cpCompiler = compiler
304      , cpCompilerVersion = compilerCacheActualVersion
305      , cpArch = arch
306      , cpBuild = build
307      , cpPkg = GhcPkgExe pkgexe
308      , cpInterpreter = runghc
309      , cpHaddock = haddock
310      , cpSandboxed = sandboxed
311      , cpCabalVersion = cabalVersion
312      , cpGlobalDB = globaldb
313      , cpGhcInfo = compilerCacheInfo
314      , cpGlobalDump = globalDump
315      }
316
317-- | Save compiler information. May throw exceptions!
318saveCompilerPaths
319  :: HasConfig env
320  => CompilerPaths
321  -> RIO env ()
322saveCompilerPaths CompilerPaths {..} = withUserStorage $ do
323  deleteBy $ UniqueCompilerInfo $ toFilePath cpCompiler
324  compilerStatus <- liftIO $ getFileStatus $ toFilePath cpCompiler
325  globalDbStatus <- liftIO $ getFileStatus $ toFilePath $ cpGlobalDB </> $(mkRelFile "package.cache")
326  let GhcPkgExe pkgexe = cpPkg
327  insert_ CompilerCache
328    { compilerCacheActualVersion = cpCompilerVersion
329    , compilerCacheGhcPath = toFilePath cpCompiler
330    , compilerCacheGhcSize = sizeToInt64 $ fileSize compilerStatus
331    , compilerCacheGhcModified = timeToInt64 $ modificationTime compilerStatus
332    , compilerCacheGhcPkgPath = toFilePath pkgexe
333    , compilerCacheRunghcPath = toFilePath cpInterpreter
334    , compilerCacheHaddockPath = toFilePath cpHaddock
335    , compilerCacheCabalVersion = T.pack $ versionString cpCabalVersion
336    , compilerCacheGlobalDb = toFilePath cpGlobalDB
337    , compilerCacheGlobalDbCacheSize = sizeToInt64 $ fileSize globalDbStatus
338    , compilerCacheGlobalDbCacheModified = timeToInt64 $ modificationTime globalDbStatus
339    , compilerCacheInfo = cpGhcInfo
340    , compilerCacheGlobalDump = tshow cpGlobalDump
341    , compilerCacheArch = T.pack $ Distribution.Text.display cpArch
342    }
343
344-- | How many upgrade checks have occurred since the given timestamp?
345upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int
346upgradeChecksSince since = withUserStorage $ count
347  [ LastPerformedAction ==. UpgradeCheck
348  , LastPerformedTimestamp >=. since
349  ]
350
351-- | Log in the database that an upgrade check occurred at the given time.
352logUpgradeCheck :: HasConfig env => UTCTime -> RIO env ()
353logUpgradeCheck time = withUserStorage $ void $ upsert
354  (LastPerformed UpgradeCheck time)
355  [LastPerformedTimestamp =. time]
356