1{- P2P protocol 2 - 3 - See doc/design/p2p_protocol.mdwn 4 - 5 - Copyright 2016-2021 Joey Hess <id@joeyh.name> 6 - 7 - Licensed under the GNU AGPL version 3 or higher. 8 -} 9 10{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} 11{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes #-} 12{-# OPTIONS_GHC -fno-warn-orphans #-} 13 14module P2P.Protocol where 15 16import qualified Utility.SimpleProtocol as Proto 17import Types (Annex) 18import Types.Key 19import Types.UUID 20import Types.Transfer 21import Types.Remote (Verification(..)) 22import Utility.Hash (IncrementalVerifier(..)) 23import Utility.AuthToken 24import Utility.Applicative 25import Utility.PartialPrelude 26import Utility.Metered 27import Utility.FileSystemEncoding 28import Git.FilePath 29import Annex.ChangedRefs (ChangedRefs) 30 31import Control.Monad 32import Control.Monad.Free 33import Control.Monad.Free.TH 34import Control.Monad.Catch 35import System.FilePath 36import System.Exit (ExitCode(..)) 37import System.IO 38import qualified Data.ByteString.Lazy as L 39import Data.Char 40import Control.Applicative 41import Prelude 42 43newtype Offset = Offset Integer 44 deriving (Show) 45 46newtype Len = Len Integer 47 deriving (Show) 48 49newtype ProtocolVersion = ProtocolVersion Integer 50 deriving (Show, Eq, Ord) 51 52defaultProtocolVersion :: ProtocolVersion 53defaultProtocolVersion = ProtocolVersion 0 54 55maxProtocolVersion :: ProtocolVersion 56maxProtocolVersion = ProtocolVersion 1 57 58newtype ProtoAssociatedFile = ProtoAssociatedFile AssociatedFile 59 deriving (Show) 60 61-- | Service as used by the connect message in gitremote-helpers(1) 62data Service = UploadPack | ReceivePack 63 deriving (Show) 64 65data Validity = Valid | Invalid 66 deriving (Show) 67 68-- | Messages in the protocol. The peer that makes the connection 69-- always initiates requests, and the other peer makes responses to them. 70data Message 71 = AUTH UUID AuthToken -- uuid of the peer that is authenticating 72 | AUTH_SUCCESS UUID -- uuid of the remote peer 73 | AUTH_FAILURE 74 | VERSION ProtocolVersion 75 | CONNECT Service 76 | CONNECTDONE ExitCode 77 | NOTIFYCHANGE 78 | CHANGED ChangedRefs 79 | CHECKPRESENT Key 80 | LOCKCONTENT Key 81 | UNLOCKCONTENT 82 | REMOVE Key 83 | GET Offset ProtoAssociatedFile Key 84 | PUT ProtoAssociatedFile Key 85 | PUT_FROM Offset 86 | ALREADY_HAVE 87 | SUCCESS 88 | FAILURE 89 | DATA Len -- followed by bytes of data 90 | VALIDITY Validity 91 | ERROR String 92 deriving (Show) 93 94instance Proto.Sendable Message where 95 formatMessage (AUTH uuid authtoken) = ["AUTH", Proto.serialize uuid, Proto.serialize authtoken] 96 formatMessage (AUTH_SUCCESS uuid) = ["AUTH-SUCCESS", Proto.serialize uuid] 97 formatMessage AUTH_FAILURE = ["AUTH-FAILURE"] 98 formatMessage (VERSION v) = ["VERSION", Proto.serialize v] 99 formatMessage (CONNECT service) = ["CONNECT", Proto.serialize service] 100 formatMessage (CONNECTDONE exitcode) = ["CONNECTDONE", Proto.serialize exitcode] 101 formatMessage NOTIFYCHANGE = ["NOTIFYCHANGE"] 102 formatMessage (CHANGED refs) = ["CHANGED", Proto.serialize refs] 103 formatMessage (CHECKPRESENT key) = ["CHECKPRESENT", Proto.serialize key] 104 formatMessage (LOCKCONTENT key) = ["LOCKCONTENT", Proto.serialize key] 105 formatMessage UNLOCKCONTENT = ["UNLOCKCONTENT"] 106 formatMessage (REMOVE key) = ["REMOVE", Proto.serialize key] 107 formatMessage (GET offset af key) = ["GET", Proto.serialize offset, Proto.serialize af, Proto.serialize key] 108 formatMessage (PUT af key) = ["PUT", Proto.serialize af, Proto.serialize key] 109 formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset] 110 formatMessage ALREADY_HAVE = ["ALREADY-HAVE"] 111 formatMessage SUCCESS = ["SUCCESS"] 112 formatMessage FAILURE = ["FAILURE"] 113 formatMessage (VALIDITY Valid) = ["VALID"] 114 formatMessage (VALIDITY Invalid) = ["INVALID"] 115 formatMessage (DATA len) = ["DATA", Proto.serialize len] 116 formatMessage (ERROR err) = ["ERROR", Proto.serialize err] 117 118instance Proto.Receivable Message where 119 parseCommand "AUTH" = Proto.parse2 AUTH 120 parseCommand "AUTH-SUCCESS" = Proto.parse1 AUTH_SUCCESS 121 parseCommand "AUTH-FAILURE" = Proto.parse0 AUTH_FAILURE 122 parseCommand "VERSION" = Proto.parse1 VERSION 123 parseCommand "CONNECT" = Proto.parse1 CONNECT 124 parseCommand "CONNECTDONE" = Proto.parse1 CONNECTDONE 125 parseCommand "NOTIFYCHANGE" = Proto.parse0 NOTIFYCHANGE 126 parseCommand "CHANGED" = Proto.parse1 CHANGED 127 parseCommand "CHECKPRESENT" = Proto.parse1 CHECKPRESENT 128 parseCommand "LOCKCONTENT" = Proto.parse1 LOCKCONTENT 129 parseCommand "UNLOCKCONTENT" = Proto.parse0 UNLOCKCONTENT 130 parseCommand "REMOVE" = Proto.parse1 REMOVE 131 parseCommand "GET" = Proto.parse3 GET 132 parseCommand "PUT" = Proto.parse2 PUT 133 parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM 134 parseCommand "ALREADY-HAVE" = Proto.parse0 ALREADY_HAVE 135 parseCommand "SUCCESS" = Proto.parse0 SUCCESS 136 parseCommand "FAILURE" = Proto.parse0 FAILURE 137 parseCommand "DATA" = Proto.parse1 DATA 138 parseCommand "ERROR" = Proto.parse1 ERROR 139 parseCommand "VALID" = Proto.parse0 (VALIDITY Valid) 140 parseCommand "INVALID" = Proto.parse0 (VALIDITY Invalid) 141 parseCommand _ = Proto.parseFail 142 143instance Proto.Serializable ProtocolVersion where 144 serialize (ProtocolVersion n) = show n 145 deserialize = ProtocolVersion <$$> readish 146 147instance Proto.Serializable Offset where 148 serialize (Offset n) = show n 149 deserialize = Offset <$$> readish 150 151instance Proto.Serializable Len where 152 serialize (Len n) = show n 153 deserialize = Len <$$> readish 154 155instance Proto.Serializable Service where 156 serialize UploadPack = "git-upload-pack" 157 serialize ReceivePack = "git-receive-pack" 158 deserialize "git-upload-pack" = Just UploadPack 159 deserialize "git-receive-pack" = Just ReceivePack 160 deserialize _ = Nothing 161 162-- | Since ProtoAssociatedFile is not the last thing in a protocol line, 163-- its serialization cannot contain any whitespace. This is handled 164-- by replacing whitespace with '%' (and '%' with '%%') 165-- 166-- When deserializing an AssociatedFile from a peer, it's sanitized, 167-- to avoid any unusual characters that might cause problems when it's 168-- displayed to the user. 169-- 170-- These mungings are ok, because a ProtoAssociatedFile is only ever displayed 171-- to the user and does not need to match a file on disk. 172instance Proto.Serializable ProtoAssociatedFile where 173 serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = "" 174 serialize (ProtoAssociatedFile (AssociatedFile (Just af))) = 175 decodeBS $ toInternalGitPath $ encodeBS $ concatMap esc $ fromRawFilePath af 176 where 177 esc '%' = "%%" 178 esc c 179 | isSpace c = "%" 180 | otherwise = [c] 181 182 deserialize s = case fromRawFilePath $ fromInternalGitPath $ toRawFilePath $ deesc [] s of 183 [] -> Just $ ProtoAssociatedFile $ AssociatedFile Nothing 184 f 185 | isRelative f -> Just $ ProtoAssociatedFile $ 186 AssociatedFile $ Just $ toRawFilePath f 187 | otherwise -> Nothing 188 where 189 deesc b [] = reverse b 190 deesc b ('%':'%':cs) = deesc ('%':b) cs 191 deesc b ('%':cs) = deesc ('_':b) cs 192 deesc b (c:cs) 193 | isControl c = deesc ('_':b) cs 194 | otherwise = deesc (c:b) cs 195 196-- | Free monad for the protocol, combining net communication, 197-- and local actions. 198data ProtoF c = Net (NetF c) | Local (LocalF c) 199 deriving (Functor) 200 201type Proto = Free ProtoF 202 203net :: Net a -> Proto a 204net = hoistFree Net 205 206local :: Local a -> Proto a 207local = hoistFree Local 208 209data NetF c 210 = SendMessage Message c 211 | ReceiveMessage (Maybe Message -> c) 212 | SendBytes Len L.ByteString MeterUpdate c 213 -- ^ Sends exactly Len bytes of data. (Any more or less will 214 -- confuse the receiver.) 215 | ReceiveBytes Len MeterUpdate (L.ByteString -> c) 216 -- ^ Lazily reads bytes from peer. Stops once Len are read, 217 -- or if connection is lost, and in either case returns the bytes 218 -- that were read. This allows resuming interrupted transfers. 219 | CheckAuthToken UUID AuthToken (Bool -> c) 220 | RelayService Service c 221 -- ^ Runs a service, relays its output to the peer, and data 222 -- from the peer to it. 223 | Relay RelayHandle RelayHandle (ExitCode -> c) 224 -- ^ Reads from the first RelayHandle, and sends the data to a 225 -- peer, while at the same time accepting input from the peer 226 -- which is sent the the second RelayHandle. Continues until 227 -- the peer sends an ExitCode. 228 | SetProtocolVersion ProtocolVersion c 229 --- ^ Called when a new protocol version has been negotiated. 230 | GetProtocolVersion (ProtocolVersion -> c) 231 deriving (Functor) 232 233type Net = Free NetF 234 235newtype RelayHandle = RelayHandle Handle 236 237data LocalF c 238 = TmpContentSize Key (Len -> c) 239 -- ^ Gets size of the temp file where received content may have 240 -- been stored. If not present, returns 0. 241 | FileSize FilePath (Len -> c) 242 -- ^ Gets size of the content of a file. If not present, returns 0. 243 | ContentSize Key (Maybe Len -> c) 244 -- ^ Gets size of the content of a key, when the full content is 245 -- present. 246 | ReadContent Key AssociatedFile Offset (L.ByteString -> Proto Validity -> Proto Bool) (Bool -> c) 247 -- ^ Reads the content of a key and sends it to the callback. 248 -- Must run the callback, or terminate the protocol connection. 249 -- 250 -- May send any amount of data, including L.empty if the content is 251 -- not available. The callback must deal with that. 252 -- 253 -- And the content may change while it's being sent. 254 -- The callback is passed a validity check that it can run after 255 -- sending the content to detect when this happened. 256 | StoreContent Key AssociatedFile Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) (Bool -> c) 257 -- ^ Stores content to the key's temp file starting at an offset. 258 -- Once the whole content of the key has been stored, moves the 259 -- temp file into place as the content of the key, and returns True. 260 -- 261 -- Must consume the whole lazy ByteString, or if unable to do 262 -- so, terminate the protocol connection. 263 -- 264 -- If the validity check is provided and fails, the content was 265 -- changed while it was being sent, so verificiation of the 266 -- received content should be forced. 267 -- 268 -- Note: The ByteString may not contain the entire remaining content 269 -- of the key. Only once the temp file size == Len has the whole 270 -- content been transferred. 271 | StoreContentTo FilePath (Maybe IncrementalVerifier) Offset Len (Proto L.ByteString) (Proto (Maybe Validity)) ((Bool, Verification) -> c) 272 -- ^ Like StoreContent, but stores the content to a temp file. 273 | SetPresent Key UUID c 274 | CheckContentPresent Key (Bool -> c) 275 -- ^ Checks if the whole content of the key is locally present. 276 | RemoveContent Key (Bool -> c) 277 -- ^ If the content is not present, still succeeds. 278 -- May fail if not enough copies to safely drop, etc. 279 | TryLockContent Key (Bool -> Proto ()) c 280 -- ^ Try to lock the content of a key, preventing it 281 -- from being deleted, while running the provided protocol 282 -- action. If unable to lock the content, or the content is not 283 -- present, runs the protocol action with False. 284 | WaitRefChange (ChangedRefs -> c) 285 -- ^ Waits for one or more git refs to change and returns them.a 286 | UpdateMeterTotalSize Meter TotalSize c 287 -- ^ Updates the total size of a Meter, for cases where the size is 288 -- not known until the data is being received. 289 | RunValidityCheck (Annex Validity) (Validity -> c) 290 -- ^ Runs a deferred validity check. 291 deriving (Functor) 292 293type Local = Free LocalF 294 295-- Generate sendMessage etc functions for all free monad constructors. 296$(makeFree ''NetF) 297$(makeFree ''LocalF) 298 299auth :: UUID -> AuthToken -> Proto () -> Proto (Maybe UUID) 300auth myuuid t a = do 301 net $ sendMessage (AUTH myuuid t) 302 postAuth a 303 304postAuth :: Proto () -> Proto (Maybe UUID) 305postAuth a = do 306 r <- net receiveMessage 307 case r of 308 Just (AUTH_SUCCESS theiruuid) -> do 309 a 310 return $ Just theiruuid 311 Just AUTH_FAILURE -> return Nothing 312 _ -> do 313 net $ sendMessage (ERROR "auth failed") 314 return Nothing 315 316negotiateProtocolVersion :: ProtocolVersion -> Proto () 317negotiateProtocolVersion preferredversion = do 318 net $ sendMessage (VERSION preferredversion) 319 r <- net receiveMessage 320 case r of 321 Just (VERSION v) -> net $ setProtocolVersion v 322 -- Old server doesn't know about the VERSION command. 323 Just (ERROR _) -> return () 324 _ -> net $ sendMessage (ERROR "expected VERSION") 325 326checkPresent :: Key -> Proto Bool 327checkPresent key = do 328 net $ sendMessage (CHECKPRESENT key) 329 checkSuccess 330 331{- Locks content to prevent it from being dropped, while running an action. 332 - 333 - Note that this only guarantees that the content is locked as long as the 334 - connection to the peer remains up. If the connection is unexpectededly 335 - dropped, the peer will then unlock the content. 336 -} 337lockContentWhile 338 :: MonadMask m 339 => (forall r. r -> Proto r -> m r) 340 -> Key 341 -> (Bool -> m a) 342 -> m a 343lockContentWhile runproto key a = bracket setup cleanup a 344 where 345 setup = runproto False $ do 346 net $ sendMessage (LOCKCONTENT key) 347 checkSuccess 348 cleanup True = runproto () $ net $ sendMessage UNLOCKCONTENT 349 cleanup False = return () 350 351remove :: Key -> Proto Bool 352remove key = do 353 net $ sendMessage (REMOVE key) 354 checkSuccess 355 356get :: FilePath -> Key -> Maybe IncrementalVerifier -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification) 357get dest key iv af m p = 358 receiveContent (Just m) p sizer storer $ \offset -> 359 GET offset (ProtoAssociatedFile af) key 360 where 361 sizer = fileSize dest 362 storer = storeContentTo dest iv 363 364put :: Key -> AssociatedFile -> MeterUpdate -> Proto Bool 365put key af p = do 366 net $ sendMessage (PUT (ProtoAssociatedFile af) key) 367 r <- net receiveMessage 368 case r of 369 Just (PUT_FROM offset) -> sendContent key af offset p 370 Just ALREADY_HAVE -> return True 371 _ -> do 372 net $ sendMessage (ERROR "expected PUT_FROM or ALREADY_HAVE") 373 return False 374 375data ServerHandler a 376 = ServerGot a 377 | ServerContinue 378 | ServerUnexpected 379 380-- Server loop, getting messages from the client and handling them 381serverLoop :: (Message -> Proto (ServerHandler a)) -> Proto (Maybe a) 382serverLoop a = do 383 mcmd <- net receiveMessage 384 case mcmd of 385 -- When the client sends ERROR to the server, the server 386 -- gives up, since it's not clear what state the client 387 -- is in, and so not possible to recover. 388 Just (ERROR _) -> return Nothing 389 -- When the client sends an unparseable message, the server 390 -- responds with an error message, and loops. This allows 391 -- expanding the protocol with new messages. 392 Nothing -> do 393 net $ sendMessage (ERROR "unknown command") 394 serverLoop a 395 Just cmd -> do 396 v <- a cmd 397 case v of 398 ServerGot r -> return (Just r) 399 ServerContinue -> serverLoop a 400 -- If the client sends an unexpected message, 401 -- the server will respond with ERROR, and 402 -- always continues processing messages. 403 -- 404 -- Since the protocol is not versioned, this 405 -- is necessary to handle protocol changes 406 -- robustly, since the client can detect when 407 -- it's talking to a server that does not 408 -- support some new feature, and fall back. 409 ServerUnexpected -> do 410 net $ sendMessage (ERROR "unexpected command") 411 serverLoop a 412 413-- | Serve the protocol, with an unauthenticated peer. Once the peer 414-- successfully authenticates, returns their UUID. 415serveAuth :: UUID -> Proto (Maybe UUID) 416serveAuth myuuid = serverLoop handler 417 where 418 handler (AUTH theiruuid authtoken) = do 419 ok <- net $ checkAuthToken theiruuid authtoken 420 if ok 421 then do 422 net $ sendMessage (AUTH_SUCCESS myuuid) 423 return (ServerGot theiruuid) 424 else do 425 net $ sendMessage AUTH_FAILURE 426 return ServerContinue 427 handler _ = return ServerUnexpected 428 429data ServerMode 430 = ServeReadOnly 431 -- ^ Allow reading, but not writing. 432 | ServeAppendOnly 433 -- ^ Allow reading, and storing new objects, but not deleting objects. 434 | ServeReadWrite 435 -- ^ Full read and write access. 436 deriving (Eq, Ord) 437 438-- | Serve the protocol, with a peer that has authenticated. 439serveAuthed :: ServerMode -> UUID -> Proto () 440serveAuthed servermode myuuid = void $ serverLoop handler 441 where 442 readonlyerror = net $ sendMessage (ERROR "this repository is read-only; write access denied") 443 appendonlyerror = net $ sendMessage (ERROR "this repository is append-only; removal denied") 444 handler (VERSION theirversion) = do 445 let v = min theirversion maxProtocolVersion 446 net $ setProtocolVersion v 447 net $ sendMessage (VERSION v) 448 return ServerContinue 449 handler (LOCKCONTENT key) = do 450 local $ tryLockContent key $ \locked -> do 451 sendSuccess locked 452 when locked $ do 453 r' <- net receiveMessage 454 case r' of 455 Just UNLOCKCONTENT -> return () 456 _ -> net $ sendMessage (ERROR "expected UNLOCKCONTENT") 457 return ServerContinue 458 handler (CHECKPRESENT key) = do 459 sendSuccess =<< local (checkContentPresent key) 460 return ServerContinue 461 handler (REMOVE key) = case servermode of 462 ServeReadWrite -> do 463 sendSuccess =<< local (removeContent key) 464 return ServerContinue 465 ServeAppendOnly -> do 466 appendonlyerror 467 return ServerContinue 468 ServeReadOnly -> do 469 readonlyerror 470 return ServerContinue 471 handler (PUT (ProtoAssociatedFile af) key) = case servermode of 472 ServeReadWrite -> handleput af key 473 ServeAppendOnly -> handleput af key 474 ServeReadOnly -> do 475 readonlyerror 476 return ServerContinue 477 handler (GET offset (ProtoAssociatedFile af) key) = do 478 void $ sendContent key af offset nullMeterUpdate 479 -- setPresent not called because the peer may have 480 -- requested the data but not permanently stored it. 481 return ServerContinue 482 handler (CONNECT service) = do 483 let goahead = net $ relayService service 484 case (servermode, service) of 485 (ServeReadWrite, _) -> goahead 486 (ServeAppendOnly, UploadPack) -> goahead 487 -- git protocol could be used to overwrite 488 -- refs or something, so don't allow 489 (ServeAppendOnly, ReceivePack) -> readonlyerror 490 (ServeReadOnly, UploadPack) -> goahead 491 (ServeReadOnly, ReceivePack) -> readonlyerror 492 -- After connecting to git, there may be unconsumed data 493 -- from the git processes hanging around (even if they 494 -- exited successfully), so stop serving this connection. 495 return $ ServerGot () 496 handler NOTIFYCHANGE = do 497 refs <- local waitRefChange 498 net $ sendMessage (CHANGED refs) 499 return ServerContinue 500 handler _ = return ServerUnexpected 501 502 handleput af key = do 503 have <- local $ checkContentPresent key 504 if have 505 then net $ sendMessage ALREADY_HAVE 506 else do 507 let sizer = tmpContentSize key 508 let storer = storeContent key af 509 v <- receiveContent Nothing nullMeterUpdate sizer storer PUT_FROM 510 when (observeBool v) $ 511 local $ setPresent key myuuid 512 return ServerContinue 513 514sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool 515sendContent key af offset@(Offset n) p = go =<< local (contentSize key) 516 where 517 go (Just (Len totallen)) = do 518 let len = totallen - n 519 if len <= 0 520 then sender (Len 0) L.empty (return Valid) 521 else local $ readContent key af offset $ 522 sender (Len len) 523 -- Content not available to send. Indicate this by sending 524 -- empty data and indlicate it's invalid. 525 go Nothing = sender (Len 0) L.empty (return Invalid) 526 sender len content validitycheck = do 527 let p' = offsetMeterUpdate p (toBytesProcessed n) 528 net $ sendMessage (DATA len) 529 net $ sendBytes len content p' 530 ver <- net getProtocolVersion 531 when (ver >= ProtocolVersion 1) $ 532 net . sendMessage . VALIDITY =<< validitycheck 533 checkSuccess 534 535receiveContent 536 :: Observable t 537 => Maybe Meter 538 -> MeterUpdate 539 -> Local Len 540 -> (Offset -> Len -> Proto L.ByteString -> Proto (Maybe Validity) -> Local t) 541 -> (Offset -> Message) 542 -> Proto t 543receiveContent mm p sizer storer mkmsg = do 544 Len n <- local sizer 545 let p' = offsetMeterUpdate p (toBytesProcessed n) 546 let offset = Offset n 547 net $ sendMessage (mkmsg offset) 548 r <- net receiveMessage 549 case r of 550 Just (DATA len@(Len l)) -> do 551 local $ case mm of 552 Nothing -> return () 553 Just m -> updateMeterTotalSize m (TotalSize (n+l)) 554 ver <- net getProtocolVersion 555 let validitycheck = if ver >= ProtocolVersion 1 556 then net receiveMessage >>= \case 557 Just (VALIDITY v) -> return (Just v) 558 _ -> do 559 net $ sendMessage (ERROR "expected VALID or INVALID") 560 return Nothing 561 else return Nothing 562 v <- local $ storer offset len 563 (net (receiveBytes len p')) 564 validitycheck 565 sendSuccess (observeBool v) 566 return v 567 _ -> do 568 net $ sendMessage (ERROR "expected DATA") 569 return observeFailure 570 571checkSuccess :: Proto Bool 572checkSuccess = do 573 ack <- net receiveMessage 574 case ack of 575 Just SUCCESS -> return True 576 Just FAILURE -> return False 577 _ -> do 578 net $ sendMessage (ERROR "expected SUCCESS or FAILURE") 579 return False 580 581sendSuccess :: Bool -> Proto () 582sendSuccess True = net $ sendMessage SUCCESS 583sendSuccess False = net $ sendMessage FAILURE 584 585notifyChange :: Proto (Maybe ChangedRefs) 586notifyChange = do 587 net $ sendMessage NOTIFYCHANGE 588 ack <- net receiveMessage 589 case ack of 590 Just (CHANGED rs) -> return (Just rs) 591 _ -> do 592 net $ sendMessage (ERROR "expected CHANGED") 593 return Nothing 594 595connect :: Service -> Handle -> Handle -> Proto ExitCode 596connect service hin hout = do 597 net $ sendMessage (CONNECT service) 598 net $ relay (RelayHandle hin) (RelayHandle hout) 599 600data RelayData 601 = RelayToPeer L.ByteString 602 | RelayFromPeer L.ByteString 603 | RelayDone ExitCode 604 deriving (Show) 605 606relayFromPeer :: Net RelayData 607relayFromPeer = do 608 r <- receiveMessage 609 case r of 610 Just (CONNECTDONE exitcode) -> return $ RelayDone exitcode 611 Just (DATA len) -> RelayFromPeer <$> receiveBytes len nullMeterUpdate 612 _ -> do 613 sendMessage $ ERROR "expected DATA or CONNECTDONE" 614 return $ RelayDone $ ExitFailure 1 615 616relayToPeer :: RelayData -> Net () 617relayToPeer (RelayDone exitcode) = sendMessage (CONNECTDONE exitcode) 618relayToPeer (RelayToPeer b) = do 619 let len = Len $ fromIntegral $ L.length b 620 sendMessage (DATA len) 621 sendBytes len b nullMeterUpdate 622relayToPeer (RelayFromPeer _) = return () 623