f18740699e
Client side support for SUCCESS-PLUS and ALREADY-HAVE-PLUS is complete, when a PUT stores to additional repositories than the expected on, the location log is updated with the additional UUIDs that contain the content. Started implementing PUT fanout to multiple remotes for clusters. It is untested, and I fear fencepost errors in the relative offset calculations. And it is missing proxying for the protocol after DATA.
105 lines
2.6 KiB
Haskell
105 lines
2.6 KiB
Haskell
{- git-annex transfer types
|
|
-
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
module Types.Transfer (
|
|
module Types.Transfer,
|
|
module Types.Direction
|
|
) where
|
|
|
|
import Types
|
|
import Types.Remote (Verification(..))
|
|
import Types.Key
|
|
import Types.Direction
|
|
import Utility.PID
|
|
import Utility.QuickCheck
|
|
import Utility.Url
|
|
import Utility.FileSystemEncoding
|
|
|
|
import Data.Time.Clock.POSIX
|
|
import Control.Concurrent
|
|
import Control.Applicative
|
|
import Prelude
|
|
|
|
{- Enough information to uniquely identify a transfer. -}
|
|
data Transfer = Transfer
|
|
{ transferDirection :: Direction
|
|
, transferUUID :: UUID
|
|
, transferKeyData :: KeyData
|
|
}
|
|
deriving (Eq, Ord, Show, Read)
|
|
|
|
transferKey :: Transfer -> Key
|
|
transferKey = mkKey . const . transferKeyData
|
|
|
|
{- Information about a Transfer, stored in the transfer information file.
|
|
-
|
|
- Note that the associatedFile may not correspond to a file in the local
|
|
- git repository. It's some file, possibly relative to some directory,
|
|
- of some repository, that was acted on to initiate the transfer.
|
|
-}
|
|
data TransferInfo = TransferInfo
|
|
{ startedTime :: Maybe POSIXTime
|
|
, transferPid :: Maybe PID
|
|
, transferTid :: Maybe ThreadId
|
|
, transferRemote :: Maybe Remote
|
|
, bytesComplete :: Maybe Integer
|
|
, associatedFile :: AssociatedFile
|
|
, transferPaused :: Bool
|
|
}
|
|
deriving (Show, Eq, Ord)
|
|
|
|
stubTransferInfo :: TransferInfo
|
|
stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing (AssociatedFile Nothing) False
|
|
|
|
instance Arbitrary TransferInfo where
|
|
arbitrary = TransferInfo
|
|
<$> arbitrary
|
|
<*> arbitrary
|
|
<*> pure Nothing -- cannot generate a ThreadID
|
|
<*> pure Nothing -- remote not needed
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
<*> arbitrary
|
|
|
|
class Observable a where
|
|
observeBool :: a -> Bool
|
|
observeFailure :: a
|
|
|
|
instance Observable Bool where
|
|
observeBool = id
|
|
observeFailure = False
|
|
|
|
instance Observable (Bool, Verification) where
|
|
observeBool = fst
|
|
observeFailure = (False, UnVerified)
|
|
|
|
instance Observable (Either e Bool) where
|
|
observeBool (Left _) = False
|
|
observeBool (Right b) = b
|
|
observeFailure = Right False
|
|
|
|
instance Observable (Maybe a) where
|
|
observeBool (Just _) = True
|
|
observeBool Nothing = False
|
|
observeFailure = Nothing
|
|
|
|
instance Observable (Either e (Maybe a)) where
|
|
observeBool (Left _) = False
|
|
observeBool (Right Nothing) = False
|
|
observeBool (Right (Just _)) = True
|
|
observeFailure = Right Nothing
|
|
|
|
class Transferrable t where
|
|
descTransfrerrable :: t -> Maybe String
|
|
|
|
instance Transferrable AssociatedFile where
|
|
descTransfrerrable (AssociatedFile af) = fromRawFilePath <$> af
|
|
|
|
instance Transferrable URLString where
|
|
descTransfrerrable = Just
|