diff options
Diffstat (limited to 'P2P/Protocol.hs')
| -rw-r--r-- | P2P/Protocol.hs | 55 |
1 files changed, 36 insertions, 19 deletions
diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index f762c3783..c750ae6ff 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -1,5 +1,7 @@ {- P2P protocol - + - See doc/design/p2p_protocol.mdwn + - - Copyright 2016 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. @@ -233,8 +235,8 @@ data LocalF c | TryLockContent Key (Bool -> Proto ()) c -- ^ Try to lock the content of a key, preventing it -- from being deleted, while running the provided protocol - -- action. If unable to lock the content, runs the protocol action - -- with False. + -- action. If unable to lock the content, or the content is not + -- present, runs the protocol action with False. | WaitRefChange (ChangedRefs -> c) -- ^ Waits for one or more git refs to change and returns them. deriving (Functor) @@ -351,10 +353,13 @@ serveAuth myuuid = serverLoop handler return ServerContinue handler _ = return ServerUnexpected +data ServerMode = ServeReadOnly | ServeReadWrite + -- | Serve the protocol, with a peer that has authenticated. -serveAuthed :: UUID -> Proto () -serveAuthed myuuid = void $ serverLoop handler +serveAuthed :: ServerMode -> UUID -> Proto () +serveAuthed servermode myuuid = void $ serverLoop handler where + readonlyerror = net $ sendMessage (ERROR "this repository is read-only; write access denied") handler (LOCKCONTENT key) = do local $ tryLockContent key $ \locked -> do sendSuccess locked @@ -367,27 +372,39 @@ serveAuthed myuuid = void $ serverLoop handler handler (CHECKPRESENT key) = do sendSuccess =<< local (checkContentPresent key) return ServerContinue - handler (REMOVE key) = do - sendSuccess =<< local (removeContent key) - return ServerContinue - handler (PUT af key) = do - have <- local $ checkContentPresent key - if have - then net $ sendMessage ALREADY_HAVE - else do - let sizer = tmpContentSize key - let storer = storeContent key af - ok <- receiveContent nullMeterUpdate sizer storer PUT_FROM - when ok $ - local $ setPresent key myuuid - return ServerContinue + handler (REMOVE key) = case servermode of + ServeReadWrite -> do + sendSuccess =<< local (removeContent key) + return ServerContinue + ServeReadOnly -> do + readonlyerror + return ServerContinue + handler (PUT af key) = case servermode of + ServeReadWrite -> do + have <- local $ checkContentPresent key + if have + then net $ sendMessage ALREADY_HAVE + else do + let sizer = tmpContentSize key + let storer = storeContent key af + ok <- receiveContent nullMeterUpdate sizer storer PUT_FROM + when ok $ + local $ setPresent key myuuid + return ServerContinue + ServeReadOnly -> do + readonlyerror + return ServerContinue handler (GET offset key af) = do void $ sendContent af key offset nullMeterUpdate -- setPresent not called because the peer may have -- requested the data but not permanently stored it. return ServerContinue handler (CONNECT service) = do - net $ relayService service + let goahead = net $ relayService service + case (servermode, service) of + (ServeReadWrite, _) -> goahead + (ServeReadOnly, UploadPack) -> goahead + (ServeReadOnly, ReceivePack) -> readonlyerror -- After connecting to git, there may be unconsumed data -- from the git processes hanging around (even if they -- exited successfully), so stop serving this connection. |