Skip to content

Commit ab22b0d

Browse files
sorkisorki
committed
remote: MonadRemoteStore typeclass
Co-Authored-By: Guillaume Maudoux <[email protected]> Related to #72
1 parent 2162d8b commit ab22b0d

File tree

5 files changed

+150
-76
lines changed

5 files changed

+150
-76
lines changed

‎hnix-store-remote/hnix-store-remote.cabal

+2
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ common commons
2020
ghc-options: -Wall
2121
default-extensions:
2222
DataKinds
23+
, DefaultSignatures
2324
, DeriveGeneric
2425
, DeriveDataTypeable
2526
, DeriveFunctor
@@ -34,6 +35,7 @@ common commons
3435
, ScopedTypeVariables
3536
, StandaloneDeriving
3637
, TypeApplications
38+
, TypeOperators
3739
, TypeSynonymInstances
3840
, InstanceSigs
3941
, KindSignatures

‎hnix-store-remote/src/System/Nix/Store/Remote/Client.hs

+16-15
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import qualified Data.Bool
2020
import qualified Data.ByteString
2121
import qualified Network.Socket.ByteString
2222

23+
import System.Nix.StorePath (HasStoreDir(..))
2324
import System.Nix.Store.Remote.Logger (processOutput)
2425
import System.Nix.Store.Remote.MonadStore
2526
import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)
@@ -32,20 +33,20 @@ import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
3233
import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp)
3334

3435
simpleOp
35-
:: ( Monad m
36-
, MonadIO m
37-
, HasProtoVersion r
36+
:: ( MonadIO m
37+
, HasStoreDir r
3838
, HasStoreSocket r
39+
, HasProtoVersion r
3940
)
4041
=> WorkerOp
4142
-> RemoteStoreT r m Bool
4243
simpleOp op = simpleOpArgs op $ pure ()
4344

4445
simpleOpArgs
45-
:: ( Monad m
46-
, MonadIO m
47-
, HasProtoVersion r
46+
:: ( MonadIO m
47+
, HasStoreDir r
4848
, HasStoreSocket r
49+
, HasProtoVersion r
4950
)
5051
=> WorkerOp
5152
-> Put
@@ -62,20 +63,20 @@ simpleOpArgs op args = do
6263
err
6364

6465
runOp
65-
:: ( Monad m
66-
, MonadIO m
67-
, HasProtoVersion r
66+
:: ( MonadIO m
67+
, HasStoreDir r
6868
, HasStoreSocket r
69+
, HasProtoVersion r
6970
)
7071
=> WorkerOp
7172
-> RemoteStoreT r m ()
7273
runOp op = runOpArgs op $ pure ()
7374

7475
runOpArgs
75-
:: ( Monad m
76-
, MonadIO m
77-
, HasProtoVersion r
76+
:: ( MonadIO m
77+
, HasStoreDir r
7878
, HasStoreSocket r
79+
, HasProtoVersion r
7980
)
8081
=> WorkerOp
8182
-> Put
@@ -86,10 +87,10 @@ runOpArgs op args =
8687
(\encode -> encode $ runPut args)
8788

8889
runOpArgsIO
89-
:: ( Monad m
90-
, MonadIO m
91-
, HasProtoVersion r
90+
:: ( MonadIO m
91+
, HasStoreDir r
9292
, HasStoreSocket r
93+
, HasProtoVersion r
9394
)
9495
=> WorkerOp
9596
-> ((Data.ByteString.ByteString -> RemoteStoreT r m ())

‎hnix-store-remote/src/System/Nix/Store/Remote/Logger.hs

+3
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ import Control.Monad.Except (throwError)
66
import Control.Monad.IO.Class (MonadIO)
77
import Data.ByteString (ByteString)
88
import Data.Serialize (Result(..))
9+
import System.Nix.StorePath (HasStoreDir(..))
910
import System.Nix.Store.Remote.Serialize.Prim (putByteString)
1011
import System.Nix.Store.Remote.Serializer (LoggerSError, logger, runSerialT)
1112
import System.Nix.Store.Remote.Socket (sockGet8, sockPut)
@@ -22,6 +23,7 @@ processOutput
2223
:: ( Monad m
2324
, MonadIO m
2425
, HasProtoVersion r
26+
, HasStoreDir r
2527
, HasStoreSocket r
2628
)
2729
=> RemoteStoreT r m [Logger]
@@ -41,6 +43,7 @@ processOutput = do
4143
:: ( Monad m
4244
, MonadIO m
4345
, HasProtoVersion r
46+
, HasStoreDir r
4447
, HasStoreSocket r
4548
)
4649
=> Result (Either LoggerSError Logger)

‎hnix-store-remote/src/System/Nix/Store/Remote/MonadStore.hs

+126-58
Original file line numberDiff line numberDiff line change
@@ -7,20 +7,8 @@ module System.Nix.Store.Remote.MonadStore
77
, RemoteStoreT
88
, runRemoteStoreT
99
, mapStoreConfig
10-
-- * Reader helpers
11-
, getStoreDir
12-
, getStoreSocket
10+
, MonadRemoteStore(..)
1311
, getProtoVersion
14-
-- * Logs
15-
, appendLogs
16-
, getLogs
17-
, flushLogs
18-
, gotError
19-
, getErrors
20-
-- * Data required from client
21-
, getData
22-
, setData
23-
, clearData
2412
) where
2513

2614
import Control.Monad.Except (MonadError)
@@ -119,21 +107,131 @@ mapStoreConfig f =
119107
) f
120108
. _unRemoteStoreT
121109

122-
-- | Ask for a @StoreDir@
123-
getStoreDir
124-
:: ( Monad m
125-
, HasStoreDir r
126-
)
127-
=> RemoteStoreT r m StoreDir
128-
getStoreDir = hasStoreDir <$> RemoteStoreT ask
129-
130-
-- | Ask for a @StoreDir@
131-
getStoreSocket
132-
:: ( Monad m
133-
, HasStoreSocket r
134-
)
135-
=> RemoteStoreT r m Socket
136-
getStoreSocket = hasStoreSocket <$> RemoteStoreT ask
110+
class ( Monad m
111+
, MonadError RemoteStoreError m
112+
)
113+
=> MonadRemoteStore m where
114+
115+
appendLogs :: [Logger] -> m ()
116+
default appendLogs
117+
:: ( MonadTrans t
118+
, MonadRemoteStore m'
119+
, m ~ t m'
120+
)
121+
=> [Logger]
122+
-> m ()
123+
appendLogs = lift . appendLogs
124+
125+
gotError :: m Bool
126+
default gotError
127+
:: ( MonadTrans t
128+
, MonadRemoteStore m'
129+
, m ~ t m'
130+
)
131+
=> m Bool
132+
gotError = lift gotError
133+
134+
getErrors :: m [Logger]
135+
default getErrors
136+
:: ( MonadTrans t
137+
, MonadRemoteStore m'
138+
, m ~ t m'
139+
)
140+
=> m [Logger]
141+
getErrors = lift getErrors
142+
143+
getLogs :: m [Logger]
144+
default getLogs
145+
:: ( MonadTrans t
146+
, MonadRemoteStore m'
147+
, m ~ t m'
148+
)
149+
=> m [Logger]
150+
getLogs = lift getLogs
151+
152+
flushLogs :: m ()
153+
default flushLogs
154+
:: ( MonadTrans t
155+
, MonadRemoteStore m'
156+
, m ~ t m'
157+
)
158+
=> m ()
159+
flushLogs = lift flushLogs
160+
161+
setData :: ByteString -> m ()
162+
default setData
163+
:: ( MonadTrans t
164+
, MonadRemoteStore m'
165+
, m ~ t m'
166+
)
167+
=> ByteString
168+
-> m ()
169+
setData = lift . setData
170+
171+
getData :: m (Maybe ByteString)
172+
default getData
173+
:: ( MonadTrans t
174+
, MonadRemoteStore m'
175+
, m ~ t m'
176+
)
177+
=> m (Maybe ByteString)
178+
getData = lift getData
179+
180+
clearData :: m ()
181+
default clearData
182+
:: ( MonadTrans t
183+
, MonadRemoteStore m'
184+
, m ~ t m'
185+
)
186+
=> m ()
187+
clearData = lift clearData
188+
189+
getStoreDir :: m StoreDir
190+
default getStoreDir
191+
:: ( MonadTrans t
192+
, MonadRemoteStore m'
193+
, m ~ t m'
194+
)
195+
=> m StoreDir
196+
getStoreDir = lift getStoreDir
197+
198+
getStoreSocket :: m Socket
199+
default getStoreSocket
200+
:: ( MonadTrans t
201+
, MonadRemoteStore m'
202+
, m ~ t m'
203+
)
204+
=> m Socket
205+
getStoreSocket = lift getStoreSocket
206+
207+
instance MonadRemoteStore m => MonadRemoteStore (StateT s m)
208+
instance MonadRemoteStore m => MonadRemoteStore (ReaderT r m)
209+
instance MonadRemoteStore m => MonadRemoteStore (ExceptT RemoteStoreError m)
210+
211+
instance ( Monad m
212+
, HasStoreDir r
213+
, HasStoreSocket r
214+
)
215+
=> MonadRemoteStore (RemoteStoreT r m) where
216+
217+
getStoreDir = hasStoreDir <$> RemoteStoreT ask
218+
getStoreSocket = hasStoreSocket <$> RemoteStoreT ask
219+
220+
appendLogs x =
221+
RemoteStoreT
222+
$ modify
223+
$ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x }
224+
getLogs = remoteStoreState_logs <$> RemoteStoreT get
225+
flushLogs =
226+
RemoteStoreT
227+
$ modify
228+
$ \s -> s { remoteStoreState_logs = mempty }
229+
gotError = any isError <$> getLogs
230+
getErrors = filter isError <$> getLogs
231+
232+
getData = remoteStoreState_mData <$> RemoteStoreT get
233+
setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x }
234+
clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing }
137235

138236
-- | Ask for a @StoreDir@
139237
getProtoVersion
@@ -142,33 +240,3 @@ getProtoVersion
142240
)
143241
=> RemoteStoreT r m ProtoVersion
144242
getProtoVersion = hasProtoVersion <$> RemoteStoreT ask
145-
146-
-- * Logs
147-
148-
gotError :: Monad m => RemoteStoreT r m Bool
149-
gotError = any isError <$> getLogs
150-
151-
getErrors :: Monad m => RemoteStoreT r m [Logger]
152-
getErrors = filter isError <$> getLogs
153-
154-
appendLogs :: Monad m => [Logger] -> RemoteStoreT r m ()
155-
appendLogs x = RemoteStoreT
156-
$ modify
157-
$ \s -> s { remoteStoreState_logs = remoteStoreState_logs s <> x }
158-
159-
getLogs :: Monad m => RemoteStoreT r m [Logger]
160-
getLogs = remoteStoreState_logs <$> RemoteStoreT get
161-
162-
flushLogs :: Monad m => RemoteStoreT r m ()
163-
flushLogs = RemoteStoreT $ modify $ \s -> s { remoteStoreState_logs = mempty }
164-
165-
-- * Data required from client
166-
167-
getData :: Monad m => RemoteStoreT r m (Maybe ByteString)
168-
getData = remoteStoreState_mData <$> RemoteStoreT get
169-
170-
setData :: Monad m => ByteString -> RemoteStoreT r m ()
171-
setData x = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = pure x }
172-
173-
clearData :: Monad m => RemoteStoreT r m ()
174-
clearData = RemoteStoreT $ modify $ \s -> s { remoteStoreState_mData = Nothing }

‎hnix-store-remote/src/System/Nix/Store/Remote/Socket.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ import Data.Serialize.Get (Get, Result(..))
99
import Data.Serialize.Put (Put, runPut)
1010
import Network.Socket.ByteString (recv, sendAll)
1111
import System.Nix.StorePath (HasStoreDir, StorePath)
12-
import System.Nix.Store.Remote.MonadStore (RemoteStoreT, RemoteStoreError(..), getStoreDir, getStoreSocket)
12+
import System.Nix.Store.Remote.MonadStore (RemoteStoreT, RemoteStoreError(..), getStoreDir)
1313
import System.Nix.Store.Remote.Serializer (NixSerializer, runP, runSerialT)
1414
import System.Nix.Store.Remote.Serialize.Prim (getInt, getByteString, getByteStrings, getPath, getPathsOrFail)
1515
import System.Nix.Store.Remote.Types (HasStoreSocket(..))
@@ -40,7 +40,7 @@ sockGet8
4040
)
4141
=> RemoteStoreT r m ByteString
4242
sockGet8 = do
43-
soc <- getStoreSocket
43+
soc <- asks hasStoreSocket
4444
liftIO $ recv soc 8
4545

4646
sockPut
@@ -51,7 +51,7 @@ sockPut
5151
=> Put
5252
-> RemoteStoreT r m ()
5353
sockPut p = do
54-
soc <- getStoreSocket
54+
soc <- asks hasStoreSocket
5555
liftIO $ sendAll soc $ runPut p
5656

5757
sockPutS

0 commit comments

Comments
 (0)