blob: 8a3f2b4070b449e149be41479ea0bf44a830d618 (
plain)
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
|
{- Handle for the Keys database.
-
- Copyright 2015 Joey Hess <id@joeyh.name>
-:
- Licensed under the GNU GPL version 3 or higher.
-}
module Database.Keys.Handle (
DbHandle,
newDbHandle,
DbState(..),
withDbState,
flushDbQueue,
) where
import qualified Database.Queue as H
import Utility.Exception
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.
data DbState = DbClosed | DbOpen H.DbQueue | DbEmpty
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 $ takeMVar mvar
go st `onException` (liftIO $ putMVar mvar st)
where
go st = do
(v, st') <- a st
liftIO $ putMVar mvar st'
return v
flushDbQueue :: DbHandle -> IO ()
flushDbQueue (DbHandle mvar) = go =<< readMVar mvar
where
go (DbOpen qh) = H.flushDbQueue qh
go _ = return ()
|
