summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2014-12-11 12:47:57 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2014-12-11 12:47:57 -0400
commitbc0bf97b20c48e1d1a35d25e2e76a311c102438c (patch)
tree05934001ff6b3060cb477a1bd017316827eb050b
parent7f5e752b41b559bce358a9d6a053a7b195706e80 (diff)
let url claims optionally include a suggested filename
-rw-r--r--Annex/URLClaim.hs29
-rw-r--r--Command/AddUrl.hs15
-rw-r--r--Command/ReKey.hs3
-rw-r--r--Command/RmUrl.hs3
-rw-r--r--Command/Whereis.hs3
-rw-r--r--Remote.hs11
-rw-r--r--Remote/External.hs10
-rw-r--r--Remote/External/Types.hs2
-rw-r--r--Types/Remote.hs3
-rw-r--r--Types/URLClaim.hs11
-rw-r--r--doc/design/external_special_remote_protocol.mdwn3
11 files changed, 67 insertions, 26 deletions
diff --git a/Annex/URLClaim.hs b/Annex/URLClaim.hs
new file mode 100644
index 000000000..3acb28e29
--- /dev/null
+++ b/Annex/URLClaim.hs
@@ -0,0 +1,29 @@
+{- Url claim checking.
+ -
+ - Copyright 2013-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.URLClaim (
+ URLClaim(..),
+ urlClaim
+) where
+
+import Common.Annex
+import Types.URLClaim
+import Logs.Web
+import Remote
+import qualified Types.Remote as Remote
+
+urlClaim :: URLString -> Annex (Remote, URLClaim)
+urlClaim url = do
+ rs <- remoteList
+ -- The web special remote claims urls by default.
+ let web = Prelude.head $ filter (\r -> uuid r == webUUID) rs
+ fromMaybe (web, URLClaimed) <$> getM (\r -> ret r <$> checkclaim r) rs
+ where
+ checkclaim = maybe (pure Nothing) (flip id url) . Remote.claimUrl
+
+ ret _ Nothing = Nothing
+ ret r (Just c) = Just (r, c)
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index 76095d6e4..27c8359b0 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -21,6 +21,7 @@ import qualified Annex.Url as Url
import qualified Backend.URL
import qualified Remote
import qualified Types.Remote as Remote
+import Annex.URLClaim
import Annex.Content
import Logs.Web
import Types.Key
@@ -58,23 +59,23 @@ seek ps = do
start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
start relaxed optfile pathdepth s = do
- r <- Remote.claimingUrl s
+ (r, claim) <- urlClaim s
if Remote.uuid r == webUUID
then startWeb relaxed optfile pathdepth s
- else startRemote r relaxed optfile pathdepth s
+ else startRemote r claim relaxed optfile pathdepth s
-startRemote :: Remote -> Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
-startRemote r relaxed optfile pathdepth s = do
+startRemote :: Remote -> URLClaim -> Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
+startRemote r claim relaxed optfile pathdepth s = do
url <- case Url.parseURIRelaxed s of
Nothing -> error $ "bad uri " ++ s
Just u -> pure u
pathmax <- liftIO $ fileNameLengthLimit "."
- let file = choosefile $ url2file url pathdepth pathmax
+ let file = flip fromMaybe optfile $ case claim of
+ URLClaimedAs f -> f
+ URLClaimed -> url2file url pathdepth pathmax
showStart "addurl" file
showNote $ "using " ++ Remote.name r
next $ performRemote r relaxed s file
- where
- choosefile = flip fromMaybe optfile
performRemote :: Remote -> Bool -> URLString -> FilePath -> CommandPerform
performRemote r relaxed uri file = ifAnnexed file adduri geturi
diff --git a/Command/ReKey.hs b/Command/ReKey.hs
index 5dadf4e60..a0348d858 100644
--- a/Command/ReKey.hs
+++ b/Command/ReKey.hs
@@ -16,6 +16,7 @@ import qualified Command.Add
import Logs.Web
import Logs.Location
import Utility.CopyFile
+import Annex.URLClaim
import qualified Remote
cmd :: [Command]
@@ -63,7 +64,7 @@ cleanup file oldkey newkey = do
-- the new key as well.
urls <- getUrls oldkey
forM_ urls $ \url -> do
- r <- Remote.claimingUrl url
+ r <- fst <$> urlClaim url
setUrlPresent (Remote.uuid r) newkey url
-- Update symlink to use the new key.
diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs
index 570004266..737c935c5 100644
--- a/Command/RmUrl.hs
+++ b/Command/RmUrl.hs
@@ -10,6 +10,7 @@ module Command.RmUrl where
import Common.Annex
import Command
import Logs.Web
+import Annex.URLClaim
import qualified Remote
cmd :: [Command]
@@ -27,7 +28,7 @@ start (file, url) = flip whenAnnexed file $ \_ key -> do
cleanup :: String -> Key -> CommandCleanup
cleanup url key = do
- r <- Remote.claimingUrl url
+ r <- fst <$> urlClaim url
let url' = if Remote.uuid r == webUUID
then url
else setDownloader url OtherDownloader
diff --git a/Command/Whereis.hs b/Command/Whereis.hs
index 314c204be..5f75badde 100644
--- a/Command/Whereis.hs
+++ b/Command/Whereis.hs
@@ -14,6 +14,7 @@ import Command
import Remote
import Logs.Trust
import Logs.Web
+import Annex.URLClaim
cmd :: [Command]
cmd = [noCommit $ withOptions (jsonOption : keyOptions) $
@@ -71,4 +72,4 @@ performRemote key remote = do
. filter (\(_, d) -> d == OtherDownloader)
. map getDownloader
<$> getUrls key
- filterM (\u -> (==) <$> pure remote <*> claimingUrl u) us
+ filterM (\u -> (==) <$> pure remote <*> (fst <$> urlClaim u)) us
diff --git a/Remote.hs b/Remote.hs
index 65e725338..dd682493c 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -46,7 +46,6 @@ module Remote (
logStatus,
checkAvailable,
isXMPPRemote,
- claimingUrl,
) where
import qualified Data.Map as M
@@ -61,7 +60,6 @@ import Annex.UUID
import Logs.UUID
import Logs.Trust
import Logs.Location hiding (logStatus)
-import Logs.Web
import Remote.List
import Config
import Git.Types (RemoteName)
@@ -320,12 +318,3 @@ hasKey r k = either (Left . show) Right <$> tryNonAsync (checkPresent r k)
hasKeyCheap :: Remote -> Bool
hasKeyCheap = checkPresentCheap
-
-{- The web special remote claims urls by default. -}
-claimingUrl :: URLString -> Annex Remote
-claimingUrl url = do
- rs <- remoteList
- let web = Prelude.head $ filter (\r -> uuid r == webUUID) rs
- fromMaybe web <$> firstM checkclaim rs
- where
- checkclaim = maybe (pure False) (flip id url) . claimUrl
diff --git a/Remote/External.hs b/Remote/External.hs
index 62671755c..baae1ab9d 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -12,6 +12,7 @@ import qualified Annex
import Common.Annex
import Types.Remote
import Types.CleanupActions
+import Types.URLClaim
import qualified Git
import Config
import Remote.Helper.Special
@@ -421,12 +422,13 @@ getAvailability external r gc = maybe query return (remoteAnnexAvailability gc)
setRemoteAvailability r avail
return avail
-claimurl :: External -> URLString -> Annex Bool
+claimurl :: External -> URLString -> Annex (Maybe URLClaim)
claimurl external url =
handleRequest external (CLAIMURL url) Nothing $ \req -> case req of
- CLAIMURL_SUCCESS -> Just $ return True
- CLAIMURL_FAILURE -> Just $ return False
- UNSUPPORTED_REQUEST -> Just $ return False
+ CLAIMURL_SUCCESS -> Just $ return $ Just URLClaimed
+ (CLAIMURL_AS f) -> Just $ return $ Just $ URLClaimedAs f
+ CLAIMURL_FAILURE -> Just $ return Nothing
+ UNSUPPORTED_REQUEST -> Just $ return Nothing
_ -> Nothing
checkurl :: External -> URLString -> Annex (Maybe Integer)
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index b00352702..a230ef3d2 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -136,6 +136,7 @@ data Response
| INITREMOTE_SUCCESS
| INITREMOTE_FAILURE ErrorMsg
| CLAIMURL_SUCCESS
+ | CLAIMURL_AS FilePath
| CLAIMURL_FAILURE
| CHECKURL_SIZE Size
| CHECKURL_SIZEUNKNOWN
@@ -158,6 +159,7 @@ instance Proto.Receivable Response where
parseCommand "INITREMOTE-SUCCESS" = Proto.parse0 INITREMOTE_SUCCESS
parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE
parseCommand "CLAIMURL-SUCCESS" = Proto.parse0 CLAIMURL_SUCCESS
+ parseCommand "CLAIMURL-AS" = Proto.parse1 CLAIMURL_AS
parseCommand "CLAIMURL-FAILURE" = Proto.parse0 CLAIMURL_FAILURE
parseCommand "CHECKURL-SIZE" = Proto.parse1 CHECKURL_SIZE
parseCommand "CHECKURL-SIZEUNKNOWN" = Proto.parse0 CHECKURL_SIZEUNKNOWN
diff --git a/Types/Remote.hs b/Types/Remote.hs
index baa857906..bb56bb01d 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -25,6 +25,7 @@ import Types.UUID
import Types.GitConfig
import Types.Availability
import Types.Creds
+import Types.URLClaim
import Config.Cost
import Utility.Metered
import Git.Types
@@ -103,7 +104,7 @@ data RemoteA a = Remote {
-- Information about the remote, for git annex info to display.
getInfo :: a [(String, String)],
-- Some remotes can download from an url (or uri).
- claimUrl :: Maybe (URLString -> a Bool),
+ claimUrl :: Maybe (URLString -> a (Maybe URLClaim)),
-- Checks that the url is accessible, and gets the size of its
-- content. Returns Nothing if the url is accessible, but
-- its size cannot be determined inexpensively.
diff --git a/Types/URLClaim.hs b/Types/URLClaim.hs
new file mode 100644
index 000000000..f14333111
--- /dev/null
+++ b/Types/URLClaim.hs
@@ -0,0 +1,11 @@
+{- git-annex url claiming
+ -
+ - Copyright 2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Types.URLClaim where
+
+data URLClaim = URLClaimed | URLClaimedAs FilePath
+ deriving (Eq)
diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn
index 072c5a1a2..c62949b6d 100644
--- a/doc/design/external_special_remote_protocol.mdwn
+++ b/doc/design/external_special_remote_protocol.mdwn
@@ -179,6 +179,9 @@ while it's handling a request.
Indicates that INITREMOTE failed.
* `CLAIMURL-SUCCESS`
Indicates that the CLAIMURL url will be handled by this remote.
+* `CLAIMURL-AS Filename`
+ Indicates that the CLAIMURL url will be handled by this remote,
+ and suggests a filename to use for it.
* `CLAIMURL-FAILURE`
Indicates that the CLAIMURL url wil not be handled by this remote.
* `CHECKURL-SIZE Size`