{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings,
GADTs, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving,
RankNTypes, NamedFieldPuns #-}
module Stack.Docker.GlobalDB
(updateDockerImageLastUsed
,getDockerImagesLastUsed
,pruneDockerImagesLastUsed
,DockerImageLastUsed
,DockerImageProjectId
,getDockerImageExe
,setDockerImageExe
,DockerImageExeId)
where
import Control.Monad.Logger (NoLoggingT)
import Control.Monad.Trans.Resource (ResourceT)
import Stack.Prelude
import Data.List (sortBy, isInfixOf, stripPrefix)
import Data.List.Extra (stripSuffix)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Data.Time.Clock (UTCTime,getCurrentTime)
import Database.Persist
import Database.Persist.Sqlite
import Database.Persist.TH
import Path (parent, (<.>))
import Path.IO (ensureDir)
import Stack.Types.Config
import Stack.Types.Docker
import System.FileLock (withFileLock, SharedExclusive(Exclusive))
share [mkPersist sqlSettings, mkMigrate "migrateTables"] [persistLowerCase|
DockerImageProject
imageHash String
projectPath FilePath
lastUsedTime UTCTime
DockerImageProjectPathKey imageHash projectPath
deriving Show
DockerImageExe
imageHash String
exePath FilePath
exeTimestamp UTCTime
compatible Bool
DockerImageExeUnique imageHash exePath exeTimestamp
deriving Show
|]
updateDockerImageLastUsed :: Config -> String -> FilePath -> IO ()
updateDockerImageLastUsed config imageId projectPath =
do curTime <- getCurrentTime
_ <- withGlobalDB config (upsert (DockerImageProject imageId projectPath curTime) [])
return ()
getDockerImagesLastUsed :: Config -> IO [DockerImageLastUsed]
getDockerImagesLastUsed config =
sortBy (flip sortImage)
. Map.toDescList
. Map.fromListWith (++)
. map mapImageProject
<$> withGlobalDB
config
(selectList [] [Asc DockerImageProjectLastUsedTime])
where
mapImageProject (Entity _ imageProject) =
(dockerImageProjectImageHash imageProject
,[(dockerImageProjectLastUsedTime imageProject
,dockerImageProjectProjectPath imageProject)])
sortImage (_,(a,_):_) (_,(b,_):_) = compare a b
sortImage _ _ = EQ
pruneDockerImagesLastUsed :: Config -> [String] -> IO ()
pruneDockerImagesLastUsed config existingHashes =
withGlobalDB config go
where
go = do
l <- selectList [] []
forM_ l (\(Entity k DockerImageProject{dockerImageProjectImageHash = h}) ->
when (h `notElem` existingHashes) $ delete k)
getDockerImageExe :: Config -> String -> FilePath -> UTCTime -> IO (Maybe Bool)
getDockerImageExe config imageId exePath exeTimestamp =
withGlobalDB config $
fmap (dockerImageExeCompatible . entityVal) <$>
getBy (DockerImageExeUnique imageId exePath exeTimestamp)
setDockerImageExe :: Config -> String -> FilePath -> UTCTime -> Bool -> IO ()
setDockerImageExe config imageId exePath exeTimestamp compatible =
withGlobalDB config $
do _ <- upsert (DockerImageExe imageId exePath exeTimestamp compatible) []
return ()
withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a
withGlobalDB config action =
do let db = dockerDatabasePath (configDocker config)
dbLock <- db <.> "lock"
ensureDir (parent db)
withFileLock (toFilePath dbLock) Exclusive (\_fl -> runSqlite (T.pack (toFilePath db))
(do _ <- runMigrationSilent migrateTables
action))
`catch` \ex -> do
let str = show ex
str' = fromMaybe str $ stripPrefix "user error (" $
fromMaybe str $ stripSuffix ")" str
if "ErrorReadOnly" `isInfixOf` str
then throwString $ str' ++
" This likely indicates that your DB file, " ++
toFilePath db ++ ", has incorrect permissions or ownership."
else throwIO (ex :: IOException)
type DockerImageLastUsed = (String, [(UTCTime, FilePath)])