GlobalDB.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings,
             GADTs, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving,
             RankNTypes, NamedFieldPuns #-}

-- | Global sqlite database shared by all projects.
-- Warning: this is currently only accessible from __outside__ a Docker container.
module Stack.Docker.GlobalDB
  (updateDockerImageLastUsed
  ,getDockerImagesLastUsed
  ,pruneDockerImagesLastUsed
  ,DockerImageLastUsed
  ,DockerImageProjectId
  ,getDockerImageExe
  ,setDockerImageExe
  ,DockerImageExeId)
  where

import           Control.Monad.Logger (NoLoggingT)
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
|]

-- | Update last used time and project for a Docker image hash.
updateDockerImageLastUsed :: Config -> String -> FilePath -> IO ()
updateDockerImageLastUsed config imageId projectPath =
  do curTime <- getCurrentTime
     _ <- withGlobalDB config (upsert (DockerImageProject imageId projectPath curTime) [])
     return ()

-- | Get a list of Docker image hashes and when they were last used.
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

-- | Given a list of all existing Docker images, remove any that no longer exist from
-- the database.
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)

-- | Get the record of whether an executable is compatible with a Docker image
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)

-- | Seet the record of whether an executable is compatible with a Docker image
setDockerImageExe :: Config -> String -> FilePath -> UTCTime -> Bool -> IO ()
setDockerImageExe config imageId exePath exeTimestamp compatible =
    withGlobalDB config $
    do _ <- upsert (DockerImageExe imageId exePath exeTimestamp compatible) []
       return ()

-- | Run an action with the global database.  This performs any needed migrations as well.
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)

-- | Date and project path where Docker image hash last used.
type DockerImageLastUsed = (String, [(UTCTime, FilePath)])