85 lines
2.4 KiB
Haskell
85 lines
2.4 KiB
Haskell
{- Sqlite database used for exports to special remotes.
|
|
-
|
|
- Copyright 2017 Joey Hess <id@joeyh.name>
|
|
-:
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
|
|
{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
module Database.Export (
|
|
ExportHandle,
|
|
openDb,
|
|
closeDb,
|
|
addExportLocation,
|
|
removeExportLocation,
|
|
getExportLocation,
|
|
ExportedId,
|
|
) where
|
|
|
|
import Database.Types
|
|
import qualified Database.Queue as H
|
|
import Database.Init
|
|
import Annex.Locations
|
|
import Annex.Common hiding (delete)
|
|
import Types.Remote (ExportLocation(..))
|
|
|
|
import Database.Persist.TH
|
|
import Database.Esqueleto hiding (Key)
|
|
|
|
newtype ExportHandle = ExportHandle H.DbQueue
|
|
|
|
share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|
|
|
Exported
|
|
key IKey
|
|
file SFilePath
|
|
KeyFileIndex key file
|
|
UniqueKey key
|
|
|]
|
|
|
|
{- Opens the database, creating it if it doesn't exist yet. -}
|
|
openDb :: UUID -> Annex ExportHandle
|
|
openDb u = do
|
|
dbdir <- fromRepo (gitAnnexExportDbDir u)
|
|
let db = dbdir </> "db"
|
|
unlessM (liftIO $ doesFileExist db) $ do
|
|
initDb db $ void $
|
|
runMigrationSilent migrateExport
|
|
h <- liftIO $ H.openDbQueue db "exported"
|
|
return $ ExportHandle h
|
|
|
|
closeDb :: ExportHandle -> Annex ()
|
|
closeDb (ExportHandle h) = liftIO $ H.closeDbQueue h
|
|
|
|
queueDb :: ExportHandle -> SqlPersistM () -> IO ()
|
|
queueDb (ExportHandle h) = H.queueDb h checkcommit
|
|
where
|
|
-- commit queue after 1000 changes
|
|
checkcommit sz _lastcommittime
|
|
| sz > 1000 = return True
|
|
| otherwise = return False
|
|
|
|
addExportLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
|
|
addExportLocation h k (ExportLocation f) = queueDb h $
|
|
void $ insertUnique $ Exported (toIKey k) (toSFilePath f)
|
|
|
|
removeExportLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
|
|
removeExportLocation h k (ExportLocation f) = queueDb h $
|
|
delete $ from $ \r -> do
|
|
where_ (r ^. ExportedKey ==. val ik &&. r ^. ExportedFile ==. val ef)
|
|
where
|
|
ik = toIKey k
|
|
ef = toSFilePath f
|
|
|
|
{- Doesn't know about recently queued changes. -}
|
|
getExportLocation :: ExportHandle -> Key -> IO [ExportLocation]
|
|
getExportLocation (ExportHandle h) k = H.queryDbQueue h $ do
|
|
l <- select $ from $ \r -> do
|
|
where_ (r ^. ExportedKey ==. val ik)
|
|
return (r ^. ExportedFile)
|
|
return $ map (ExportLocation . fromSFilePath . unValue) l
|
|
where
|
|
ik = toIKey k
|