add the addurl command

Command/AddUrl.hs

@@ -0,0 +1,74 @@
+{- git-annex command
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.AddUrl where
+
+import Control.Monad.State (liftIO, when)
+import Network.URI
+import Data.String.Utils
+import System.Directory
+
+import Command
+import qualified Backend
+import qualified Remote.Web
+import qualified Command.Add
+import Messages
+import Content
+import PresenceLog
+
+command :: [Command]
+command = [repoCommand "addurl" paramPath seek "add urls to annex"]
+
+seek :: [CommandSeek]
+seek = [withStrings start]
+
+start :: CommandStartString
+start s = do
+	let u = parseURI s
+	case u of
+		Nothing -> error $ "bad url " ++ s
+		Just url -> do
+			file <- liftIO $ url2file url
+			showStart "addurl" file
+			next $ perform s file
+			
+perform :: String -> FilePath -> CommandPerform
+perform url file = do
+	[(_, backend)] <- Backend.chooseBackends [file]
+	showNote $ "downloading " ++ url
+	ok <- Remote.Web.download file [url]
+	if ok
+		then do
+			stored <- Backend.storeFileKey file backend
+			case stored of
+				Nothing -> stop
+				Just (key, _) -> do
+					moveAnnex key file
+					Remote.Web.setUrl key url InfoPresent
+					next $ Command.Add.cleanup file key
+		else stop
+
+url2file :: URI -> IO FilePath
+url2file url = do
+	let parts = filter safe $ split "/" $ uriPath url
+	if null parts
+		then fallback
+		else do
+			let file = last parts
+			e <- doesFileExist file
+			if e then fallback else return file
+	where
+		fallback = do
+			let file = replace "/" "_" $ show url
+			e <- doesFileExist file
+			when e $ error "already have this url"
+			return file
+		safe s
+			| null s = False
+			| s == "." = False
+			| s == ".." = False
+			| otherwise = True

GitAnnex.hs

@@ -46,6 +46,7 @@ import qualified Command.Uninit
 import qualified Command.Trust
 import qualified Command.Untrust
 import qualified Command.Semitrust
+import qualified Command.AddUrl
 import qualified Command.Map
 import qualified Command.Upgrade
 import qualified Command.Version
@@ -68,6 +69,7 @@ cmds = concat
 	, Command.Trust.command
 	, Command.Untrust.command
 	, Command.Semitrust.command
+	, Command.AddUrl.command
 	, Command.FromKey.command
 	, Command.DropKey.command
 	, Command.SetKey.command

LocationLog.hs

@@ -37,10 +37,7 @@ logChange repo key u s = do
 	when (null u) $
 		error $ "unknown UUID for " ++ Git.repoDescribe repo ++ 
 			" (have you run git annex init there?)"
-	line <- logNow s u
+	addLog (logFile key) =<< logNow s u
-	let f = logFile key
-	ls <- readLog f
-	writeLog f (compactLog $ line:ls)
 
 {- Returns a list of repository UUIDs that, according to the log, have
  - the value of a key. -}

PresenceLog.hs

@@ -13,6 +13,7 @@
 
 module PresenceLog (
 	LogStatus(..),
+	addLog,
 	readLog,
 	writeLog,
 	logNow,
@@ -70,6 +71,11 @@ instance Read LogLine where
 			bad = ret $ LogLine 0 Undefined ""
 			ret v = [(v, "")]
 
+addLog :: FilePath -> LogLine -> Annex ()
+addLog file line = do
+	ls <- readLog file
+	writeLog file (compactLog $ line:ls)
+
 {- Reads a log file.
  - Note that the LogLines returned may be in any order. -}
 readLog :: FilePath -> Annex [LogLine]

Remote/Web.hs

@@ -6,7 +6,9 @@
  -}
 
 module Remote.Web (
-	remote
+	remote,
+	setUrl,
+	download
 ) where
 
 import Control.Monad.State (liftIO)
@@ -20,11 +22,13 @@ import Network.Curl.Code
 import Types
 import Types.Remote
 import qualified Git
+import qualified Annex
 import Messages
 import Utility
 import UUID
 import Config
 import PresenceLog
+import LocationLog
 
 remote :: RemoteType Annex
 remote = RemoteType {
@@ -50,10 +54,10 @@ gen r _ _ =
 		uuid = webUUID,
 		cost = expensiveRemoteCost,
 		name = Git.repoDescribe r,
-		storeKey = upload,
+		storeKey = uploadKey,
-		retrieveKeyFile = download,
+		retrieveKeyFile = downloadKey,
-		removeKey = remove,
+		removeKey = dropKey,
-		hasKey = check,
+		hasKey = checkKey,
 		hasKeyCheap = False,
 		config = Nothing
 	}
@@ -62,40 +66,44 @@ gen r _ _ =
 urlLog :: Key -> FilePath
 urlLog key = "remote/web" </> show key ++ ".log"
 
-urls :: Key -> Annex [URLString]
+getUrls :: Key -> Annex [URLString]
-urls key = currentLog (urlLog key)
+getUrls key = currentLog (urlLog key)
 
-download :: Key -> FilePath -> Annex Bool
+{- Records a change in an url for a key. -}
-download key file = download' file =<< urls key
+setUrl :: Key -> URLString -> LogStatus -> Annex ()
-download' :: FilePath -> [URLString] -> Annex Bool
+setUrl key url status = do
-download' _ [] = return False
+	g <- Annex.gitRepo
-download' file (url:us) = do
+	addLog (urlLog key) =<< logNow status url
-	showProgress -- make way for curl progress bar
-	ok <- liftIO $ boolSystem "curl" [Params "-# -o", File file, File url]
-	if ok then return ok else download' file us
 
-upload :: Key -> Annex Bool
+	-- update location log to indicate that the web has the key, or not
-upload _ = do
+	us <- getUrls key
+	logChange g key webUUID (if null us then InfoMissing else InfoPresent)
+
+downloadKey :: Key -> FilePath -> Annex Bool
+downloadKey key file = download file =<< getUrls key
+
+uploadKey :: Key -> Annex Bool
+uploadKey _ = do
 	warning "upload to web not supported"
 	return False
 
-remove :: Key -> Annex Bool
+dropKey :: Key -> Annex Bool
-remove _ = do
+dropKey _ = do
 	warning "removal from web not supported"
 	return False
 
-check :: Key -> Annex (Either IOException Bool)
+checkKey :: Key -> Annex (Either IOException Bool)
-check key = do
+checkKey key = do
-	us <- urls key
+	us <- getUrls key
 	if null us
 		then return $ Right False
-		else return . Right =<< check' us
+		else return . Right =<< checkKey' us
-check' :: [URLString] -> Annex Bool
+checkKey' :: [URLString] -> Annex Bool
-check' [] = return False
+checkKey' [] = return False
-check' (u:us) = do
+checkKey' (u:us) = do
 	showNote ("checking " ++ u)
 	e <- liftIO $ urlexists u
-	if e then return e else check' us
+	if e then return e else checkKey' us
 
 urlexists :: URLString -> IO Bool
 urlexists url = do
@@ -105,3 +113,10 @@ urlexists url = do
 	_ <- setopt curl (CurlFailOnError True)
 	res <- perform curl
 	return $ res == CurlOK
+
+download :: FilePath -> [URLString] -> Annex Bool
+download _ [] = return False
+download file (url:us) = do
+	showProgress -- make way for curl progress bar
+	ok <- liftIO $ boolSystem "curl" [Params "-# -o", File file, File url]
+	if ok then return ok else download file us