module Stack.Docker.GlobalDB
(updateDockerImageLastUsed
,getDockerImagesLastUsed
,pruneDockerImagesLastUsed
,DockerImageLastUsed
,DockerImageProjectId
,getDockerImageExe
,setDockerImageExe
,DockerImageExeId)
where
import Control.Exception (IOException,catch,throwIO)
import Control.Monad (forM_, when)
import Control.Monad.Logger (NoLoggingT)
import Control.Monad.Trans.Resource (ResourceT)
import Data.List (sortBy, isInfixOf, stripPrefix)
import Data.List.Extra (stripSuffix)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
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 (toFilePath, parent)
import Path.IO (ensureDir)
import Stack.Types.Config
import Stack.Types.Docker
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 =
do imageProjects <- withGlobalDB config (selectList [] [Asc DockerImageProjectLastUsedTime])
return (sortBy (flip sortImage)
(Map.toDescList (Map.fromListWith (++)
(map mapImageProject imageProjects))))
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 $ do
mentity <- getBy (DockerImageExeUnique imageId exePath exeTimestamp)
return (fmap (dockerImageExeCompatible . entityVal) mentity)
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)
ensureDir (parent db)
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 fail $ str' ++
" This likely indicates that your DB file, " ++
toFilePath db ++ ", has incorrect permissions or ownership."
else throwIO (ex :: IOException)
type DockerImageLastUsed = (String, [(UTCTime, FilePath)])