add GETAVAILABILITY to external special remote protocol

And some reworking of types, and added an annex-availability git config
setting.
This commit is contained in:
Joey Hess 2014-01-13 14:41:10 -04:00
parent 47d2ebd374
commit c20f31a1ad
22 changed files with 99 additions and 26 deletions

View file

@ -72,7 +72,7 @@ gen r u c gc = do
then Just buprepo
else Nothing
, remotetype = remote
, globallyAvailable = not $ bupLocal buprepo
, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
, readonly = False
}
return $ Just $ encryptableRemote c

View file

@ -61,7 +61,7 @@ gen r u c gc = do
gitconfig = gc,
localpath = Just dir,
readonly = False,
globallyAvailable = False,
availability = LocallyAvailable,
remotetype = remote
}
where

View file

@ -45,6 +45,7 @@ gen r u c gc = do
external <- newExternal externaltype u c
Annex.addCleanup (fromUUID u) $ stopExternal external
cst <- getCost external r gc
avail <- getAvailability external r gc
return $ Just $ encryptableRemote c
(storeEncrypted external $ getGpgEncParams (c,gc))
(retrieveEncrypted external)
@ -66,11 +67,11 @@ gen r u c gc = do
repo = r,
gitconfig = gc,
readonly = False,
globallyAvailable = False,
availability = avail,
remotetype = remote
}
where
externaltype = fromMaybe (error "missing externaltype") $ remoteAnnexExternalType gc
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
externalSetup :: Maybe UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
externalSetup mu c = do
@ -419,3 +420,21 @@ getCost external r gc = go =<< remoteCost' gc
_ -> Nothing
setRemoteCost r c
return c
{- Caches the availability in the git config to avoid needing to start up an
- external special remote every time time just to ask it what its
- availability is.
-
- Most remotes do not bother to implement a reply to this request;
- globally available is the default.
-}
getAvailability :: External -> Git.Repo -> RemoteGitConfig -> Annex Availability
getAvailability external r gc = maybe query return (remoteAnnexAvailability gc)
where
query = do
avail <- handleRequest external GETAVAILABILITY Nothing $ \req -> case req of
AVAILABILITY avail -> Just $ return avail
UNSUPPORTED_REQUEST -> Just $ return GloballyAvailable
_ -> Nothing
setRemoteAvailability r avail
return avail

View file

@ -38,6 +38,7 @@ import Utility.Metered (BytesProcessed(..))
import Logs.Transfer (Direction(..))
import Config.Cost (Cost)
import Types.Remote (RemoteConfig)
import Types.Availability (Availability(..))
import Data.Char
import Control.Concurrent.STM
@ -105,6 +106,7 @@ data Request
= PREPARE
| INITREMOTE
| GETCOST
| GETAVAILABILITY
| TRANSFER Direction Key FilePath
| CHECKPRESENT Key
| REMOVE Key
@ -120,6 +122,7 @@ instance Sendable Request where
formatMessage PREPARE = ["PREPARE"]
formatMessage INITREMOTE = ["INITREMOTE"]
formatMessage GETCOST = ["GETCOST"]
formatMessage GETAVAILABILITY = ["GETAVAILABILITY"]
formatMessage (TRANSFER direction key file) =
[ "TRANSFER", serialize direction, serialize key, serialize file ]
formatMessage (CHECKPRESENT key) = [ "CHECKPRESENT", serialize key ]
@ -137,6 +140,7 @@ data Response
| REMOVE_SUCCESS Key
| REMOVE_FAILURE Key ErrorMsg
| COST Cost
| AVAILABILITY Availability
| INITREMOTE_SUCCESS
| INITREMOTE_FAILURE ErrorMsg
| UNSUPPORTED_REQUEST
@ -153,6 +157,7 @@ instance Receivable Response where
parseCommand "REMOVE-SUCCESS" = parse1 REMOVE_SUCCESS
parseCommand "REMOVE-FAILURE" = parse2 REMOVE_FAILURE
parseCommand "COST" = parse1 COST
parseCommand "AVAILABILITY" = parse1 AVAILABILITY
parseCommand "INITREMOTE-SUCCESS" = parse0 INITREMOTE_SUCCESS
parseCommand "INITREMOTE-FAILURE" = parse1 INITREMOTE_FAILURE
parseCommand "UNSUPPORTED-REQUEST" = parse0 UNSUPPORTED_REQUEST
@ -252,6 +257,14 @@ instance Serializable Cost where
serialize = show
deserialize = readish
instance Serializable Availability where
serialize GloballyAvailable = "GLOBAL"
serialize LocallyAvailable = "LOCAL"
deserialize "GLOBAL" = Just GloballyAvailable
deserialize "LOCAL" = Just LocallyAvailable
deserialize _ = Nothing
instance Serializable BytesProcessed where
serialize (BytesProcessed n) = show n
deserialize = BytesProcessed <$$> readish

View file

@ -114,7 +114,7 @@ gen' r u c gc = do
, repo = r
, gitconfig = gc { remoteGitConfig = Just $ extractGitConfig r }
, readonly = Git.repoIsHttp r
, globallyAvailable = globallyAvailableCalc r
, availability = availabilityCalc r
, remotetype = remote
}
return $ Just $ encryptableRemote c

View file

@ -126,7 +126,7 @@ gen r u c gc
, gitconfig = gc
{ remoteGitConfig = Just $ extractGitConfig r }
, readonly = Git.repoIsHttp r
, globallyAvailable = globallyAvailableCalc r
, availability = availabilityCalc r
, remotetype = remote
}

View file

@ -66,7 +66,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
gitconfig = gc,
localpath = Nothing,
readonly = False,
globallyAvailable = True,
availability = GloballyAvailable,
remotetype = remote
}

View file

@ -1,6 +1,6 @@
{- Utilities for git remotes.
-
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
- Copyright 2011-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -9,18 +9,20 @@ module Remote.Helper.Git where
import Common.Annex
import qualified Git
import Types.Availability
repoCheap :: Git.Repo -> Bool
repoCheap = not . Git.repoIsUrl
localpathCalc :: Git.Repo -> Maybe FilePath
localpathCalc r = if globallyAvailableCalc r
then Nothing
else Just $ Git.repoPath r
localpathCalc r
| availabilityCalc r == GloballyAvailable = Nothing
| otherwise = Just $ Git.repoPath r
globallyAvailableCalc :: Git.Repo -> Bool
globallyAvailableCalc r = not $
Git.repoIsLocal r || Git.repoIsLocalUnknown r
availabilityCalc :: Git.Repo -> Availability
availabilityCalc r
| (Git.repoIsLocal r || Git.repoIsLocalUnknown r) = LocallyAvailable
| otherwise = GloballyAvailable
{- Avoids performing an action on a local repository that's not usable.
- Does not check that the repository is still available on disk. -}

View file

@ -59,7 +59,7 @@ gen r u c gc = do
repo = r,
gitconfig = gc,
readonly = False,
globallyAvailable = False,
availability = GloballyAvailable,
remotetype = remote
}
where

View file

@ -88,7 +88,7 @@ gen r u c gc = do
then Just $ rsyncUrl o
else Nothing
, readonly = False
, globallyAvailable = not islocal
, availability = if islocal then LocallyAvailable else GloballyAvailable
, remotetype = remote
}

View file

@ -69,7 +69,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
gitconfig = gc,
localpath = Nothing,
readonly = False,
globallyAvailable = True,
availability = GloballyAvailable,
remotetype = remote
}

View file

@ -81,7 +81,7 @@ gen r u c gc = do
gitconfig = gc,
localpath = Nothing,
readonly = False,
globallyAvailable = True,
availability = GloballyAvailable,
remotetype = remote
}

View file

@ -61,7 +61,7 @@ gen r _ c gc =
localpath = Nothing,
repo = r,
readonly = True,
globallyAvailable = True,
availability = GloballyAvailable,
remotetype = remote
}

View file

@ -72,7 +72,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
gitconfig = gc,
localpath = Nothing,
readonly = False,
globallyAvailable = True,
availability = GloballyAvailable,
remotetype = remote
}