Expand checkurl to support recommended filename, and multi-file-urls
This commit was sponsored by an anonymous bitcoiner.
This commit is contained in:
parent
7ae16bb6f7
commit
2cd84fcc8b
18 changed files with 115 additions and 77 deletions
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
25
Remote/External/Types.hs
vendored
25
Remote/External/Types.hs
vendored
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue