1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
{- Sqlite database of information about Keys
-
- Copyright 2015 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.Keys (
DbHandle,
addAssociatedFile,
getAssociatedFiles,
getAssociatedKey,
removeAssociatedFile,
storeInodeCaches,
addInodeCaches,
getInodeCaches,
removeInodeCaches,
AssociatedId,
ContentId,
) where
import Database.Types
import Database.Keys.Handle
import qualified Database.Queue as H
import Locations
import Common hiding (delete)
import Annex
import Types.Key
import Annex.Perms
import Annex.LockFile
import Utility.InodeCache
import Annex.InodeSentinal
import Database.Persist.TH
import Database.Esqueleto hiding (Key)
import Data.Time.Clock
share [mkPersist sqlSettings, mkMigrate "migrateKeysDb"] [persistLowerCase|
Associated
key SKey
file FilePath
KeyFileIndex key file
Content
key SKey
cache SInodeCache
KeyCacheIndex key cache
|]
newtype ReadHandle = ReadHandle H.DbQueue
type Reader v = ReadHandle -> Annex v
{- Runs an action that reads from the database.
-
- If the database doesn't already exist, it's not created; mempty is
- returned instead. This way, when the keys database is not in use,
- there's minimal overhead in checking it.
-
- If the database is already open, any writes are flushed to it, to ensure
- consistency.
-
- Any queued writes will be flushed before the read.
-}
runReader :: Monoid v => Reader v -> Annex v
runReader a = do
h <- getDbHandle
withDbState h go
where
go DbEmpty = return (mempty, DbEmpty)
go st@(DbOpen qh) = do
liftIO $ H.flushDbQueue qh
v <- a (ReadHandle qh)
return (v, st)
go DbClosed = do
st' <- openDb False DbClosed
v <- case st' of
(DbOpen qh) -> a (ReadHandle qh)
_ -> return mempty
return (v, st')
readDb :: SqlPersistM a -> ReadHandle -> Annex a
readDb a (ReadHandle h) = liftIO $ H.queryDbQueue h a
newtype WriteHandle = WriteHandle H.DbQueue
type Writer = WriteHandle -> Annex ()
{- Runs an action that writes to the database. Typically this is used to
- queue changes, which will be flushed at a later point.
-
- The database is created if it doesn't exist yet. -}
runWriter :: Writer -> Annex ()
runWriter a = do
h <- getDbHandle
withDbState h go
where
go st@(DbOpen qh) = do
v <- a (WriteHandle qh)
return (v, st)
go st = do
st' <- openDb True st
v <- case st' of
DbOpen qh -> a (WriteHandle qh)
_ -> error "internal"
return (v, st')
queueDb :: SqlPersistM () -> WriteHandle -> Annex ()
queueDb a (WriteHandle h) = liftIO $ H.queueDb h checkcommit a
where
-- commit queue after 1000 changes or 5 minutes, whichever comes first
checkcommit sz lastcommittime
| sz > 1000 = return True
| otherwise = do
now <- getCurrentTime
return $ diffUTCTime lastcommittime now > 300
{- Gets the handle cached in Annex state; creates a new one if it's not yet
- available, but doesn't open the database. -}
getDbHandle :: Annex DbHandle
getDbHandle = go =<< getState keysdbhandle
where
go (Just h) = pure h
go Nothing = do
h <- liftIO newDbHandle
changeState $ \s -> s { keysdbhandle = Just h }
return h
{- Opens the database, perhaps creating it if it doesn't exist yet.
-
- Multiple readers and writers can have the database open at the same
- time. Database.Handle deals with the concurrency issues.
- The lock is held while opening the database, so that when
- the database doesn't exist yet, one caller wins the lock and
- can create it undisturbed.
-}
openDb :: Bool -> DbState -> Annex DbState
openDb _ st@(DbOpen _) = return st
openDb False DbEmpty = return DbEmpty
openDb createdb _ = withExclusiveLock gitAnnexKeysDbLock $ do
dbdir <- fromRepo gitAnnexKeysDb
let db = dbdir </> "db"
dbexists <- liftIO $ doesFileExist db
case (dbexists, createdb) of
(True, _) -> open db
(False, True) -> do
liftIO $ do
createDirectoryIfMissing True dbdir
H.initDb db $ void $
runMigrationSilent migrateKeysDb
setAnnexDirPerm dbdir
setAnnexFilePerm db
open db
(False, False) -> return DbEmpty
where
open db = liftIO $ DbOpen <$> H.openDbQueue db "content"
addAssociatedFile :: Key -> FilePath -> Annex ()
addAssociatedFile k f = runWriter $ addAssociatedFile' k f
addAssociatedFile' :: Key -> FilePath -> Writer
addAssociatedFile' k f = queueDb $ do
-- If the same file was associated with a different key before,
-- remove that.
delete $ from $ \r -> do
where_ (r ^. AssociatedFile ==. val f &&. r ^. AssociatedKey ==. val sk)
void $ insertUnique $ Associated sk f
where
sk = toSKey k
{- Note that the files returned were once associated with the key, but
- some of them may not be any longer. -}
getAssociatedFiles :: Key -> Annex [FilePath]
getAssociatedFiles = runReader . getAssociatedFiles' . toSKey
getAssociatedFiles' :: SKey -> Reader [FilePath]
getAssociatedFiles' sk = readDb $ do
l <- select $ from $ \r -> do
where_ (r ^. AssociatedKey ==. val sk)
return (r ^. AssociatedFile)
return $ map unValue l
{- Gets any keys that are on record as having a particular associated file.
- (Should be one or none but the database doesn't enforce that.) -}
getAssociatedKey :: FilePath -> Annex [Key]
getAssociatedKey = runReader . getAssociatedKey'
getAssociatedKey' :: FilePath -> Reader [Key]
getAssociatedKey' f = readDb $ do
l <- select $ from $ \r -> do
where_ (r ^. AssociatedFile ==. val f)
return (r ^. AssociatedKey)
return $ map (fromSKey . unValue) l
removeAssociatedFile :: Key -> FilePath -> Annex ()
removeAssociatedFile k = runWriter . removeAssociatedFile' (toSKey k)
removeAssociatedFile' :: SKey -> FilePath -> Writer
removeAssociatedFile' sk f = queueDb $
delete $ from $ \r -> do
where_ (r ^. AssociatedKey ==. val sk &&. r ^. AssociatedFile ==. val f)
{- Stats the files, and stores their InodeCaches. -}
storeInodeCaches :: Key -> [FilePath] -> Annex ()
storeInodeCaches k fs = withTSDelta $ \d ->
addInodeCaches k . catMaybes =<< liftIO (mapM (`genInodeCache` d) fs)
addInodeCaches :: Key -> [InodeCache] -> Annex ()
addInodeCaches k is = runWriter $ addInodeCaches' (toSKey k) is
addInodeCaches' :: SKey -> [InodeCache] -> Writer
addInodeCaches' sk is = queueDb $
forM_ is $ \i -> insertUnique $ Content sk (toSInodeCache i)
{- A key may have multiple InodeCaches; one for the annex object, and one
- for each pointer file that is a copy of it. -}
getInodeCaches :: Key -> Annex [InodeCache]
getInodeCaches = runReader . getInodeCaches' . toSKey
getInodeCaches' :: SKey -> Reader [InodeCache]
getInodeCaches' sk = readDb $ do
l <- select $ from $ \r -> do
where_ (r ^. ContentKey ==. val sk)
return (r ^. ContentCache)
return $ map (fromSInodeCache . unValue) l
removeInodeCaches :: Key -> Annex ()
removeInodeCaches = runWriter . removeInodeCaches' . toSKey
removeInodeCaches' :: SKey -> Writer
removeInodeCaches' sk = queueDb $
delete $ from $ \r -> do
where_ (r ^. ContentKey ==. val sk)
|
