Expand checkurl to support recommended filename, and multi-file-urls

This commit was sponsored by an anonymous bitcoiner.
This commit is contained in:
Joey Hess 2014-12-11 15:32:42 -04:00
parent 7ae16bb6f7
commit 2cd84fcc8b
18 changed files with 115 additions and 77 deletions

View file

@ -75,7 +75,7 @@ gen r u c gc = do
, mkUnavailable = return Nothing
, getInfo = return [("repo", buprepo)]
, claimUrl = Nothing
, checkUrl = const $ return Nothing
, checkUrl = Nothing
}
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this buprepo)

View file

@ -72,7 +72,7 @@ gen r u c gc = do
, mkUnavailable = return Nothing
, getInfo = return [("repo", ddarrepo)]
, claimUrl = Nothing
, checkUrl = const $ return Nothing
, checkUrl = Nothing
}
ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
specialcfg = (specialRemoteCfg c)

View file

@ -70,7 +70,7 @@ gen r u c gc = do
gc { remoteAnnexDirectory = Just "/dev/null" },
getInfo = return [("directory", dir)],
claimUrl = Nothing,
checkUrl = const $ return Nothing
checkUrl = Nothing
}
where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc

View file

@ -12,6 +12,7 @@ import qualified Annex
import Common.Annex
import Types.Remote
import Types.CleanupActions
import Types.UrlContents
import qualified Git
import Config
import Remote.Helper.Special
@ -71,7 +72,7 @@ gen r u c gc = do
gc { remoteAnnexExternalType = Just "!dne!" },
getInfo = return [("externaltype", externaltype)],
claimUrl = Just (claimurl external),
checkUrl = checkurl external
checkUrl = Just (checkurl external)
}
where
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
@ -429,11 +430,14 @@ claimurl external url =
UNSUPPORTED_REQUEST -> Just $ return False
_ -> Nothing
checkurl :: External -> URLString -> Annex (Maybe Integer)
checkurl :: External -> URLString -> Annex UrlContents
checkurl external url =
handleRequest external (CHECKURL url) Nothing $ \req -> case req of
CHECKURL_SIZE sz -> Just $ return $ Just sz
CHECKURL_SIZEUNKNOWN -> Just $ return Nothing
CHECKURL_CONTENTS sz f -> Just $ return $ UrlContents sz
(if null f then id else const f)
CHECKURL_MULTI l -> Just $ return $ UrlNested $ map mknested l
CHECKURL_FAILURE errmsg -> Just $ error errmsg
UNSUPPORTED_REQUEST -> error "CHECKURL not implemented by external special remote"
_ -> Nothing
where
mknested (url', sz, f) = (url', UrlContents sz (const f))

View file

@ -137,8 +137,8 @@ data Response
| INITREMOTE_FAILURE ErrorMsg
| CLAIMURL_SUCCESS
| CLAIMURL_FAILURE
| CHECKURL_SIZE Size
| CHECKURL_SIZEUNKNOWN
| CHECKURL_CONTENTS Size FilePath
| CHECKURL_MULTI [(URLString, Size, FilePath)]
| CHECKURL_FAILURE ErrorMsg
| UNSUPPORTED_REQUEST
deriving (Show)
@ -159,8 +159,8 @@ instance Proto.Receivable Response where
parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE
parseCommand "CLAIMURL-SUCCESS" = Proto.parse0 CLAIMURL_SUCCESS
parseCommand "CLAIMURL-FAILURE" = Proto.parse0 CLAIMURL_FAILURE
parseCommand "CHECKURL-SIZE" = Proto.parse1 CHECKURL_SIZE
parseCommand "CHECKURL-SIZEUNKNOWN" = Proto.parse0 CHECKURL_SIZEUNKNOWN
parseCommand "CHECKURL-CONTENTS" = Proto.parse2 CHECKURL_CONTENTS
parseCommand "CHECKURL-MULTI" = Proto.parse1 CHECKURL_MULTI
parseCommand "CHECKURL-FAILURE" = Proto.parse1 CHECKURL_FAILURE
parseCommand "UNSUPPORTED-REQUEST" = Proto.parse0 UNSUPPORTED_REQUEST
parseCommand _ = Proto.parseFail
@ -233,7 +233,7 @@ instance Proto.Receivable AsyncMessage where
type ErrorMsg = String
type Setting = String
type ProtocolVersion = Int
type Size = Integer
type Size = Maybe Integer
supportedProtocolVersions :: [ProtocolVersion]
supportedProtocolVersions = [1]
@ -263,8 +263,10 @@ instance Proto.Serializable Cost where
deserialize = readish
instance Proto.Serializable Size where
serialize = show
deserialize = readish
serialize (Just s) = show s
serialize Nothing = "UNKNOWN"
deserialize "UNKNOWN" = Just Nothing
deserialize s = maybe Nothing (Just . Just) (readish s)
instance Proto.Serializable Availability where
serialize GloballyAvailable = "GLOBAL"
@ -277,3 +279,12 @@ instance Proto.Serializable Availability where
instance Proto.Serializable BytesProcessed where
serialize (BytesProcessed n) = show n
deserialize = BytesProcessed <$$> readish
instance Proto.Serializable [(URLString, Size, FilePath)] where
serialize = unwords . map go
where
go (url, sz, f) = url ++ " " ++ maybe "UNKNOWN" show sz ++ " " ++ f
deserialize = Just . go [] . words
where
go c (url:sz:f:rest) = go ((url, readish sz, f):c) rest
go c _ = reverse c

View file

@ -123,7 +123,7 @@ gen' r u c gc = do
, mkUnavailable = return Nothing
, getInfo = return $ gitRepoInfo r
, claimUrl = Nothing
, checkUrl = const $ return Nothing
, checkUrl = Nothing
}
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this rsyncopts)

View file

@ -161,7 +161,7 @@ gen r u c gc
, mkUnavailable = unavailable r u c gc
, getInfo = return $ gitRepoInfo r
, claimUrl = Nothing
, checkUrl = const $ return Nothing
, checkUrl = Nothing
}
unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)

View file

@ -70,7 +70,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
getInfo = includeCredsInfo c (AWS.creds u) $
[ ("glacier vault", getVault c) ],
claimUrl = Nothing,
checkUrl = const $ return Nothing
checkUrl = Nothing
}
specialcfg = (specialRemoteCfg c)
-- Disabled until jobList gets support for chunks.

View file

@ -63,7 +63,7 @@ gen r u c gc = do
gc { remoteAnnexHookType = Just "!dne!" },
getInfo = return [("hooktype", hooktype)],
claimUrl = Nothing,
checkUrl = const $ return Nothing
checkUrl = Nothing
}
where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc

View file

@ -85,7 +85,7 @@ gen r u c gc = do
, mkUnavailable = return Nothing
, getInfo = return [("url", url)]
, claimUrl = Nothing
, checkUrl = const $ return Nothing
, checkUrl = Nothing
}
where
specialcfg = (specialRemoteCfg c)

View file

@ -94,7 +94,7 @@ gen r u c gc = do
, Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c))
],
claimUrl = Nothing,
checkUrl = const $ return Nothing
checkUrl = Nothing
}
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)

View file

@ -87,7 +87,7 @@ gen r u c gc = do
mkUnavailable = return Nothing,
getInfo = return [],
claimUrl = Nothing,
checkUrl = const $ return Nothing
checkUrl = Nothing
}
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)

View file

@ -65,7 +65,7 @@ gen r _ c gc =
mkUnavailable = return Nothing,
getInfo = return [],
claimUrl = Nothing, -- implicitly claims all urls
checkUrl = const $ return Nothing
checkUrl = Nothing
}
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool

View file

@ -75,7 +75,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
getInfo = includeCredsInfo c (davCreds u) $
[("url", fromMaybe "unknown" (M.lookup "url" c))],
claimUrl = Nothing,
checkUrl = const $ return Nothing
checkUrl = Nothing
}
chunkconfig = getChunkConfig c