0f4ee4f298I'm unsure why this fixed it, but it did. Seems to suggest that the memory leak is not due to a bug in my code, but that ghc didn't manage to take full advantage of laziness, or was failing to gc something it could have.
133 lines
3.9 KiB
Haskell
133 lines
3.9 KiB
Haskell
{- P2P protocol, Annex implementation
|
|
-
|
|
- Copyright 2016 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE RankNTypes, FlexibleContexts #-}
|
|
|
|
module P2P.Annex
|
|
( RunMode(..)
|
|
, P2PConnection(..)
|
|
, runFullProto
|
|
) where
|
|
|
|
import Annex.Common
|
|
import Annex.Content
|
|
import Annex.Transfer
|
|
import P2P.Protocol
|
|
import P2P.IO
|
|
import Logs.Location
|
|
import Types.NumCopies
|
|
|
|
import Control.Monad.Free
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
-- When we're serving a peer, we know their uuid, and can use it to update
|
|
-- transfer logs.
|
|
data RunMode
|
|
= Serving UUID
|
|
| Client
|
|
|
|
-- Full interpreter for Proto, that can receive and send objects.
|
|
runFullProto :: RunMode -> P2PConnection -> Proto a -> Annex (Either String a)
|
|
runFullProto runmode conn = go
|
|
where
|
|
go :: RunProto Annex
|
|
go (Pure v) = pure (Right v)
|
|
go (Free (Net n)) = runNet conn go n
|
|
go (Free (Local l)) = runLocal runmode go l
|
|
|
|
runLocal :: RunMode -> RunProto Annex -> LocalF (Proto a) -> Annex (Either String a)
|
|
runLocal runmode runner a = case a of
|
|
TmpContentSize k next -> do
|
|
tmp <- fromRepo $ gitAnnexTmpObjectLocation k
|
|
size <- liftIO $ catchDefaultIO 0 $ getFileSize tmp
|
|
runner (next (Len size))
|
|
FileSize f next -> do
|
|
size <- liftIO $ catchDefaultIO 0 $ getFileSize f
|
|
runner (next (Len size))
|
|
ContentSize k next -> do
|
|
let getsize = liftIO . catchMaybeIO . getFileSize
|
|
size <- inAnnex' isJust Nothing getsize k
|
|
runner (next (Len <$> size))
|
|
-- 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
|
|
-- content is sent, but we don't use it.
|
|
-- Instead, the receiving peer must AlwaysVerify
|
|
-- the content it receives.
|
|
Right (Just (f, _check)) -> do
|
|
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 e -> return (Left (show e))
|
|
Right b -> runner (next b)
|
|
Right Nothing -> return (Left "content not available")
|
|
Left e -> return (Left (show e))
|
|
StoreContent k af o l getb next -> do
|
|
ok <- flip catchNonAsync (const $ return False) $
|
|
transfer download k af $
|
|
getViaTmp AlwaysVerify k $ \tmp ->
|
|
unVerified $ storefile tmp o l getb
|
|
runner (next ok)
|
|
StoreContentTo dest o l getb next -> do
|
|
ok <- flip catchNonAsync (const $ return False) $
|
|
storefile dest o l getb
|
|
runner (next ok)
|
|
SetPresent k u next -> do
|
|
v <- tryNonAsync $ logChange k u InfoPresent
|
|
case v of
|
|
Left e -> return (Left (show e))
|
|
Right () -> runner next
|
|
CheckContentPresent k next -> do
|
|
v <- tryNonAsync $ inAnnex k
|
|
case v of
|
|
Left e -> return (Left (show e))
|
|
Right result -> runner (next result)
|
|
RemoveContent k next -> do
|
|
v <- tryNonAsync $ lockContentForRemoval k $ \contentlock -> do
|
|
removeAnnex contentlock
|
|
logStatus k InfoMissing
|
|
return True
|
|
case v of
|
|
Left e -> return (Left (show e))
|
|
Right result -> runner (next result)
|
|
TryLockContent k protoaction next -> do
|
|
v <- tryNonAsync $ lockContentShared k $ \verifiedcopy ->
|
|
case verifiedcopy of
|
|
LockedCopy _ -> runner (protoaction True)
|
|
_ -> runner (protoaction False)
|
|
-- If locking fails, lockContentShared throws an exception.
|
|
-- Let the peer know it failed.
|
|
case v of
|
|
Left _ -> runner $ do
|
|
protoaction False
|
|
next
|
|
Right _ -> runner next
|
|
where
|
|
transfer mk k af ta = case runmode of
|
|
-- Update transfer logs when serving.
|
|
Serving theiruuid ->
|
|
mk theiruuid k af noRetry (const ta) noNotification
|
|
-- Transfer logs are updated higher in the stack when
|
|
-- a client.
|
|
Client -> ta
|
|
storefile dest (Offset o) (Len l) getb = do
|
|
v <- runner getb
|
|
case v of
|
|
Right b -> liftIO $ do
|
|
withBinaryFile dest ReadWriteMode $ \h -> do
|
|
when (o /= 0) $
|
|
hSeek h AbsoluteSeek o
|
|
L.hPut h b
|
|
sz <- liftIO $ getFileSize dest
|
|
return (toInteger sz == l + o)
|
|
Left e -> error e
|