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
|
{- Handle for the Keys database.
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-:
- Licensed under the GNU AGPL version 3 or higher.
-}
module Database.Keys.Handle (
DbHandle,
newDbHandle,
DbState(..),
withDbState,
flushDbQueue,
closeDbHandle,
) where
import qualified Database.Queue as H
import Database.Keys.Tables
import Utility.Exception
import Utility.DebugLocks
import Control.Concurrent
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Applicative
import Prelude
-- The MVar is always left full except when actions are run
-- that access the database.
newtype DbHandle = DbHandle (MVar DbState)
-- The database can be closed or open, but it also may have been
-- tried to open (for read) and didn't exist yet or is not readable.
data DbState = DbClosed | DbOpen (H.DbQueue, DbTablesChanged) | DbUnavailable
newDbHandle :: IO DbHandle
newDbHandle = DbHandle <$> newMVar DbClosed
-- Runs an action on the state of the handle, which can change its state.
-- The MVar is empty while the action runs, which blocks other users
-- of the handle from running.
withDbState
:: (MonadIO m, MonadCatch m)
=> DbHandle
-> (DbState -> m (v, DbState))
-> m v
withDbState (DbHandle mvar) a = do
st <- liftIO $ debugLocks $ takeMVar mvar
go st `onException` (liftIO $ debugLocks $ putMVar mvar st)
where
go st = do
(v, st') <- a st
liftIO $ debugLocks $ putMVar mvar st'
return v
flushDbQueue :: DbHandle -> IO ()
flushDbQueue h = withDbState h go
where
go (DbOpen (qh, _)) = do
H.flushDbQueue qh
return ((), DbOpen (qh, mempty))
go st = return ((), st)
closeDbHandle :: DbHandle -> IO ()
closeDbHandle h = withDbState h go
where
go (DbOpen (qh, _)) = do
H.closeDbQueue qh
return ((), DbClosed)
go st = return ((), st)
|
