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
|
{- Sqlite database used for incremental fsck.
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-:
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
module Database.Fsck (
newPass,
openDb,
closeDb,
H.commitDb,
H.DbHandle,
addDb,
inDb,
FsckedId,
) where
import Database.Types
import qualified Database.Handle as H
import Locations
import Utility.Directory
import Annex
import Types.Key
import Annex.Perms
import Annex.LockFile
import Database.Persist.TH
import Database.Esqueleto hiding (Key)
import Control.Monad
import Control.Monad.IfElse
import Control.Monad.IO.Class (liftIO)
import System.Directory
import Data.Maybe
import Control.Applicative
{- Each key stored in the database has already been fscked as part
- of the latest incremental fsck pass. -}
share [mkPersist sqlSettings, mkMigrate "migrateFsck"] [persistLowerCase|
Fscked
key SKey
UniqueKey key
|]
{- The database is removed when starting a new incremental fsck pass.
-
- This may fail, if other fsck processes are currently running using the
- database. Removing the database in that situation would lead to crashes
- or undefined behavior.
-}
newPass :: Annex Bool
newPass = isJust <$> tryExclusiveLock gitAnnexFsckDbLock go
where
go = liftIO. nukeFile =<< fromRepo gitAnnexFsckDb
{- Opens the database, creating it atomically if it doesn't exist yet. -}
openDb :: Annex H.DbHandle
openDb = do
db <- fromRepo gitAnnexFsckDb
unlessM (liftIO $ doesFileExist db) $ do
let newdb = db ++ ".new"
h <- liftIO $ H.openDb newdb
void $ liftIO $ H.runDb h $
runMigrationSilent migrateFsck
liftIO $ H.closeDb h
setAnnexFilePerm newdb
liftIO $ renameFile newdb db
lockFileShared =<< fromRepo gitAnnexFsckDbLock
liftIO $ H.openDb db
closeDb :: H.DbHandle -> Annex ()
closeDb h = do
liftIO $ H.closeDb h
unlockFile =<< fromRepo gitAnnexFsckDbLock
addDb :: H.DbHandle -> Key -> IO ()
addDb h = void . H.runDb' h commitPolicy . insert . Fscked . toSKey
inDb :: H.DbHandle -> Key -> IO Bool
inDb h k = H.runDb h $ do
r <- select $ from $ \r -> do
where_ (r ^. FsckedKey ==. val (toSKey k))
return (r ^. FsckedKey)
return $ not $ null r
{- Bundle up addDb transactions and commit after 60 seconds.
- This is a balance between resuming where the last incremental
- fsck left off, and making too many commits which slows down the fsck
- of lots of small or not present files. -}
commitPolicy :: H.CommitPolicy
commitPolicy = H.CommitAfter (fromIntegral (60 :: Int))
|
