summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-11-20 16:42:18 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-11-20 16:42:18 -0400
commit849256634ad1234f9957532e0131e0e2b491bdeb (patch)
tree1feba99e261107f0e5c2ad8e724df57bbb3b9fa0 /Remote
parentdce8e76ef443e33d88b8301c86ebf080fceff511 (diff)
improve p2p protocol implementation
Tested it in ghci a little now.
Diffstat (limited to 'Remote')
-rw-r--r--Remote/Helper/P2P.hs6
-rw-r--r--Remote/Helper/P2P/IO.hs34
2 files changed, 24 insertions, 16 deletions
diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs
index fbd6c2463..1e1519560 100644
--- a/Remote/Helper/P2P.hs
+++ b/Remote/Helper/P2P.hs
@@ -134,6 +134,7 @@ data NetF c
| ReceiveMessage (Message -> c)
| SendBytes Len L.ByteString c
| ReceiveBytes Len (L.ByteString -> c)
+ | CheckAuthToken UUID AuthToken (Bool -> c)
| Relay RelayHandle
(RelayData -> Net (Maybe ExitCode))
(ExitCode -> c)
@@ -173,7 +174,6 @@ data LocalF c
-- Note: The ByteString may not contain the entire remaining content
-- of the key. Only once the key file size == Len has the whole
-- content been transferred.
- | CheckAuthToken UUID AuthToken (Bool -> c)
| SetPresent Key UUID c
| CheckContentPresent Key (Bool -> c)
-- ^ Checks if the whole content of the key is locally present.
@@ -203,6 +203,7 @@ runNet (ReceiveMessage _) [] = [("not enough Messages provided", Nothing)]
runNet (ReceiveMessage next) (m:ms) = ("<", Just m):runPure (next m) ms
runNet (SendBytes _ _ next) ms = ("> bytes", Nothing):runPure next ms
runNet (ReceiveBytes _ next) ms = ("< bytes", Nothing):runPure (next L.empty) ms
+runNet (CheckAuthToken _ _ next) ms = runPure (next True) ms
runNet (Relay _ _ next) ms = runPure (next ExitSuccess) ms
runNet (RelayService _ _ next) ms = runPure (next ExitSuccess) ms
runNet (WriteRelay _ _ next) ms = runPure next ms
@@ -211,7 +212,6 @@ runLocal :: Show r => LocalF (Proto r) -> [Message] -> [(String, Maybe Message)]
runLocal (KeyFileSize _ next) ms = runPure (next (Len 100)) ms
runLocal (ReadKeyFile _ _ next) ms = runPure (next L.empty) ms
runLocal (WriteKeyFile _ _ _ _ next) ms = runPure (next True) ms
-runLocal (CheckAuthToken _ _ next) ms = runPure (next True) ms
runLocal (SetPresent _ _ next) ms = runPure next ms
runLocal (CheckContentPresent _ next) ms = runPure (next False) ms
runLocal (RemoveKeyFile _ next) ms = runPure (next True) ms
@@ -298,7 +298,7 @@ serve myuuid = go Nothing
r <- net receiveMessage
case r of
AUTH theiruuid authtoken -> do
- ok <- local $ checkAuthToken theiruuid authtoken
+ ok <- net $ checkAuthToken theiruuid authtoken
if ok
then do
net $ sendMessage (AUTH_SUCCESS myuuid)
diff --git a/Remote/Helper/P2P/IO.hs b/Remote/Helper/P2P/IO.hs
index 82ba2d6f9..6908fd68c 100644
--- a/Remote/Helper/P2P/IO.hs
+++ b/Remote/Helper/P2P/IO.hs
@@ -14,6 +14,7 @@ module Remote.Helper.P2P.IO
import Remote.Helper.P2P
import Utility.Process
+import Types.UUID
import Git
import Git.Command
import Utility.SafeCommand
@@ -33,39 +34,46 @@ type RunProto = forall a m. MonadIO m => Proto a -> m a
data S = S
{ repo :: Repo
- , hdl :: Handle
+ , ihdl :: Handle
+ , ohdl :: Handle
}
-- Implementation of the protocol, communicating with a peer
-- over a Handle. No Local actions will be run.
-runNetProtoHandle :: MonadIO m => Handle -> Repo -> Proto a -> m a
-runNetProtoHandle h r = go
+runNetProtoHandle :: MonadIO m => Handle -> Handle -> Repo -> Proto a -> m a
+runNetProtoHandle i o r = go
where
go :: RunProto
go (Pure a) = pure a
- go (Free (Net n)) = runNetHandle (S r h) go n
+ go (Free (Net n)) = runNetHandle (S r i o) go n
go (Free (Local _)) = error "local actions not allowed"
runNetHandle :: MonadIO m => S -> RunProto -> NetF (Proto a) -> m a
runNetHandle s runner f = case f of
SendMessage m next -> do
liftIO $ do
- hPutStrLn (hdl s) (unwords (formatMessage m))
- hFlush (hdl s)
+ hPutStrLn (ohdl s) (unwords (formatMessage m))
+ hFlush (ohdl s)
runner next
ReceiveMessage next -> do
- l <- liftIO $ hGetLine (hdl s)
- let m = fromMaybe (ERROR "protocol parse error")
- (parseMessage l)
- runner (next m)
+ l <- liftIO $ hGetLine (ihdl s)
+ case parseMessage l of
+ Just m -> runner (next m)
+ Nothing -> runner $ do
+ let e = ERROR "protocol parse error"
+ net $ sendMessage e
+ next e
SendBytes _len b next -> do
liftIO $ do
- L.hPut (hdl s) b
- hFlush (hdl s)
+ L.hPut (ohdl s) b
+ hFlush (ohdl s)
runner next
ReceiveBytes (Len n) next -> do
- b <- liftIO $ L.hGet (hdl s) (fromIntegral n)
+ b <- liftIO $ L.hGet (ihdl s) (fromIntegral n)
runner (next b)
+ CheckAuthToken u t next -> do
+ authed <- return True -- TODO XXX FIXME really check
+ runner (next authed)
Relay hout callback next ->
runRelay runner hout callback >>= runner . next
RelayService service callback next ->