diff options
| -rw-r--r-- | Command/AddUrl.hs | 74 | ||||
| -rw-r--r-- | GitAnnex.hs | 2 | ||||
| -rw-r--r-- | LocationLog.hs | 5 | ||||
| -rw-r--r-- | PresenceLog.hs | 6 | ||||
| -rw-r--r-- | Remote/Web.hs | 69 |
5 files changed, 125 insertions, 31 deletions
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs new file mode 100644 index 000000000..713a486a5 --- /dev/null +++ b/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 diff --git a/GitAnnex.hs b/GitAnnex.hs index 58b512f71..85eb2bf26 100644 --- a/GitAnnex.hs +++ b/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 diff --git a/LocationLog.hs b/LocationLog.hs index a5db7d121..19a8eb83a 100644 --- a/LocationLog.hs +++ b/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 - let f = logFile key - ls <- readLog f - writeLog f (compactLog $ line:ls) + addLog (logFile key) =<< logNow s u {- Returns a list of repository UUIDs that, according to the log, have - the value of a key. -} diff --git a/PresenceLog.hs b/PresenceLog.hs index 71d78f1ed..0777db209 100644 --- a/PresenceLog.hs +++ b/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] diff --git a/Remote/Web.hs b/Remote/Web.hs index 201f923cf..342acef91 100644 --- a/Remote/Web.hs +++ b/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, - retrieveKeyFile = download, - removeKey = remove, - hasKey = check, + storeKey = uploadKey, + retrieveKeyFile = downloadKey, + removeKey = dropKey, + 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] -urls key = currentLog (urlLog key) +getUrls :: Key -> Annex [URLString] +getUrls key = currentLog (urlLog key) -download :: Key -> FilePath -> Annex Bool -download key file = download' file =<< urls key -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 +{- Records a change in an url for a key. -} +setUrl :: Key -> URLString -> LogStatus -> Annex () +setUrl key url status = do + g <- Annex.gitRepo + addLog (urlLog key) =<< logNow status url + + -- update location log to indicate that the web has the key, or not + 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 -upload :: Key -> Annex Bool -upload _ = do +uploadKey :: Key -> Annex Bool +uploadKey _ = do warning "upload to web not supported" return False -remove :: Key -> Annex Bool -remove _ = do +dropKey :: Key -> Annex Bool +dropKey _ = do warning "removal from web not supported" return False -check :: Key -> Annex (Either IOException Bool) -check key = do - us <- urls key +checkKey :: Key -> Annex (Either IOException Bool) +checkKey key = do + us <- getUrls key if null us then return $ Right False - else return . Right =<< check' us -check' :: [URLString] -> Annex Bool -check' [] = return False -check' (u:us) = do + else return . Right =<< checkKey' us +checkKey' :: [URLString] -> Annex Bool +checkKey' [] = return False +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 |