|
1 | | -{-# LANGUAGE RankNTypes #-} |
2 | | -{-# LANGUAGE TypeApplications #-} |
3 | | -{-| |
4 | | -Module: Pos.Infra.StateLock |
5 | | -Description: A lock on the local state of a node |
6 | | -
|
7 | | -Provides a lock that is to be taken while modifying, or requiring a |
8 | | -consistent view on, the local state (the database and mempool). |
9 | | -
|
10 | | -It collects metrics on how long a given action waits on the lock, and |
11 | | -how long the action takes. |
12 | | --} |
13 | 1 | module Pos.Infra.StateLock |
14 | | - ( Priority (..) |
15 | | - , StateLock (..) |
16 | | - , newEmptyStateLock |
17 | | - , newStateLock |
18 | | - |
19 | | - , StateLockMetrics (..) |
20 | | - , ignoreStateLockMetrics |
21 | | - |
22 | | - , modifyStateLock |
23 | | - , withStateLock |
24 | | - , withStateLockNoMetrics |
| 2 | + ( module X |
25 | 3 | ) where |
26 | 4 |
|
27 | | -import Universum |
28 | | - |
29 | | -import Control.Monad.Catch (MonadMask) |
30 | | -import Data.Aeson.Types (ToJSON (..), Value) |
31 | | -import Data.Time.Units (Microsecond) |
32 | | -import JsonLog (CanJsonLog (..)) |
33 | | -import Mockable (CurrentTime, Mockable, currentTime) |
34 | | -import System.Mem (getAllocationCounter) |
35 | | -import System.Wlog (LoggerNameBox, WithLogger, askLoggerName, |
36 | | - usingLoggerName) |
37 | | - |
38 | | -import Pos.Core (HeaderHash) |
39 | | -import Pos.Util.Concurrent (modifyMVar, withMVar) |
40 | | -import Pos.Util.Concurrent.PriorityLock (Priority (..), PriorityLock, |
41 | | - newPriorityLock, withPriorityLock) |
42 | | -import Pos.Util.Util (HasLens', lensOf) |
43 | | - |
44 | | - |
45 | | --- | A simple wrapper over 'MVar' which stores 'HeaderHash' (our |
46 | | --- current tip) and is taken whenever we want to update GState or |
47 | | --- other data dependent on GState. |
48 | | -data StateLock = StateLock |
49 | | - { slTip :: !(MVar HeaderHash) |
50 | | - , slLock :: !PriorityLock |
51 | | - } |
52 | | - |
53 | | --- | Create empty (i. e. locked) 'StateLock'. |
54 | | -newEmptyStateLock :: MonadIO m => m StateLock |
55 | | -newEmptyStateLock = StateLock <$> newEmptyMVar <*> newPriorityLock |
56 | | - |
57 | | --- | Create a 'StateLock' with given tip. |
58 | | -newStateLock :: MonadIO m => HeaderHash -> m StateLock |
59 | | -newStateLock tip = StateLock <$> newMVar tip <*> newPriorityLock |
60 | | - |
61 | | --- | Effectful getters and setters for metrics related to the actions |
62 | | --- which use 'StateLock'. |
63 | | --- |
64 | | --- TODO this should not be fixed at IO, if being able to mock features |
65 | | --- remains a goal. But we can't free it up right now because the current |
66 | | --- mockable system doesn't work well with ether. |
67 | | --- |
68 | | --- TODO: make it type class if we want to use other things we have |
69 | | --- in application and to be more consistent with other code. @gromak |
70 | | -data StateLockMetrics slr = StateLockMetrics |
71 | | - { -- | Called when a thread begins to wait to modify the mempool. |
72 | | - -- Parameter is the reason for modifying the mempool. |
73 | | - slmWait :: !(slr -> LoggerNameBox IO ()) |
74 | | - -- | Called when a thread is granted the lock on the mempool. Parameter |
75 | | - -- indicates how long it waited. |
76 | | - , slmAcquire :: !(slr -> Microsecond -> LoggerNameBox IO ()) |
77 | | - -- | Called when a thread is finished modifying the mempool and has |
78 | | - -- released the lock. Parameters indicates time elapsed since acquiring |
79 | | - -- the lock, and new mempool size. |
80 | | - , slmRelease :: !(slr -> Microsecond -> Microsecond -> Int64 -> LoggerNameBox IO Value) |
81 | | - } |
82 | | - |
83 | | --- | A 'StateLockMetrics' that never does any writes. Use it if you |
84 | | --- don't care about metrics. |
85 | | -ignoreStateLockMetrics :: StateLockMetrics () |
86 | | -ignoreStateLockMetrics = StateLockMetrics |
87 | | - { slmWait = \_ -> pure () |
88 | | - , slmAcquire = \_ _ -> pure () |
89 | | - , slmRelease = \_ _ _ _ -> pure (toJSON ()) |
90 | | - } |
91 | | - |
92 | | -type MonadStateLockBase ctx m |
93 | | - = ( MonadIO m |
94 | | - , MonadMask m |
95 | | - , MonadReader ctx m |
96 | | - , HasLens' ctx StateLock |
97 | | - ) |
98 | | - |
99 | | -type MonadStateLock ctx slr m |
100 | | - = ( MonadStateLockBase ctx m |
101 | | - , WithLogger m |
102 | | - , Mockable CurrentTime m |
103 | | - , HasLens' ctx (StateLockMetrics slr) |
104 | | - , CanJsonLog m |
105 | | - ) |
106 | | - |
107 | | --- | Run an action acquiring 'StateLock' lock. Argument of |
108 | | --- action is an old tip, result is put as a new tip. |
109 | | -modifyStateLock :: forall ctx slr m a. |
110 | | - MonadStateLock ctx slr m |
111 | | - => Priority |
112 | | - -> slr |
113 | | - -> (HeaderHash -> m (HeaderHash, a)) |
114 | | - -> m a |
115 | | -modifyStateLock = stateLockHelper modifyMVar |
116 | | - |
117 | | --- | Run an action acquiring 'StateLock' lock without modifying tip. |
118 | | -withStateLock :: |
119 | | - MonadStateLock ctx slr m => Priority -> slr -> (HeaderHash -> m a) -> m a |
120 | | -withStateLock = stateLockHelper withMVar |
121 | | - |
122 | | --- | Version of 'withStateLock' that does not gather metrics |
123 | | -withStateLockNoMetrics :: |
124 | | - MonadStateLockBase ctx m => Priority -> (HeaderHash -> m a) -> m a |
125 | | -withStateLockNoMetrics prio action = do |
126 | | - StateLock mvar prioLock <- view (lensOf @StateLock) |
127 | | - withPriorityLock prioLock prio $ withMVar mvar action |
128 | | - |
129 | | -stateLockHelper :: forall ctx slr m a b. |
130 | | - MonadStateLock ctx slr m |
131 | | - => (MVar HeaderHash -> (HeaderHash -> m b) -> m a) |
132 | | - -> Priority |
133 | | - -> slr |
134 | | - -> (HeaderHash -> m b) |
135 | | - -> m a |
136 | | -stateLockHelper doWithMVar prio reason action = do |
137 | | - StateLock mvar prioLock <- view (lensOf @StateLock) |
138 | | - StateLockMetrics {..} <- view (lensOf @(StateLockMetrics slr)) |
139 | | - lname <- askLoggerName |
140 | | - liftIO . usingLoggerName lname $ slmWait reason |
141 | | - timeBeginWait <- currentTime |
142 | | - withPriorityLock prioLock prio $ doWithMVar mvar $ \hh -> do |
143 | | - timeEndWait <- currentTime |
144 | | - liftIO . usingLoggerName lname $ |
145 | | - slmAcquire reason (timeEndWait - timeBeginWait) |
146 | | - timeBeginModify <- currentTime |
147 | | - memBeginModify <- liftIO getAllocationCounter |
148 | | - res <- action hh |
149 | | - timeEndModify <- currentTime |
150 | | - memEndModify <- liftIO getAllocationCounter |
151 | | - json <- liftIO . usingLoggerName lname $ slmRelease |
152 | | - reason |
153 | | - (timeEndWait - timeBeginWait) |
154 | | - (timeEndModify - timeBeginModify) |
155 | | - -- counter counts "down" memory that has been allocated by the thread |
156 | | - (memBeginModify - memEndModify) |
157 | | - jsonLog json |
158 | | - pure res |
| 5 | +import Pos.Sinbin.StateLock as X |
0 commit comments