From 26a3156541e655ca6a32bbccff79326b045fb531 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 2 Dec 2016 16:39:01 -0400 Subject: plumb assicated files through P2P protocol for updating transfer logs ReadContent can't update the log, since it reads lazily. This part of the P2P monad will need to be rethought. Associated files are heavily sanitized when received from a peer; they could be an exploit vector. This commit was sponsored by Jochen Bartl on Patreon. --- P2P/Annex.hs | 43 ++++++++++++++++---------- P2P/Protocol.hs | 94 ++++++++++++++++++++++++++++++++++++++++----------------- 2 files changed, 93 insertions(+), 44 deletions(-) (limited to 'P2P') diff --git a/P2P/Annex.hs b/P2P/Annex.hs index dce4ceeba..5e1763fc6 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -15,6 +15,8 @@ module P2P.Annex import Annex.Common import Annex.Content +import Annex.Transfer +import Annex.Notification import P2P.Protocol import P2P.IO import Logs.Location @@ -48,8 +50,8 @@ runLocal runmode runner a = case a of let getsize = liftIO . catchMaybeIO . getFileSize size <- inAnnex' isJust Nothing getsize k runner (next (Len <$> size)) - -- TODO transfer logs - ReadContent k (Offset o) next -> do + -- TODO transfer log not updated + ReadContent k af (Offset o) next -> do v <- tryNonAsync $ prepSendAnnex k case v of -- The check can detect a problem after the @@ -57,25 +59,26 @@ runLocal runmode runner a = case a of -- Instead, the receiving peer must AlwaysVerify -- the content it receives. Right (Just (f, _check)) -> do - v' <- liftIO $ tryNonAsync $ do - h <- openBinaryFile f ReadMode - when (o /= 0) $ - hSeek h AbsoluteSeek o - L.hGetContents h + v' <- tryNonAsync $ -- transfer upload k af $ + liftIO $ do + h <- openBinaryFile f ReadMode + when (o /= 0) $ + hSeek h AbsoluteSeek o + L.hGetContents h case v' of Left _ -> return Nothing Right b -> runner (next b) _ -> return Nothing - -- TODO transfer logs - WriteContent k (Offset o) (Len l) b next -> do + WriteContent k af (Offset o) (Len l) b next -> do ok <- flip catchNonAsync (const $ return False) $ - getViaTmp AlwaysVerify k $ \tmp -> liftIO $ do - withBinaryFile tmp WriteMode $ \h -> do - when (o /= 0) $ - hSeek h AbsoluteSeek o - L.hPut h b - sz <- getFileSize tmp - return (toInteger sz == l, UnVerified) + transfer download k af $ + getViaTmp AlwaysVerify k $ \tmp -> liftIO $ do + withBinaryFile tmp WriteMode $ \h -> do + when (o /= 0) $ + hSeek h AbsoluteSeek o + L.hPut h b + sz <- getFileSize tmp + return (toInteger sz == l, UnVerified) runner (next ok) SetPresent k u next -> do v <- tryNonAsync $ logChange k u InfoPresent @@ -107,3 +110,11 @@ runLocal runmode runner a = case a of protoaction False next Right _ -> runner next + where + transfer mk k af a = case runmode of + -- Update transfer logs when serving. + Serving theiruuid -> + mk theiruuid k af noRetry (const a) noNotification + -- Transfer logs are updated higher in the stack when + -- a client. + Client -> a diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index 9678b7954..53c3265ef 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -5,7 +5,9 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts, RankNTypes #-} +{-# LANGUAGE DeriveFunctor, TemplateHaskell, FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module P2P.Protocol where @@ -15,14 +17,17 @@ import Types.UUID import Utility.AuthToken import Utility.Applicative import Utility.PartialPrelude +import Git.FilePath import Control.Monad import Control.Monad.Free import Control.Monad.Free.TH import Control.Monad.Catch +import System.FilePath import System.Exit (ExitCode(..)) import System.IO import qualified Data.ByteString.Lazy as L +import Data.Char newtype Offset = Offset Integer deriving (Show) @@ -46,8 +51,8 @@ data Message | LOCKCONTENT Key | UNLOCKCONTENT | REMOVE Key - | GET Offset Key - | PUT Key + | GET Offset AssociatedFile Key + | PUT AssociatedFile Key | PUT_FROM Offset | ALREADY_HAVE | SUCCESS @@ -66,8 +71,8 @@ instance Proto.Sendable Message where formatMessage (LOCKCONTENT key) = ["LOCKCONTENT", Proto.serialize key] formatMessage UNLOCKCONTENT = ["UNLOCKCONTENT"] formatMessage (REMOVE key) = ["REMOVE", Proto.serialize key] - formatMessage (GET offset key) = ["GET", Proto.serialize offset, Proto.serialize key] - formatMessage (PUT key) = ["PUT", Proto.serialize key] + formatMessage (GET offset af key) = ["GET", Proto.serialize offset, Proto.serialize af, Proto.serialize key] + formatMessage (PUT af key) = ["PUT", Proto.serialize af, Proto.serialize key] formatMessage (PUT_FROM offset) = ["PUT-FROM", Proto.serialize offset] formatMessage ALREADY_HAVE = ["ALREADY-HAVE"] formatMessage SUCCESS = ["SUCCESS"] @@ -85,8 +90,8 @@ instance Proto.Receivable Message where parseCommand "LOCKCONTENT" = Proto.parse1 LOCKCONTENT parseCommand "UNLOCKCONTENT" = Proto.parse0 UNLOCKCONTENT parseCommand "REMOVE" = Proto.parse1 REMOVE - parseCommand "GET" = Proto.parse2 GET - parseCommand "PUT" = Proto.parse1 PUT + parseCommand "GET" = Proto.parse3 GET + parseCommand "PUT" = Proto.parse2 PUT parseCommand "PUT-FROM" = Proto.parse1 PUT_FROM parseCommand "ALREADY-HAVE" = Proto.parse0 ALREADY_HAVE parseCommand "SUCCESS" = Proto.parse0 SUCCESS @@ -110,6 +115,38 @@ instance Proto.Serializable Service where deserialize "git-receive-pack" = Just ReceivePack deserialize _ = Nothing +-- | Since AssociatedFile is not the last thing in a protocol line, +-- its serialization cannot contain any whitespace. This is handled +-- by replacing whitespace with '%' (and '%' with '%%') +-- +-- When deserializing an AssociatedFile from a peer, it's sanitized, +-- to avoid any unusual characters that might cause problems when it's +-- displayed to the user. +-- +-- These mungings are ok, because an AssociatedFile is only ever displayed +-- to the user and does not need to match a file on disk. +instance Proto.Serializable AssociatedFile where + serialize Nothing = "" + serialize (Just af) = toInternalGitPath $ concatMap esc af + where + esc '%' = "%%" + esc c + | isSpace c = "%" + | otherwise = [c] + + deserialize s = case fromInternalGitPath $ deesc [] s of + [] -> Just Nothing + f + | isRelative f -> Just (Just f) + | otherwise -> Nothing + where + deesc b [] = reverse b + deesc b ('%':'%':cs) = deesc ('%':b) cs + deesc b ('%':cs) = deesc ('_':b) cs + deesc b (c:cs) + | isControl c = deesc ('_':b) cs + | otherwise = deesc (c:b) cs + -- | Free monad for the protocol, combining net communication, -- and local actions. data ProtoF c = Net (NetF c) | Local (LocalF c) @@ -155,10 +192,10 @@ data LocalF c | ContentSize Key (Maybe Len -> c) -- ^ Gets size of the content of a key, when the full content is -- present. - | ReadContent Key Offset (L.ByteString -> c) + | ReadContent Key AssociatedFile Offset (L.ByteString -> c) -- ^ Lazily reads the content of a key. Note that the content -- may change while it's being sent. - | WriteContent Key Offset Len L.ByteString (Bool -> c) + | WriteContent Key AssociatedFile Offset Len L.ByteString (Bool -> c) -- ^ Writes content to temp file starting at an offset. -- Once the whole content of the key has been stored, moves the -- temp file into place and returns True. @@ -226,15 +263,15 @@ remove key = do net $ sendMessage (REMOVE key) checkSuccess -get :: Key -> Proto Bool -get key = receiveContent key (`GET` key) +get :: Key -> AssociatedFile -> Proto Bool +get key af = receiveContent key af (\offset -> GET offset af key) -put :: Key -> Proto Bool -put key = do - net $ sendMessage (PUT key) +put :: Key -> AssociatedFile -> Proto Bool +put key af = do + net $ sendMessage (PUT af key) r <- net receiveMessage case r of - PUT_FROM offset -> sendContent key offset + PUT_FROM offset -> sendContent key af offset ALREADY_HAVE -> return True _ -> do net $ sendMessage (ERROR "expected PUT_FROM") @@ -307,17 +344,17 @@ serveAuthed myuuid = void $ serverLoop handler handler (REMOVE key) = do sendSuccess =<< local (removeContent key) return ServerContinue - handler (PUT key) = do + handler (PUT af key) = do have <- local $ checkContentPresent key if have then net $ sendMessage ALREADY_HAVE else do - ok <- receiveContent key PUT_FROM + ok <- receiveContent key af PUT_FROM when ok $ local $ setPresent key myuuid return ServerContinue - handler (GET offset key) = do - void $ sendContent key offset + handler (GET offset key af) = do + void $ sendContent af key offset -- setPresent not called because the peer may have -- requested the data but not permanently stored it. return ServerContinue @@ -326,22 +363,22 @@ serveAuthed myuuid = void $ serverLoop handler return ServerContinue handler _ = return ServerUnexpected -sendContent :: Key -> Offset -> Proto Bool -sendContent key offset = do - (len, content) <- readContentLen key offset +sendContent :: Key -> AssociatedFile -> Offset -> Proto Bool +sendContent key af offset = do + (len, content) <- readContentLen key af offset net $ sendMessage (DATA len) net $ sendBytes len content checkSuccess -receiveContent :: Key -> (Offset -> Message) -> Proto Bool -receiveContent key mkmsg = do +receiveContent :: Key -> AssociatedFile -> (Offset -> Message) -> Proto Bool +receiveContent key af mkmsg = do Len n <- local $ tmpContentSize key let offset = Offset n net $ sendMessage (mkmsg offset) r <- net receiveMessage case r of DATA len -> do - ok <- local . writeContent key offset len + ok <- local . writeContent key af offset len =<< net (receiveBytes len) sendSuccess ok return ok @@ -366,8 +403,8 @@ sendSuccess False = net $ sendMessage FAILURE -- Reads content from an offset. The Len should correspond to -- the length of the ByteString, but to avoid buffering the content -- in memory, is gotten using contentSize. -readContentLen :: Key -> Offset -> Proto (Len, L.ByteString) -readContentLen key (Offset offset) = go =<< local (contentSize key) +readContentLen :: Key -> AssociatedFile -> Offset -> Proto (Len, L.ByteString) +readContentLen key af (Offset offset) = go =<< local (contentSize key) where go Nothing = return (Len 0, L.empty) go (Just (Len totallen)) = do @@ -375,7 +412,8 @@ readContentLen key (Offset offset) = go =<< local (contentSize key) if len <= 0 then return (Len 0, L.empty) else do - content <- local $ readContent key (Offset offset) + content <- local $ + readContent key af (Offset offset) return (Len len, content) connect :: Service -> Handle -> Handle -> Proto ExitCode -- cgit v1.2.3