Skip to content

Commit 428a61a

Browse files
sorkisorki
committed
remote: split runStoreSocket, doReq into Remote.Client.Core
1 parent 7dc5c59 commit 428a61a

File tree

3 files changed

+187
-158
lines changed

3 files changed

+187
-158
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -78,6 +78,7 @@ library
7878
, System.Nix.Store.Remote
7979
, System.Nix.Store.Remote.Arbitrary
8080
, System.Nix.Store.Remote.Client
81+
, System.Nix.Store.Remote.Client.Core
8182
, System.Nix.Store.Remote.Logger
8283
, System.Nix.Store.Remote.MonadStore
8384
, System.Nix.Store.Remote.Serialize

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

Lines changed: 12 additions & 158 deletions
Original file line numberDiff line numberDiff line change
@@ -1,48 +1,38 @@
11
module System.Nix.Store.Remote.Client
2-
( Run
3-
, simpleOp
2+
( simpleOp
43
, simpleOpArgs
54
, runOp
65
, runOpArgs
76
, runOpArgsIO
8-
, runStoreSocket
9-
, ourProtoVersion
10-
, doReq
117
, addToStore
128
, buildDerivation
139
, isValidPath
10+
, module System.Nix.Store.Remote.Client.Core
1411
) where
1512

16-
import Control.Monad (unless, when)
13+
import Control.Monad (when)
1714
import Control.Monad.Except (throwError)
18-
import Control.Monad.IO.Class (MonadIO, liftIO)
19-
import Data.DList (DList)
15+
import Control.Monad.IO.Class (liftIO)
2016
import Data.Serialize.Put (Put, runPut)
21-
import Data.Some (Some(Some))
22-
23-
import qualified Data.ByteString
24-
import qualified Network.Socket.ByteString
17+
import Data.Some (Some)
18+
import Data.Text (Text)
2519

20+
import System.Nix.Build (BuildMode, BuildResult)
21+
import System.Nix.Derivation (Derivation)
2622
import System.Nix.Hash (HashAlgo(..))
2723
import System.Nix.Nar (NarSource)
2824
import System.Nix.StorePath (StorePath, StorePathName)
2925
import System.Nix.Store.Remote.Logger (processOutput)
3026
import System.Nix.Store.Remote.MonadStore
3127
import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)
32-
import System.Nix.Store.Remote.Serializer (bool, enum, int, mapErrorS, protoVersion, storeRequest, text, trustedFlag, workerMagic)
33-
import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeInput(..), ClientHandshakeOutput(..))
34-
import System.Nix.Store.Remote.Types.Logger (Logger)
35-
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion)
36-
import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig)
28+
import System.Nix.Store.Remote.Serializer (bool, enum, mapErrorS)
3729
import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))
38-
import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..))
39-
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
4030
import System.Nix.Store.Remote.Types.WorkerOp (WorkerOp)
31+
import System.Nix.Store.Remote.Client.Core
4132
import System.Nix.Store.Types (FileIngestionMethod(..), RepairMode(..))
4233

43-
import Data.Text
44-
import System.Nix.Build
45-
import System.Nix.Derivation (Derivation)
34+
import qualified Data.ByteString
35+
import qualified Network.Socket.ByteString
4636

4737
simpleOp
4838
:: MonadRemoteStore m
@@ -93,47 +83,6 @@ runOpArgsIO op encoder = do
9383

9484
processOutput
9585

96-
-- | Perform @StoreRequest@
97-
doReq
98-
:: forall m a
99-
. ( MonadIO m
100-
, MonadRemoteStore m
101-
, StoreReply a
102-
, Show a
103-
)
104-
=> StoreRequest a
105-
-> m a
106-
doReq = \case
107-
x -> do
108-
sockPutS
109-
(mapErrorS
110-
RemoteStoreError_SerializerRequest
111-
storeRequest
112-
)
113-
(Some x)
114-
115-
case x of
116-
AddToStore {} -> do
117-
118-
ms <- takeNarSource
119-
case ms of
120-
Just (stream :: NarSource IO) -> do
121-
soc <- getStoreSocket
122-
liftIO
123-
$ stream
124-
$ Network.Socket.ByteString.sendAll soc
125-
Nothing ->
126-
throwError
127-
RemoteStoreError_NoNarSourceProvided
128-
129-
_ -> pure ()
130-
131-
processOutput
132-
sockGetS
133-
(mapErrorS RemoteStoreError_SerializerReply
134-
$ getReplyS @a
135-
)
136-
13786
-- | Add `NarSource` to the store
13887
addToStore
13988
:: MonadRemoteStore m
@@ -159,100 +108,5 @@ buildDerivation
159108
-> m BuildResult
160109
buildDerivation a b c = doReq (BuildDerivation a b c)
161110

162-
--isValidPath :: MonadIO m => StorePath -> RemoteStoreT StoreConfig m Bool
163-
--isValidPath = doReq . IsValidPath
164-
165-
-- TOOD: want this, but Logger.processOutput is fixed to RemoteStoreT r m
166111
isValidPath :: MonadRemoteStore m => StorePath -> m Bool
167112
isValidPath = doReq . IsValidPath
168-
169-
type Run m a = m (Either RemoteStoreError a, DList Logger)
170-
171-
runStoreSocket
172-
:: ( Monad m
173-
, MonadIO m
174-
)
175-
=> PreStoreConfig
176-
-> RemoteStoreT StoreConfig m a
177-
-> Run m a
178-
runStoreSocket preStoreConfig code =
179-
runRemoteStoreT preStoreConfig $ do
180-
ClientHandshakeOutput{..}
181-
<- greet
182-
ClientHandshakeInput
183-
{ clientHandshakeInputOurVersion = ourProtoVersion
184-
}
185-
186-
mapStoreConfig
187-
(preStoreConfigToStoreConfig
188-
clientHandshakeOutputLeastCommonVerison)
189-
code
190-
191-
where
192-
greet
193-
:: MonadIO m
194-
=> ClientHandshakeInput
195-
-> RemoteStoreT PreStoreConfig m ClientHandshakeOutput
196-
greet ClientHandshakeInput{..} = do
197-
198-
sockPutS
199-
(mapErrorS
200-
RemoteStoreError_SerializerHandshake
201-
workerMagic
202-
)
203-
WorkerMagic_One
204-
205-
magic <-
206-
sockGetS
207-
$ mapErrorS
208-
RemoteStoreError_SerializerHandshake
209-
workerMagic
210-
211-
unless
212-
(magic == WorkerMagic_Two)
213-
$ throwError RemoteStoreError_WorkerMagic2Mismatch
214-
215-
daemonVersion <- sockGetS protoVersion
216-
217-
when (daemonVersion < ProtoVersion 1 10)
218-
$ throwError RemoteStoreError_ClientVersionTooOld
219-
220-
sockPutS protoVersion clientHandshakeInputOurVersion
221-
222-
let leastCommonVersion = min daemonVersion ourProtoVersion
223-
224-
when (leastCommonVersion >= ProtoVersion 1 14)
225-
$ sockPutS int (0 :: Int) -- affinity, obsolete
226-
227-
when (leastCommonVersion >= ProtoVersion 1 11) $ do
228-
sockPutS
229-
(mapErrorS RemoteStoreError_SerializerPut bool)
230-
False -- reserveSpace, obsolete
231-
232-
daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33
233-
then do
234-
-- If we were buffering I/O, we would flush the output here.
235-
txtVer <-
236-
sockGetS
237-
$ mapErrorS
238-
RemoteStoreError_SerializerGet
239-
text
240-
pure $ Just txtVer
241-
else pure Nothing
242-
243-
remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35
244-
then do
245-
sockGetS
246-
$ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag
247-
else pure Nothing
248-
249-
mapStoreConfig
250-
(preStoreConfigToStoreConfig leastCommonVersion)
251-
processOutput
252-
253-
pure ClientHandshakeOutput
254-
{ clientHandshakeOutputNixVersion = daemonNixVersion
255-
, clientHandshakeOutputTrust = remoteTrustsUs
256-
, clientHandshakeOutputLeastCommonVerison = leastCommonVersion
257-
, clientHandshakeOutputServerVersion = daemonVersion
258-
}

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

Lines changed: 174 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,174 @@
1+
module System.Nix.Store.Remote.Client.Core
2+
( Run
3+
, runStoreSocket
4+
, doReq
5+
) where
6+
7+
import Control.Monad (unless, when)
8+
import Control.Monad.Except (throwError)
9+
import Control.Monad.IO.Class (MonadIO, liftIO)
10+
import Data.DList (DList)
11+
import Data.Some (Some(Some))
12+
import System.Nix.Nar (NarSource)
13+
import System.Nix.Store.Remote.Logger (processOutput)
14+
import System.Nix.Store.Remote.MonadStore
15+
( MonadRemoteStore
16+
, RemoteStoreError(..)
17+
, RemoteStoreT
18+
, runRemoteStoreT
19+
, mapStoreConfig
20+
, takeNarSource
21+
, getStoreSocket
22+
)
23+
import System.Nix.Store.Remote.Socket (sockPutS, sockGetS)
24+
import System.Nix.Store.Remote.Serializer
25+
( bool
26+
, int
27+
, mapErrorS
28+
, protoVersion
29+
, storeRequest
30+
, text
31+
, trustedFlag
32+
, workerMagic
33+
)
34+
import System.Nix.Store.Remote.Types.Handshake (ClientHandshakeInput(..), ClientHandshakeOutput(..))
35+
import System.Nix.Store.Remote.Types.Logger (Logger)
36+
import System.Nix.Store.Remote.Types.ProtoVersion (ProtoVersion(..), ourProtoVersion)
37+
import System.Nix.Store.Remote.Types.StoreConfig (PreStoreConfig, StoreConfig, preStoreConfigToStoreConfig)
38+
import System.Nix.Store.Remote.Types.StoreRequest (StoreRequest(..))
39+
import System.Nix.Store.Remote.Types.StoreReply (StoreReply(..))
40+
import System.Nix.Store.Remote.Types.WorkerMagic (WorkerMagic(..))
41+
42+
import qualified Network.Socket.ByteString
43+
44+
type Run m a = m (Either RemoteStoreError a, DList Logger)
45+
46+
-- | Perform @StoreRequest@
47+
doReq
48+
:: forall m a
49+
. ( MonadIO m
50+
, MonadRemoteStore m
51+
, StoreReply a
52+
, Show a
53+
)
54+
=> StoreRequest a
55+
-> m a
56+
doReq = \case
57+
x -> do
58+
sockPutS
59+
(mapErrorS
60+
RemoteStoreError_SerializerRequest
61+
storeRequest
62+
)
63+
(Some x)
64+
65+
case x of
66+
AddToStore {} -> do
67+
68+
ms <- takeNarSource
69+
case ms of
70+
Just (stream :: NarSource IO) -> do
71+
soc <- getStoreSocket
72+
liftIO
73+
$ stream
74+
$ Network.Socket.ByteString.sendAll soc
75+
Nothing ->
76+
throwError
77+
RemoteStoreError_NoNarSourceProvided
78+
79+
_ -> pure ()
80+
81+
processOutput
82+
sockGetS
83+
(mapErrorS RemoteStoreError_SerializerReply
84+
$ getReplyS @a
85+
)
86+
87+
runStoreSocket
88+
:: ( Monad m
89+
, MonadIO m
90+
)
91+
=> PreStoreConfig
92+
-> RemoteStoreT StoreConfig m a
93+
-> Run m a
94+
runStoreSocket preStoreConfig code =
95+
runRemoteStoreT preStoreConfig $ do
96+
ClientHandshakeOutput{..}
97+
<- greet
98+
ClientHandshakeInput
99+
{ clientHandshakeInputOurVersion = ourProtoVersion
100+
}
101+
102+
mapStoreConfig
103+
(preStoreConfigToStoreConfig
104+
clientHandshakeOutputLeastCommonVerison)
105+
code
106+
107+
where
108+
greet
109+
:: MonadIO m
110+
=> ClientHandshakeInput
111+
-> RemoteStoreT PreStoreConfig m ClientHandshakeOutput
112+
greet ClientHandshakeInput{..} = do
113+
114+
sockPutS
115+
(mapErrorS
116+
RemoteStoreError_SerializerHandshake
117+
workerMagic
118+
)
119+
WorkerMagic_One
120+
121+
magic <-
122+
sockGetS
123+
$ mapErrorS
124+
RemoteStoreError_SerializerHandshake
125+
workerMagic
126+
127+
unless
128+
(magic == WorkerMagic_Two)
129+
$ throwError RemoteStoreError_WorkerMagic2Mismatch
130+
131+
daemonVersion <- sockGetS protoVersion
132+
133+
when (daemonVersion < ProtoVersion 1 10)
134+
$ throwError RemoteStoreError_ClientVersionTooOld
135+
136+
sockPutS protoVersion clientHandshakeInputOurVersion
137+
138+
let leastCommonVersion = min daemonVersion ourProtoVersion
139+
140+
when (leastCommonVersion >= ProtoVersion 1 14)
141+
$ sockPutS int (0 :: Int) -- affinity, obsolete
142+
143+
when (leastCommonVersion >= ProtoVersion 1 11) $ do
144+
sockPutS
145+
(mapErrorS RemoteStoreError_SerializerPut bool)
146+
False -- reserveSpace, obsolete
147+
148+
daemonNixVersion <- if leastCommonVersion >= ProtoVersion 1 33
149+
then do
150+
-- If we were buffering I/O, we would flush the output here.
151+
txtVer <-
152+
sockGetS
153+
$ mapErrorS
154+
RemoteStoreError_SerializerGet
155+
text
156+
pure $ Just txtVer
157+
else pure Nothing
158+
159+
remoteTrustsUs <- if leastCommonVersion >= ProtoVersion 1 35
160+
then do
161+
sockGetS
162+
$ mapErrorS RemoteStoreError_SerializerHandshake trustedFlag
163+
else pure Nothing
164+
165+
mapStoreConfig
166+
(preStoreConfigToStoreConfig leastCommonVersion)
167+
processOutput
168+
169+
pure ClientHandshakeOutput
170+
{ clientHandshakeOutputNixVersion = daemonNixVersion
171+
, clientHandshakeOutputTrust = remoteTrustsUs
172+
, clientHandshakeOutputLeastCommonVerison = leastCommonVersion
173+
, clientHandshakeOutputServerVersion = daemonVersion
174+
}

0 commit comments

Comments
 (0)