fromkey, registerurl: Allow urls to be specified instead of keys, and generate URL keys.

This is especially useful because the caller doesn't need to generate valid
url keys, which involves some escaping of characters, and may involve
taking a md5sum of the url if it's too long.

Backend/URL.hs

@@ -31,8 +31,8 @@ backend = Backend
 	}
 
 {- Every unique url has a corresponding key. -}
-fromUrl :: String -> Maybe Integer -> Annex Key
-fromUrl url size = return $ stubKey
+fromUrl :: String -> Maybe Integer -> Key
+fromUrl url size = stubKey
 	{ keyName = genKeyName url
 	, keyBackendName = "URL"
 	, keySize = size

Command/AddUrl.hs

@@ -115,7 +115,7 @@ performRemote r relaxed uri file sz = ifAnnexed file adduri geturi
 
 downloadRemoteFile :: Remote -> Bool -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key)
 downloadRemoteFile r relaxed uri file sz = do
-	urlkey <- Backend.URL.fromUrl uri sz
+	let urlkey = Backend.URL.fromUrl uri sz
 	liftIO $ createDirectoryIfMissing True (parentDir file)
 	ifM (Annex.getState Annex.fast <||> pure relaxed)
 		( do
@@ -206,7 +206,7 @@ performQuvi relaxed pageurl videourl file = ifAnnexed file addurl geturl
 #ifdef WITH_QUVI
 addUrlFileQuvi :: Bool -> URLString -> URLString -> FilePath -> Annex (Maybe Key)
 addUrlFileQuvi relaxed quviurl videourl file = do
-	key <- Backend.URL.fromUrl quviurl Nothing
+	let key = Backend.URL.fromUrl quviurl Nothing
 	ifM (pure relaxed <||> Annex.getState Annex.fast)
 		( do
 			cleanup webUUID quviurl file key Nothing
@@ -264,7 +264,7 @@ addUrlFile relaxed url urlinfo file = do
 
 downloadWeb :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)
 downloadWeb url urlinfo file = do
-	dummykey <- addSizeUrlKey urlinfo <$> Backend.URL.fromUrl url Nothing
+	let dummykey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing
 	let downloader f _ = do
 		showOutput
 		downloadUrl [url] f
@@ -321,7 +321,7 @@ cleanup u url file key mtmp = do
 nodownload :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)
 nodownload url urlinfo file
 	| Url.urlExists urlinfo = do
-		key <- Backend.URL.fromUrl url (Url.urlSize urlinfo)
+		let key = Backend.URL.fromUrl url (Url.urlSize urlinfo)
 		cleanup webUUID url file key Nothing
 		return (Just key)
 	| otherwise = do

Command/FromKey.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010 Joey Hess <id@joeyh.name>
+ - Copyright 2010, 2015 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -15,6 +15,9 @@ import qualified Annex.Queue
 import Annex.Content
 import Types.Key
 import qualified Annex
+import qualified Backend.URL
+
+import Network.URI
 
 cmd :: [Command]
 cmd = [notDirect $ notBareRepo $
@@ -28,7 +31,7 @@ seek ps = do
 
 start :: Bool -> [String] -> CommandStart
 start force (keyname:file:[]) = do
-	let key = fromMaybe (error "bad key") $ file2key keyname
+	let key = mkKey keyname
 	unless force $ do
 		inbackend <- inAnnex key
 		unless inbackend $ error $
@@ -45,12 +48,19 @@ massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
   where
 	go status [] = next $ return status
 	go status ((keyname,f):rest) | not (null keyname) && not (null f) = do
-		let key = fromMaybe (error $ "bad key " ++ keyname) $ file2key keyname
+		let key = mkKey keyname
 		ok <- perform' key f
 		let !status' = status && ok
 		go status' rest
 	go _ _ = error "Expected pairs of key and file on stdin, but got something else."
 
+mkKey :: String -> Key
+mkKey s = case file2key s of
+	Just k -> k
+	Nothing -> case parseURI s of
+		Just _u -> Backend.URL.fromUrl s Nothing
+		Nothing -> error $ "bad key " ++ s
+
 perform :: Key -> FilePath -> CommandPerform
 perform key file = do
 	ok <- perform' key file

Command/ImportFeed.hs

@@ -370,4 +370,4 @@ clearFeedProblem :: URLString -> Annex ()
 clearFeedProblem url = void $ liftIO . tryIO . removeFile =<< feedState url
 
 feedState :: URLString -> Annex FilePath
-feedState url = fromRepo . gitAnnexFeedState =<< fromUrl url Nothing
+feedState url = fromRepo $ gitAnnexFeedState $ fromUrl url Nothing

Command/RegisterUrl.hs

@@ -11,9 +11,9 @@ module Command.RegisterUrl where
 
 import Common.Annex
 import Command
-import Types.Key
 import Logs.Web
 import Annex.UUID
+import Command.FromKey (mkKey)
 
 cmd :: [Command]
 cmd = [notDirect $ notBareRepo $
@@ -25,7 +25,7 @@ seek = withWords start
 
 start :: [String] -> CommandStart
 start (keyname:url:[]) = do
-	let key = fromMaybe (error "bad key") $ file2key keyname
+	let key = mkKey keyname
 	showStart "registerurl" url
 	next $ perform key url
 start [] = do
@@ -38,7 +38,7 @@ massAdd = go True =<< map (separate (== ' ')) . lines <$> liftIO getContents
   where
 	go status [] = next $ return status
 	go status ((keyname,u):rest) | not (null keyname) && not (null u) = do
-		let key = fromMaybe (error $ "bad key " ++ keyname) $ file2key keyname
+		let key = mkKey keyname
 		ok <- perform' key u
 		let !status' = status && ok
 		go status' rest

Remote/BitTorrent.hs

@@ -155,7 +155,7 @@ torrentUrlNum u
 
 {- A Key corresponding to the URL of a torrent file. -}
 torrentUrlKey :: URLString -> Annex Key
-torrentUrlKey u = fromUrl (fst $ torrentUrlNum u) Nothing
+torrentUrlKey u = return $ fromUrl (fst $ torrentUrlNum u) Nothing
 
 {- Temporary directory used to download a torrent. -}
 tmpTorrentDir :: URLString -> Annex FilePath

debian/changelog

@@ -1,3 +1,10 @@
+git-annex (5.20150523) UNRELEASED; urgency=medium
+
+  * fromkey, registerurl: Allow urls to be specified instead of keys,
+    and generate URL keys.
+
+ -- Joey Hess <id@joeyh.name>  Fri, 22 May 2015 22:23:32 -0400
+
 git-annex (5.20150522) unstable; urgency=medium
 
   * import: Refuse to import files that are within the work tree, as that

doc/git-annex-fromkey.mdwn

@@ -15,6 +15,12 @@ If the key and file are not specified on the command line, they are
 instead read from stdin. Any number of lines can be provided in this
 mode, each containing a key and filename, separated by a single space.
 
+Normally the key is a git-annex formatted key. However, to make it easier
+to use this to add urls, if the key cannot be parsed as a key, and is a
+valid url, an URL key is constructed from the url. Note that this does not
+register the url as a location of the key; use [[git-annex-registerurl]](1)
+to do that.
+
 # OPTIONS
 
 * `--force`

doc/git-annex-registerurl.mdwn

@@ -17,6 +17,10 @@ If the key and url are not specified on the command line, they are
 instead read from stdin. Any number of lines can be provided in this
 mode, each containing a key and url, separated by a single space.
 
+Normally the key is a git-annex formatted key. However, to make it easier
+to use this to add urls, if the key cannot be parsed as a key, and is a
+valid url, an URL key is constructed from the url.
+
 # SEE ALSO
 
 [[git-annex]](1)