diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -63,6 +63,7 @@ import Utility.Quvi (QuviVersion) #endif import Utility.InodeCache +import Utility.Url import "mtl" Control.Monad.Reader import Control.Concurrent @@ -128,6 +129,7 @@ , useragent :: Maybe String , errcounter :: Integer , unusedkeys :: Maybe (S.Set Key) + , tempurls :: M.Map Key URLString #ifdef WITH_QUVI , quviversion :: Maybe QuviVersion #endif @@ -173,6 +175,7 @@ , useragent = Nothing , errcounter = 0 , unusedkeys = Nothing + , tempurls = M.empty #ifdef WITH_QUVI , quviversion = Nothing #endif diff --git a/Annex/UUID.hs b/Annex/UUID.hs --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -23,6 +23,8 @@ storeUUID, storeUUIDIn, setUUID, + webUUID, + bitTorrentUUID, ) where import Common.Annex @@ -98,3 +100,11 @@ setUUID r u = do let s = show configkey ++ "=" ++ fromUUID u Git.Config.store s r + +-- Dummy uuid for the whole web. Do not alter. +webUUID :: UUID +webUUID = UUID "00000000-0000-0000-0000-000000000001" + +-- Dummy uuid for bittorrent. Do not alter. +bitTorrentUUID :: UUID +bitTorrentUUID = UUID "00000000-0000-0000-0000-000000000002" diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -19,7 +19,6 @@ import Logs.Transfer import Logs.Location import Logs.Group -import Logs.Web (webUUID) import qualified Remote import qualified Types.Remote as Remote import Utility.ThreadScheduler @@ -115,7 +114,7 @@ - since we need to look at the locations of all keys anyway. -} expensiveScan :: UrlRenderer -> [Remote] -> Assistant () -expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do +expensiveScan urlrenderer rs = batch <~> do debug ["starting scan of", show visiblers] let us = map Remote.uuid rs @@ -135,7 +134,6 @@ remove <- asIO1 $ removableRemote urlrenderer liftIO $ mapM_ (void . tryNonAsync . remove) $ S.toList removablers where - onlyweb = all (== webUUID) $ map Remote.uuid rs visiblers = let rs' = filter (not . Remote.readonly) rs in if null rs' then rs else rs' diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -21,6 +21,7 @@ import Logs.Presence import Logs.Location import Annex.Content +import Annex.UUID import qualified Backend import qualified Types.Backend import qualified Types.Key @@ -80,7 +81,7 @@ where go Nothing = debug ["Skipping redundant upgrade"] go (Just dest) = do - liftAnnex $ setUrlPresent k u + liftAnnex $ setUrlPresent webUUID k u hook <- asIO1 $ distributionDownloadComplete d dest cleanup modifyDaemonStatus_ $ \s -> s { transferHook = M.insert k hook (transferHook s) } @@ -97,7 +98,7 @@ } cleanup = liftAnnex $ do lockContent k removeAnnex - setUrlMissing k u + setUrlMissing webUUID k u logStatus k InfoMissing {- Called once the download is done. diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -42,7 +42,6 @@ import Annex.UUID import Assistant.Ssh import Config -import Logs.Web (webUUID) import qualified Data.Text as T import qualified Data.Map as M @@ -193,7 +192,7 @@ editForm :: Bool -> RepoId -> Handler Html editForm new (RepoUUID uuid) - | uuid == webUUID = page "The web" (Just Configuration) $ do + | uuid == webUUID || uuid == bitTorrentUUID = page "The web" (Just Configuration) $ do $(widgetFile "configurators/edit/webrepository") | otherwise = page "Edit repository" (Just Configuration) $ do mremote <- liftAnnex $ Remote.remoteFromUUID uuid diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -78,7 +78,7 @@ -- Box.com has a max file size of 100 mb, but -- using smaller chunks has better memory -- performance. - , ("chunksize", "10mb") + , ("chunk", "10mb") ] _ -> $(widgetFile "configurators/addbox.com") #else diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -10,10 +10,13 @@ import Build.TestConfig import Build.Version +import Utility.PartialPrelude +import Utility.Process import Utility.SafeCommand import Utility.ExternalSHA import Utility.Env import qualified Git.Version +import Utility.DottedVersion tests :: [TestCase] tests = @@ -29,6 +32,7 @@ , TestCase "rsync" $ requireCmd "rsync" "rsync --version >/dev/null" , TestCase "curl" $ testCmd "curl" "curl --version >/dev/null" , TestCase "wget" $ testCmd "wget" "wget --version >/dev/null" + , TestCase "wget supports -q --show-progress" checkWgetQuietProgress , TestCase "bup" $ testCmd "bup" "bup --version >/dev/null" , TestCase "nice" $ testCmd "nice" "nice true >/dev/null" , TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null" @@ -95,6 +99,18 @@ when (v < oldestallowed) $ error $ "installed git version " ++ show v ++ " is too old! (Need " ++ show oldestallowed ++ " or newer)" return $ Config "gitversion" $ StringConfig $ show v + +checkWgetQuietProgress :: Test +checkWgetQuietProgress = Config "wgetquietprogress" . BoolConfig + . maybe False (>= normalize "1.16") + <$> getWgetVersion + +getWgetVersion :: IO (Maybe DottedVersion) +getWgetVersion = extract <$> readProcess "wget" ["--version"] + where + extract s = case lines s of + [] -> Nothing + (l:_) -> normalize <$> headMaybe (drop 2 $ words l) getSshConnectionCaching :: Test getSshConnectionCaching = Config "sshconnectioncaching" . BoolConfig <$> diff --git a/BuildFlags.hs b/BuildFlags.hs --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -86,6 +86,11 @@ #else #warning Building without CryptoHash. #endif +#ifdef WITH_TORRENTParser + , "TorrentParser" +#else +#warning Building without haskell torrent library; will instead use btshowmetainfo to parse torrent files. +#endif #ifdef WITH_EKG , "EKG" #endif diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,26 @@ +git-annex (5.20141219) unstable; urgency=medium + + * Webapp: When adding a new box.com remote, use the new style chunking. + Thanks, Jon Ander Peñalba. + * External special remote protocol now includes commands for setting + and getting the urls associated with a key. + * Urls can now be claimed by remotes. This will allow creating, + for example, a external special remote that handles magnet: and + *.torrent urls. + * Use wget -q --show-progress for less verbose wget output, + when built with wget 1.16. + * Added bittorrent special remote. + * addurl behavior change: When downloading an url ending in .torrent, + it will download files from bittorrent, instead of the old behavior + of adding the torrent file to the repository. + * Added Recommends on aria2. + * When possible, build with the haskell torrent library for parsing + torrent files. As a fallback, can instead use btshowmetainfo from + bittornado | bittorrent. + * Fix build with -f-S3. + + -- Joey Hess Fri, 19 Dec 2014 16:53:26 -0400 + git-annex (5.20141203) unstable; urgency=medium * proxy: New command for direct mode repositories, allows bypassing diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -19,13 +19,18 @@ import qualified Annex.Queue import qualified Annex.Url as Url import qualified Backend.URL +import qualified Remote +import qualified Types.Remote as Remote import Annex.Content +import Annex.UUID import Logs.Web import Types.Key import Types.KeySource +import Types.UrlContents import Config import Annex.Content.Direct import Logs.Location +import Utility.Metered import qualified Annex.Transfer as Transfer #ifdef WITH_QUVI import Annex.Quvi @@ -47,22 +52,83 @@ relaxedOption = flagOption [] "relaxed" "skip size check" seek :: CommandSeek -seek ps = do - f <- getOptionField fileOption return +seek us = do + optfile <- getOptionField fileOption return relaxed <- getOptionFlag relaxedOption - d <- getOptionField pathdepthOption (return . maybe Nothing readish) - withStrings (start relaxed f d) ps + pathdepth <- getOptionField pathdepthOption (return . maybe Nothing readish) + forM_ us $ \u -> do + r <- Remote.claimingUrl u + if Remote.uuid r == webUUID + then void $ commandAction $ startWeb relaxed optfile pathdepth u + else do + pathmax <- liftIO $ fileNameLengthLimit "." + let deffile = fromMaybe (urlString2file u pathdepth pathmax) optfile + res <- tryNonAsync $ maybe + (error $ "unable to checkUrl of " ++ Remote.name r) + (flip id u) + (Remote.checkUrl r) + case res of + Left e -> void $ commandAction $ do + showStart "addurl" u + warning (show e) + next $ next $ return False + Right (UrlContents sz mf) -> do + void $ commandAction $ + startRemote r relaxed (maybe deffile fromSafeFilePath mf) u sz + Right (UrlMulti l) -> + forM_ l $ \(u', sz, f) -> + void $ commandAction $ + startRemote r relaxed (deffile fromSafeFilePath f) u' sz -start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart -start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s +startRemote :: Remote -> Bool -> FilePath -> URLString -> Maybe Integer -> CommandStart +startRemote r relaxed file uri sz = do + pathmax <- liftIO $ fileNameLengthLimit "." + let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file + showStart "addurl" file' + showNote $ "from " ++ Remote.name r + next $ performRemote r relaxed uri file' sz + +performRemote :: Remote -> Bool -> URLString -> FilePath -> Maybe Integer -> CommandPerform +performRemote r relaxed uri file sz = ifAnnexed file adduri geturi where + loguri = setDownloader uri OtherDownloader + adduri = addUrlChecked relaxed loguri (Remote.uuid r) checkexistssize + checkexistssize key = return $ case sz of + Nothing -> (True, True) + Just n -> (True, n == fromMaybe n (keySize key)) + geturi = next $ isJust <$> downloadRemoteFile r relaxed uri file sz + +downloadRemoteFile :: Remote -> Bool -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key) +downloadRemoteFile r relaxed uri file sz = do + urlkey <- Backend.URL.fromUrl uri sz + liftIO $ createDirectoryIfMissing True (parentDir file) + ifM (Annex.getState Annex.fast <||> pure relaxed) + ( do + cleanup (Remote.uuid r) loguri file urlkey Nothing + return (Just urlkey) + , do + -- Set temporary url for the urlkey + -- so that the remote knows what url it + -- should use to download it. + setTempUrl urlkey loguri + let downloader = Remote.retrieveKeyFile r urlkey (Just file) + ret <- downloadWith downloader urlkey (Remote.uuid r) loguri file + removeTempUrl urlkey + return ret + ) + where + loguri = setDownloader uri OtherDownloader + +startWeb :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart +startWeb relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s + where (s', downloader) = getDownloader s bad = fromMaybe (error $ "bad url " ++ s') $ parseURI $ escapeURIString isUnescapedInURI s' choosefile = flip fromMaybe optfile go url = case downloader of QuviDownloader -> usequvi - DefaultDownloader -> + _ -> #ifdef WITH_QUVI ifM (quviSupported s') ( usequvi @@ -75,7 +141,7 @@ pathmax <- liftIO $ fileNameLengthLimit "." let file = choosefile $ url2file url pathdepth pathmax showStart "addurl" file - next $ perform relaxed s' file + next $ performWeb relaxed s' file #ifdef WITH_QUVI badquvi = error $ "quvi does not know how to download url " ++ s' usequvi = do @@ -91,12 +157,21 @@ usequvi = error "not built with quvi support" #endif +performWeb :: Bool -> URLString -> FilePath -> CommandPerform +performWeb relaxed url file = ifAnnexed file addurl geturl + where + geturl = next $ isJust <$> addUrlFile relaxed url file + addurl = addUrlChecked relaxed url webUUID checkexistssize + checkexistssize = Url.withUrlOptions . Url.check url . keySize + #ifdef WITH_QUVI performQuvi :: Bool -> URLString -> URLString -> FilePath -> CommandPerform performQuvi relaxed pageurl videourl file = ifAnnexed file addurl geturl where quviurl = setDownloader pageurl QuviDownloader - addurl key = next $ cleanup quviurl file key Nothing + addurl key = next $ do + cleanup webUUID quviurl file key Nothing + return True geturl = next $ isJust <$> addUrlFileQuvi relaxed quviurl videourl file #endif @@ -106,7 +181,7 @@ key <- Backend.URL.fromUrl quviurl Nothing ifM (pure relaxed <||> Annex.getState Annex.fast) ( do - cleanup' quviurl file key Nothing + cleanup webUUID quviurl file key Nothing return (Just key) , do {- Get the size, and use that to check @@ -124,55 +199,58 @@ downloadUrl [videourl] tmp if ok then do - cleanup' quviurl file key (Just tmp) + cleanup webUUID quviurl file key (Just tmp) return (Just key) else return Nothing ) #endif -perform :: Bool -> URLString -> FilePath -> CommandPerform -perform relaxed url file = ifAnnexed file addurl geturl - where - geturl = next $ isJust <$> addUrlFile relaxed url file - addurl key - | relaxed = do - setUrlPresent key url - next $ return True - | otherwise = ifM (elem url <$> getUrls key) - ( stop - , do - (exists, samesize) <- Url.withUrlOptions $ Url.check url (keySize key) - if exists && samesize - then do - setUrlPresent key url - next $ return True - else do - warning $ "while adding a new url to an already annexed file, " ++ if exists - then "url does not have expected file size (use --relaxed to bypass this check) " ++ url - else "failed to verify url exists: " ++ url - stop - ) +addUrlChecked :: Bool -> URLString -> UUID -> (Key -> Annex (Bool, Bool)) -> Key -> CommandPerform +addUrlChecked relaxed url u checkexistssize key + | relaxed = do + setUrlPresent u key url + next $ return True + | otherwise = ifM (elem url <$> getUrls key) + ( next $ return True -- nothing to do + , do + (exists, samesize) <- checkexistssize key + if exists && samesize + then do + setUrlPresent u key url + next $ return True + else do + warning $ "while adding a new url to an already annexed file, " ++ if exists + then "url does not have expected file size (use --relaxed to bypass this check) " ++ url + else "failed to verify url exists: " ++ url + stop + ) addUrlFile :: Bool -> URLString -> FilePath -> Annex (Maybe Key) addUrlFile relaxed url file = do liftIO $ createDirectoryIfMissing True (parentDir file) ifM (Annex.getState Annex.fast <||> pure relaxed) ( nodownload relaxed url file - , do - showAction $ "downloading " ++ url ++ " " - download url file + , downloadWeb url file ) -download :: URLString -> FilePath -> Annex (Maybe Key) -download url file = do - {- Generate a dummy key to use for this download, before we can - - examine the file and find its real key. This allows resuming - - downloads, as the dummy key for a given url is stable. -} +downloadWeb :: URLString -> FilePath -> Annex (Maybe Key) +downloadWeb url file = do dummykey <- addSizeUrlKey url =<< Backend.URL.fromUrl url Nothing + let downloader f _ = do + showOutput + downloadUrl [url] f + showAction $ "downloading " ++ url ++ " " + downloadWith downloader dummykey webUUID url file + +{- The Key should be a dummy key, based on the URL, which is used + - for this download, before we can examine the file and find its real key. + - For resuming downloads to work, the dummy key for a given url should be + - stable. -} +downloadWith :: (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key) +downloadWith downloader dummykey u url file = prepGetViaTmpChecked dummykey Nothing $ do tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey - showOutput - ifM (runtransfer dummykey tmp) + ifM (runtransfer tmp) ( do backend <- chooseBackend file let source = KeySource @@ -184,15 +262,15 @@ case k of Nothing -> return Nothing Just (key, _) -> do - cleanup' url file key (Just tmp) + cleanup u url file key (Just tmp) return (Just key) , return Nothing ) where - runtransfer dummykey tmp = Transfer.notifyTransfer Transfer.Download (Just file) $ - Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do + runtransfer tmp = Transfer.notifyTransfer Transfer.Download (Just file) $ + Transfer.download u dummykey (Just file) Transfer.forwardRetry $ \p -> do liftIO $ createDirectoryIfMissing True (parentDir tmp) - downloadUrl [url] tmp + downloader tmp p {- Hits the url to get the size, if available. - @@ -204,16 +282,11 @@ size <- snd <$> Url.withUrlOptions (Url.exists url) return $ key { keySize = size } -cleanup :: URLString -> FilePath -> Key -> Maybe FilePath -> Annex Bool -cleanup url file key mtmp = do - cleanup' url file key mtmp - return True - -cleanup' :: URLString -> FilePath -> Key -> Maybe FilePath -> Annex () -cleanup' url file key mtmp = do +cleanup :: UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex () +cleanup u url file key mtmp = do when (isJust mtmp) $ logStatus key InfoPresent - setUrlPresent key url + setUrlPresent u key url Command.Add.addLink file key Nothing whenM isDirect $ do void $ addAssociatedFile key file @@ -230,7 +303,7 @@ if exists then do key <- Backend.URL.fromUrl url size - cleanup' url file key Nothing + cleanup webUUID url file key Nothing return (Just key) else do warning $ "unable to access url: " ++ url @@ -245,8 +318,16 @@ | depth < 0 -> frombits $ reverse . take (negate depth) . reverse | otherwise -> error "bad --pathdepth" where - fullurl = uriRegName auth ++ uriPath url ++ uriQuery url + fullurl = concat + [ maybe "" uriRegName (uriAuthority url) + , uriPath url + , uriQuery url + ] frombits a = intercalate "/" $ a urlbits urlbits = map (truncateFilePath pathmax . sanitizeFilePath) $ filter (not . null) $ split "/" fullurl - auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url + +urlString2file :: URLString -> Maybe Int -> Int -> FilePath +urlString2file s pathdepth pathmax = case Url.parseURIRelaxed s of + Nothing -> error $ "bad uri " ++ s + Just u -> url2file u pathdepth pathmax diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -22,11 +22,15 @@ import qualified Annex import Command import qualified Annex.Url as Url +import qualified Remote +import qualified Types.Remote as Remote +import Types.UrlContents import Logs.Web import qualified Utility.Format import Utility.Tmp -import Command.AddUrl (addUrlFile, relaxedOption) +import Command.AddUrl (addUrlFile, downloadRemoteFile, relaxedOption) import Annex.Perms +import Annex.UUID import Backend.URL (fromUrl) #ifdef WITH_QUVI import Annex.Quvi @@ -137,9 +141,29 @@ performDownload :: Bool -> Cache -> ToDownload -> Annex Bool performDownload relaxed cache todownload = case location todownload of Enclosure url -> checkknown url $ - rundownload url (takeExtension url) $ - addUrlFile relaxed url + rundownload url (takeExtension url) $ \f -> do + r <- Remote.claimingUrl url + if Remote.uuid r == webUUID + then maybeToList <$> addUrlFile relaxed url f + else do + res <- tryNonAsync $ maybe + (error $ "unable to checkUrl of " ++ Remote.name r) + (flip id url) + (Remote.checkUrl r) + case res of + Left _ -> return [] + Right (UrlContents sz _) -> + maybeToList <$> + downloadRemoteFile r relaxed url f sz + Right (UrlMulti l) -> do + kl <- forM l $ \(url', sz, subf) -> + downloadRemoteFile r relaxed url' (f fromSafeFilePath subf) sz + return $ if all isJust kl + then catMaybes kl + else [] + QuviLink pageurl -> do +#ifdef WITH_QUVI let quviurl = setDownloader pageurl QuviDownloader checkknown quviurl $ do mp <- withQuviOptions Quvi.query [Quvi.quiet, Quvi.httponly] pageurl @@ -150,8 +174,11 @@ Just link -> do let videourl = Quvi.linkUrl link checkknown videourl $ - rundownload videourl ("." ++ Quvi.linkSuffix link) $ - addUrlFileQuvi relaxed quviurl videourl + rundownload videourl ("." ++ Quvi.linkSuffix link) $ \f -> + maybeToList <$> addUrlFileQuvi relaxed quviurl videourl f +#else + return False +#endif where forced = Annex.getState Annex.force @@ -168,16 +195,17 @@ Nothing -> return True Just f -> do showStart "addurl" f - mk <- getter f - case mk of - Just key -> do - whenM (annexGenMetaData <$> Annex.getGitConfig) $ - addMetaData key $ extractMetaData todownload - showEndOk - return True - Nothing -> do + ks <- getter f + if null ks + then do showEndFail checkFeedBroken (feedurl todownload) + else do + forM_ ks $ \key -> + whenM (annexGenMetaData <$> Annex.getGitConfig) $ + addMetaData key $ extractMetaData todownload + showEndOk + return True {- Find a unique filename to save the url to. - If the file exists, prefixes it with a number. diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -16,6 +16,7 @@ import Logs.Web import Logs.Location import Utility.CopyFile +import qualified Remote cmd :: [Command] cmd = [notDirect $ command "rekey" @@ -61,8 +62,9 @@ -- If the old key had some associated urls, record them for -- the new key as well. urls <- getUrls oldkey - unless (null urls) $ - mapM_ (setUrlPresent newkey) urls + forM_ urls $ \url -> do + r <- Remote.claimingUrl url + setUrlPresent (Remote.uuid r) newkey url -- Update symlink to use the new key. liftIO $ removeFile file diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -10,6 +10,8 @@ import Common.Annex import Command import Logs.Web +import Annex.UUID +import qualified Remote cmd :: [Command] cmd = [notBareRepo $ @@ -26,5 +28,9 @@ cleanup :: String -> Key -> CommandCleanup cleanup url key = do - setUrlMissing key url + r <- Remote.claimingUrl url + let url' = if Remote.uuid r == webUUID + then url + else setDownloader url OtherDownloader + setUrlMissing (Remote.uuid r) key url' return True diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010 Joey Hess + - Copyright 2010-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -13,6 +13,7 @@ import Command import Remote import Logs.Trust +import Logs.Web cmd :: [Command] cmd = [noCommit $ withOptions (jsonOption : keyOptions) $ @@ -57,9 +58,17 @@ untrustedheader = "The following untrusted locations may also have copies:\n" performRemote :: Key -> Remote -> Annex () -performRemote key remote = maybe noop go $ whereisKey remote +performRemote key remote = do + ls <- (++) + <$> askremote + <*> claimedurls + unless (null ls) $ showLongNote $ unlines $ + map (\l -> name remote ++ ": " ++ l) ls where - go a = do - ls <- a key - unless (null ls) $ showLongNote $ unlines $ - map (\l -> name remote ++ ": " ++ l) ls + askremote = maybe (pure []) (flip id key) (whereisKey remote) + claimedurls = do + us <- map fst + . filter (\(_, d) -> d == OtherDownloader) + . map getDownloader + <$> getUrls key + filterM (\u -> (==) <$> pure remote <*> claimingUrl u) us diff --git a/Git/Version.hs b/Git/Version.hs --- a/Git/Version.hs +++ b/Git/Version.hs @@ -5,18 +5,16 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Git.Version where +module Git.Version ( + installed, + normalize, + GitVersion, +) where import Common - -data GitVersion = GitVersion String Integer - deriving (Eq) - -instance Ord GitVersion where - compare (GitVersion _ x) (GitVersion _ y) = compare x y +import Utility.DottedVersion -instance Show GitVersion where - show (GitVersion s _) = s +type GitVersion = DottedVersion installed :: IO GitVersion installed = normalize . extract <$> readProcess "git" ["--version"] @@ -24,20 +22,3 @@ extract s = case lines s of [] -> "" (l:_) -> unwords $ drop 2 $ words l - -{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to - - a somewhat arbitrary integer representation. -} -normalize :: String -> GitVersion -normalize v = GitVersion v $ - sum $ mult 1 $ reverse $ extend precision $ take precision $ - map readi $ split "." v - where - extend n l = l ++ replicate (n - length l) 0 - mult _ [] = [] - mult n (x:xs) = (n*x) : mult (n*10^width) xs - readi :: String -> Integer - readi s = case reads s of - ((x,_):_) -> x - _ -> 0 - precision = 10 -- number of segments of the version to compare - width = length "yyyymmddhhmmss" -- maximum width of a segment diff --git a/Logs/Trust.hs b/Logs/Trust.hs --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -15,7 +15,6 @@ trustExclude, lookupTrust, trustMapLoad, - trustMapRaw, ) where import qualified Data.Map as M @@ -23,7 +22,6 @@ import Common.Annex import Types.TrustLevel -import qualified Annex.Branch import qualified Annex import Logs import Remote.List @@ -77,8 +75,3 @@ configuredtrust r = (\l -> Just (Types.Remote.uuid r, l)) =<< readTrustLevel =<< remoteAnnexTrustLevel (Types.Remote.gitconfig r) - -{- Does not include forcetrust or git config values, just those from the - - log file. -} -trustMapRaw :: Annex TrustMap -trustMapRaw = calcTrustMap <$> Annex.Branch.get trustLog diff --git a/Logs/Trust/Basic.hs b/Logs/Trust/Basic.hs --- a/Logs/Trust/Basic.hs +++ b/Logs/Trust/Basic.hs @@ -8,6 +8,7 @@ module Logs.Trust.Basic ( module X, trustSet, + trustMapRaw, ) where import Data.Time.Clock.POSIX @@ -30,3 +31,8 @@ parseLog (Just . parseTrustLog) Annex.changeState $ \s -> s { Annex.trustmap = Nothing } trustSet NoUUID _ = error "unknown UUID; cannot modify" + +{- Does not include forcetrust or git config values, just those from the + - log file. -} +trustMapRaw :: Annex TrustMap +trustMapRaw = calcTrustMap <$> Annex.Branch.get trustLog diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -1,26 +1,30 @@ {- Web url logs. - - - Copyright 2011, 2013 Joey Hess + - Copyright 2011-2014 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Logs.Web ( URLString, - webUUID, getUrls, + getUrlsWithPrefix, setUrlPresent, setUrlMissing, knownUrls, Downloader(..), getDownloader, setDownloader, + setTempUrl, + removeTempUrl, ) where import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Map as M import Data.Tuple.Utils import Common.Annex +import qualified Annex import Logs import Logs.Presence import Logs.Location @@ -28,16 +32,14 @@ import Annex.CatFile import qualified Git import qualified Git.LsFiles - -type URLString = String - --- Dummy uuid for the whole web. Do not alter. -webUUID :: UUID -webUUID = UUID "00000000-0000-0000-0000-000000000001" +import Utility.Url {- Gets all urls that a key might be available from. -} getUrls :: Key -> Annex [URLString] -getUrls key = go $ urlLogFile key : oldurlLogs key +getUrls key = do + l <- go $ urlLogFile key : oldurlLogs key + tmpl <- Annex.getState (maybeToList . M.lookup key . Annex.tempurls) + return (tmpl ++ l) where go [] = return [] go (l:ls) = do @@ -46,19 +48,21 @@ then go ls else return us -setUrlPresent :: Key -> URLString -> Annex () -setUrlPresent key url = do +getUrlsWithPrefix :: Key -> String -> Annex [URLString] +getUrlsWithPrefix key prefix = filter (prefix `isPrefixOf`) <$> getUrls key + +setUrlPresent :: UUID -> Key -> URLString -> Annex () +setUrlPresent uuid key url = do us <- getUrls key unless (url `elem` us) $ do addLog (urlLogFile key) =<< logNow InfoPresent url - -- update location log to indicate that the web has the key - logChange key webUUID InfoPresent + logChange key uuid InfoPresent -setUrlMissing :: Key -> URLString -> Annex () -setUrlMissing key url = do +setUrlMissing :: UUID -> Key -> URLString -> Annex () +setUrlMissing uuid key url = do addLog (urlLogFile key) =<< logNow InfoMissing url whenM (null <$> getUrls key) $ - logChange key webUUID InfoMissing + logChange key uuid InfoMissing {- Finds all known urls. -} knownUrls :: Annex [URLString] @@ -78,18 +82,27 @@ geturls Nothing = return [] geturls (Just logsha) = getLog . L.unpack <$> catObject logsha -data Downloader = DefaultDownloader | QuviDownloader +setTempUrl :: Key -> URLString -> Annex () +setTempUrl key url = Annex.changeState $ \s -> + s { Annex.tempurls = M.insert key url (Annex.tempurls s) } -{- Determines the downloader for an URL. - - - - Some URLs are not downloaded by normal means, and this is indicated - - by prefixing them with downloader: when they are recorded in the url - - logs. -} +removeTempUrl :: Key -> Annex () +removeTempUrl key = Annex.changeState $ \s -> + s { Annex.tempurls = M.delete key (Annex.tempurls s) } + +data Downloader = WebDownloader | QuviDownloader | OtherDownloader + deriving (Eq) + +{- To keep track of how an url is downloaded, it's mangled slightly in + - the log. For quvi, "quvi:" is prefixed. For urls that are handled by + - some other remote, ":" is prefixed. -} +setDownloader :: URLString -> Downloader -> String +setDownloader u WebDownloader = u +setDownloader u QuviDownloader = "quvi:" ++ u +setDownloader u OtherDownloader = ":" ++ u + getDownloader :: URLString -> (URLString, Downloader) getDownloader u = case separate (== ':') u of ("quvi", u') -> (u', QuviDownloader) - _ -> (u, DefaultDownloader) - -setDownloader :: URLString -> Downloader -> URLString -setDownloader u DefaultDownloader = u -setDownloader u QuviDownloader = "quvi:" ++ u + ("", u') -> (u', OtherDownloader) + _ -> (u, WebDownloader) diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -45,7 +45,8 @@ forceTrust, logStatus, checkAvailable, - isXMPPRemote + isXMPPRemote, + claimingUrl, ) where import qualified Data.Map as M @@ -60,6 +61,7 @@ import Logs.UUID import Logs.Trust import Logs.Location hiding (logStatus) +import Logs.Web import Remote.List import Config import Git.Types (RemoteName) @@ -318,3 +320,12 @@ 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/BitTorrent.hs b/Remote/BitTorrent.hs new file mode 100644 --- /dev/null +++ b/Remote/BitTorrent.hs @@ -0,0 +1,390 @@ +{- BitTorrent remote. + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Remote.BitTorrent (remote) where + +import Common.Annex +import Types.Remote +import qualified Annex +import qualified Git +import qualified Git.Construct +import Config.Cost +import Logs.Web +import Types.UrlContents +import Types.CleanupActions +import Types.Key +import Utility.Metered +import Utility.Tmp +import Backend.URL +import Annex.Perms +import Annex.UUID +import qualified Annex.Url as Url + +import Network.URI + +#ifdef WITH_TORRENTPARSER +import Data.Torrent +import qualified Data.ByteString.Lazy as B +#endif + +remote :: RemoteType +remote = RemoteType { + typename = "bittorrent", + enumerate = list, + generate = gen, + setup = error "not supported" +} + +-- There is only one bittorrent remote, and it always exists. +list :: Annex [Git.Repo] +list = do + r <- liftIO $ Git.Construct.remoteNamed "bittorrent" Git.Construct.fromUnknown + return [r] + +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) +gen r _ c gc = + return $ Just Remote + { uuid = bitTorrentUUID + , cost = expensiveRemoteCost + , name = Git.repoDescribe r + , storeKey = uploadKey + , retrieveKeyFile = downloadKey + , retrieveKeyFileCheap = downloadKeyCheap + , removeKey = dropKey + , checkPresent = checkKey + , checkPresentCheap = False + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , gitconfig = gc + , localpath = Nothing + , repo = r + , readonly = True + , availability = GloballyAvailable + , remotetype = remote + , mkUnavailable = return Nothing + , getInfo = return [] + , claimUrl = Just (pure . isSupportedUrl) + , checkUrl = Just checkTorrentUrl + } + +downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool +downloadKey key _file dest p = + get . map (torrentUrlNum . fst . getDownloader) =<< getBitTorrentUrls key + where + get [] = do + warning "could not download torrent" + return False + get urls = do + showOutput -- make way for download progress bar + untilTrue urls $ \(u, filenum) -> do + registerTorrentCleanup u + checkDependencies + ifM (downloadTorrentFile u) + ( downloadTorrentContent key u dest filenum p + , return False + ) + +downloadKeyCheap :: Key -> FilePath -> Annex Bool +downloadKeyCheap _ _ = return False + +uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool +uploadKey _ _ _ = do + warning "upload to bittorrent not supported" + return False + +dropKey :: Key -> Annex Bool +dropKey k = do + mapM_ (setUrlMissing bitTorrentUUID k) =<< getBitTorrentUrls k + return True + +{- We punt and don't try to check if a torrent has enough seeders + - with all the pieces etc. That would be quite hard.. and even if + - implemented, it tells us nothing about the later state of the torrent. + -} +checkKey :: Key -> Annex Bool +checkKey = error "cannot reliably check torrent status" + +getBitTorrentUrls :: Key -> Annex [URLString] +getBitTorrentUrls key = filter supported <$> getUrls key + where + supported u = + let (u', dl) = (getDownloader u) + in dl == OtherDownloader && isSupportedUrl u' + +isSupportedUrl :: URLString -> Bool +isSupportedUrl u = isTorrentMagnetUrl u || isTorrentUrl u + +isTorrentUrl :: URLString -> Bool +isTorrentUrl = maybe False (\u -> ".torrent" `isSuffixOf` uriPath u) . parseURI + +isTorrentMagnetUrl :: URLString -> Bool +isTorrentMagnetUrl u = "magnet:" `isPrefixOf` u && checkbt (parseURI u) + where + checkbt (Just uri) | "xt=urn:btih:" `isInfixOf` uriQuery uri = True + checkbt _ = False + +checkTorrentUrl :: URLString -> Annex UrlContents +checkTorrentUrl u = do + checkDependencies + registerTorrentCleanup u + ifM (downloadTorrentFile u) + ( torrentContents u + , error "could not download torrent file" + ) + +{- To specify which file inside a multi-url torrent, the file number is + - appended to the url. -} +torrentUrlWithNum :: URLString -> Int -> URLString +torrentUrlWithNum u n = u ++ "#" ++ show n + +torrentUrlNum :: URLString -> (URLString, Int) +torrentUrlNum u + | '#' `elem` u = + let (n, ru) = separate (== '#') (reverse u) + in (reverse ru, fromMaybe 1 $ readish $ reverse n) + | otherwise = (u, 1) + +{- A Key corresponding to the URL of a torrent file. -} +torrentUrlKey :: URLString -> Annex Key +torrentUrlKey u = fromUrl (fst $ torrentUrlNum u) Nothing + +{- Temporary directory used to download a torrent. -} +tmpTorrentDir :: URLString -> Annex FilePath +tmpTorrentDir u = do + d <- fromRepo gitAnnexTmpMiscDir + f <- keyFile <$> torrentUrlKey u + return (d f) + +{- Temporary filename to use to store the torrent file. -} +tmpTorrentFile :: URLString -> Annex FilePath +tmpTorrentFile u = fromRepo . gitAnnexTmpObjectLocation =<< torrentUrlKey u + +{- A cleanup action is registered to delete the torrent file and its + - associated temp directory when git-annex exits. + - + - This allows multiple actions that use the same torrent file and temp + - directory to run in a single git-annex run. + -} +registerTorrentCleanup :: URLString -> Annex () +registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $ do + liftIO . nukeFile =<< tmpTorrentFile u + d <- tmpTorrentDir u + liftIO $ whenM (doesDirectoryExist d) $ + removeDirectoryRecursive d + +{- Downloads the torrent file. (Not its contents.) -} +downloadTorrentFile :: URLString -> Annex Bool +downloadTorrentFile u = do + torrent <- tmpTorrentFile u + ifM (liftIO $ doesFileExist torrent) + ( return True + , do + showAction "downloading torrent file" + showOutput + createAnnexDirectory (parentDir torrent) + if isTorrentMagnetUrl u + then do + tmpdir <- tmpTorrentDir u + let metadir = tmpdir "meta" + createAnnexDirectory metadir + ok <- downloadMagnetLink u metadir torrent + liftIO $ removeDirectoryRecursive metadir + return ok + else do + misctmp <- fromRepo gitAnnexTmpMiscDir + withTmpFileIn misctmp "torrent" $ \f _h -> do + ok <- Url.withUrlOptions $ Url.download u f + when ok $ + liftIO $ renameFile f torrent + return ok + ) + +downloadMagnetLink :: URLString -> FilePath -> FilePath -> Annex Bool +downloadMagnetLink u metadir dest = ifM download + ( liftIO $ do + ts <- filter (".torrent" `isPrefixOf`) + <$> dirContents metadir + case ts of + (t:[]) -> do + renameFile t dest + return True + _ -> return False + , return False + ) + where + download = runAria + [ Param "--bt-metadata-only" + , Param "--bt-save-metadata" + , Param u + , Param "--seed-time=0" + , Param "--summary-interval=0" + , Param "-d" + , File metadir + ] + +downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool +downloadTorrentContent k u dest filenum p = do + torrent <- tmpTorrentFile u + tmpdir <- tmpTorrentDir u + createAnnexDirectory tmpdir + f <- wantedfile torrent + showOutput + ifM (download torrent tmpdir <&&> liftIO (doesFileExist (tmpdir f))) + ( do + liftIO $ renameFile (tmpdir f) dest + return True + , return False + ) + where + download torrent tmpdir = ariaProgress (keySize k) p + [ Param $ "--select-file=" ++ show filenum + , File torrent + , Param "-d" + , File tmpdir + , Param "--seed-time=0" + , Param "--summary-interval=0" + , Param "--file-allocation=none" + -- Needed so aria will resume partially downloaded files + -- in multi-file torrents. + , Param "--check-integrity=true" + ] + + {- aria2c will create part of the directory structure + - contained in the torrent. It may download parts of other files + - in addition to the one we asked for. So, we need to find + - out the filename we want based on the filenum. + -} + wantedfile torrent = do + fs <- liftIO $ map fst <$> torrentFileSizes torrent + if length fs >= filenum + then return (fs !! (filenum - 1)) + else error "Number of files in torrent seems to have changed." + +checkDependencies :: Annex () +checkDependencies = do + missing <- liftIO $ filterM (not <$$> inPath) deps + unless (null missing) $ + error $ "need to install additional software in order to download from bittorrent: " ++ unwords missing + where + deps = + [ "aria2c" +#ifndef TORRENT + , "btshowmetainfo" +#endif + ] + +ariaParams :: [CommandParam] -> Annex [CommandParam] +ariaParams ps = do + opts <- map Param . annexAriaTorrentOptions <$> Annex.getGitConfig + return (ps ++ opts) + +runAria :: [CommandParam] -> Annex Bool +runAria ps = liftIO . boolSystem "aria2c" =<< ariaParams ps + +-- Parse aria output to find "(n%)" and update the progress meter +-- with it. The output is also output to stdout. +ariaProgress :: Maybe Integer -> MeterUpdate -> [CommandParam] -> Annex Bool +ariaProgress Nothing _ ps = runAria ps +ariaProgress (Just sz) meter ps = + liftIO . commandMeter (parseAriaProgress sz) meter "aria2c" + =<< ariaParams ps + +parseAriaProgress :: Integer -> ProgressParser +parseAriaProgress totalsize = go [] . reverse . split ['\r'] + where + go remainder [] = (Nothing, remainder) + go remainder (x:xs) = case readish (findpercent x) of + Nothing -> go (x++remainder) xs + Just p -> (Just (frompercent p), remainder) + + -- "(N%)" + findpercent = takeWhile (/= '%') . drop 1 . dropWhile (/= '(') + + frompercent p = toBytesProcessed $ totalsize * p `div` 100 + +{- Used only if the haskell torrent library is not available. -} +#ifndef WITH_TORRENTPARSER +btshowmetainfo :: FilePath -> String -> IO [String] +btshowmetainfo torrent field = + findfield [] . lines <$> readProcess "btshowmetainfo" [torrent] + where + findfield c [] = reverse c + findfield c (l:ls) + | l == fieldkey = multiline c ls + | fieldkey `isPrefixOf` l = + findfield ((drop (length fieldkey) l):c) ls + | otherwise = findfield c ls + + multiline c (l:ls) + | " " `isPrefixOf` l = multiline (drop 3 l:c) ls + | otherwise = findfield c ls + multiline c [] = findfield c [] + + fieldkey = field ++ take (14 - length field) (repeat '.') ++ ": " +#endif + +{- Examines the torrent file and gets the list of files in it, + - and their sizes. + -} +torrentFileSizes :: FilePath -> IO [(FilePath, Integer)] +torrentFileSizes torrent = do +#ifdef WITH_TORRENTPARSER + let mkfile = joinPath . map (scrub . decodeBS) + b <- B.readFile torrent + return $ case readTorrent b of + Left e -> error $ "failed to parse torrent: " ++ e + Right t -> case tInfo t of + SingleFile { tLength = l, tName = f } -> + [ (mkfile [f], l) ] + MultiFile { tFiles = fs, tName = dir } -> + map (\tf -> (mkfile $ dir:filePath tf, fileLength tf)) fs + where +#else + files <- getfield "files" + if null files + then do + fnl <- getfield "file name" + szl <- map readish <$> getfield "file size" + case (fnl, szl) of + ((fn:[]), (Just sz:[])) -> return [(scrub fn, sz)] + _ -> parsefailed (show (fnl, szl)) + else do + v <- getfield "directory name" + case v of + (d:[]) -> return $ map (splitsize d) files + _ -> parsefailed (show v) + where + getfield = btshowmetainfo torrent + parsefailed s = error $ "failed to parse btshowmetainfo output for torrent file: " ++ show s + + -- btshowmetainfo outputs a list of "filename (size)" + splitsize d l = (scrub (d fn), sz) + where + sz = fromMaybe (parsefailed l) $ readish $ + reverse $ takeWhile (/= '(') $ dropWhile (== ')') $ + reverse l + fn = reverse $ drop 2 $ + dropWhile (/= '(') $ dropWhile (== ')') $ reverse l +#endif + -- a malicious torrent file might try to do directory traversal + scrub f = if isAbsolute f || any (== "..") (splitPath f) + then error "found unsafe filename in torrent!" + else f + +torrentContents :: URLString -> Annex UrlContents +torrentContents u = convert + <$> (liftIO . torrentFileSizes =<< tmpTorrentFile u) + where + convert [(fn, sz)] = UrlContents (Just sz) (Just (mkSafeFilePath fn)) + convert l = UrlMulti $ map mkmulti (zip l [1..]) + + mkmulti ((fn, sz), n) = + (torrentUrlWithNum u n, Just sz, mkSafeFilePath $ joinPath $ drop 1 $ splitPath fn) diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -74,6 +74,8 @@ , readonly = False , mkUnavailable = return Nothing , getInfo = return [("repo", buprepo)] + , claimUrl = Nothing + , checkUrl = Nothing } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store this buprepo) diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -71,6 +71,8 @@ , readonly = False , mkUnavailable = return Nothing , getInfo = return [("repo", ddarrepo)] + , claimUrl = Nothing + , checkUrl = Nothing } ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc specialcfg = (specialRemoteCfg c) diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -46,30 +46,32 @@ (retrieve dir chunkconfig) (simplyPrepare $ remove dir) (simplyPrepare $ checkKey dir chunkconfig) - Remote { - uuid = u, - cost = cst, - name = Git.repoDescribe r, - storeKey = storeKeyDummy, - retrieveKeyFile = retreiveKeyFileDummy, - retrieveKeyFileCheap = retrieveCheap dir chunkconfig, - removeKey = removeKeyDummy, - checkPresent = checkPresentDummy, - checkPresentCheap = True, - whereisKey = Nothing, - remoteFsck = Nothing, - repairRepo = Nothing, - config = c, - repo = r, - gitconfig = gc, - localpath = Just dir, - readonly = False, - availability = LocallyAvailable, - remotetype = remote, - mkUnavailable = gen r u c $ - gc { remoteAnnexDirectory = Just "/dev/null" }, - getInfo = return [("directory", dir)] - } + Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyDummy + , retrieveKeyFile = retreiveKeyFileDummy + , retrieveKeyFileCheap = retrieveCheap dir chunkconfig + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy + , checkPresentCheap = True + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , repo = r + , gitconfig = gc + , localpath = Just dir + , readonly = False + , availability = LocallyAvailable + , remotetype = remote + , mkUnavailable = gen r u c $ + gc { remoteAnnexDirectory = Just "/dev/null" } + , getInfo = return [("directory", dir)] + , claimUrl = Nothing + , checkUrl = Nothing + } where dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -12,6 +12,7 @@ import Common.Annex import Types.Remote import Types.CleanupActions +import Types.UrlContents import qualified Git import Config import Remote.Helper.Special @@ -19,6 +20,7 @@ import Logs.Transfer import Logs.PreferredContent.Raw import Logs.RemoteState +import Logs.Web import Config.Cost import Annex.UUID import Creds @@ -46,30 +48,32 @@ (simplyPrepare $ retrieve external) (simplyPrepare $ remove external) (simplyPrepare $ checkKey external) - Remote { - uuid = u, - cost = cst, - name = Git.repoDescribe r, - storeKey = storeKeyDummy, - retrieveKeyFile = retreiveKeyFileDummy, - retrieveKeyFileCheap = \_ _ -> return False, - removeKey = removeKeyDummy, - checkPresent = checkPresentDummy, - checkPresentCheap = False, - whereisKey = Nothing, - remoteFsck = Nothing, - repairRepo = Nothing, - config = c, - localpath = Nothing, - repo = r, - gitconfig = gc, - readonly = False, - availability = avail, - remotetype = remote, - mkUnavailable = gen r u c $ + Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyDummy + , retrieveKeyFile = retreiveKeyFileDummy + , retrieveKeyFileCheap = \_ _ -> return False + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy + , checkPresentCheap = False + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , localpath = Nothing + , repo = r + , gitconfig = gc + , readonly = False + , availability = avail + , remotetype = remote + , mkUnavailable = gen r u c $ gc { remoteAnnexExternalType = Just "!dne!" } , getInfo = return [("externaltype", externaltype)] - } + , claimUrl = Just (claimurl external) + , checkUrl = Just (checkurl external) + } where externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc) @@ -215,6 +219,14 @@ state <- fromMaybe "" <$> getRemoteState (externalUUID external) key send $ VALUE state + handleRemoteRequest (SETURLPRESENT key url) = + setUrlPresent (externalUUID external) key url + handleRemoteRequest (SETURLMISSING key url) = + setUrlMissing (externalUUID external) key url + handleRemoteRequest (GETURLS key prefix) = do + mapM_ (send . VALUE . fst . getDownloader) + =<< getUrlsWithPrefix key prefix + send (VALUE "") -- end of list handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg handleRemoteRequest (VERSION _) = sendMessage lck external $ ERROR "too late to send VERSION" @@ -409,3 +421,27 @@ _ -> Nothing setRemoteAvailability r avail return avail + +claimurl :: External -> URLString -> Annex Bool +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 + _ -> Nothing + +checkurl :: External -> URLString -> Annex UrlContents +checkurl external url = + handleRequest external (CHECKURL url) Nothing $ \req -> case req of + CHECKURL_CONTENTS sz f -> Just $ return $ UrlContents sz + (if null f then Nothing else Just $ mkSafeFilePath f) + -- Treat a single item multi response specially to + -- simplify the external remote implementation. + CHECKURL_MULTI ((_, sz, f):[]) -> + Just $ return $ UrlContents sz $ Just $ mkSafeFilePath f + CHECKURL_MULTI l -> Just $ return $ UrlMulti $ map mkmulti l + CHECKURL_FAILURE errmsg -> Just $ error errmsg + UNSUPPORTED_REQUEST -> error "CHECKURL not implemented by external special remote" + _ -> Nothing + where + mkmulti (u, s, f) = (u, s, mkSafeFilePath f) diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs --- a/Remote/External/Types.hs +++ b/Remote/External/Types.hs @@ -39,6 +39,7 @@ import Config.Cost (Cost) import Types.Remote (RemoteConfig) import Types.Availability (Availability(..)) +import Utility.Url (URLString) import qualified Utility.SimpleProtocol as Proto import Control.Concurrent.STM @@ -90,6 +91,8 @@ | INITREMOTE | GETCOST | GETAVAILABILITY + | CLAIMURL URLString + | CHECKURL URLString | TRANSFER Direction Key FilePath | CHECKPRESENT Key | REMOVE Key @@ -106,6 +109,8 @@ formatMessage INITREMOTE = ["INITREMOTE"] formatMessage GETCOST = ["GETCOST"] formatMessage GETAVAILABILITY = ["GETAVAILABILITY"] + formatMessage (CLAIMURL url) = [ "CLAIMURL", Proto.serialize url ] + formatMessage (CHECKURL url) = [ "CHECKURL", Proto.serialize url ] formatMessage (TRANSFER direction key file) = [ "TRANSFER" , Proto.serialize direction @@ -130,6 +135,11 @@ | AVAILABILITY Availability | INITREMOTE_SUCCESS | INITREMOTE_FAILURE ErrorMsg + | CLAIMURL_SUCCESS + | CLAIMURL_FAILURE + | CHECKURL_CONTENTS Size FilePath + | CHECKURL_MULTI [(URLString, Size, FilePath)] + | CHECKURL_FAILURE ErrorMsg | UNSUPPORTED_REQUEST deriving (Show) @@ -147,6 +157,11 @@ parseCommand "AVAILABILITY" = Proto.parse1 AVAILABILITY parseCommand "INITREMOTE-SUCCESS" = Proto.parse0 INITREMOTE_SUCCESS parseCommand "INITREMOTE-FAILURE" = Proto.parse1 INITREMOTE_FAILURE + parseCommand "CLAIMURL-SUCCESS" = Proto.parse0 CLAIMURL_SUCCESS + parseCommand "CLAIMURL-FAILURE" = Proto.parse0 CLAIMURL_FAILURE + 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 @@ -165,6 +180,9 @@ | GETWANTED | SETSTATE Key String | GETSTATE Key + | SETURLPRESENT Key URLString + | SETURLMISSING Key URLString + | GETURLS Key String | DEBUG String deriving (Show) @@ -182,6 +200,9 @@ parseCommand "GETWANTED" = Proto.parse0 GETWANTED parseCommand "SETSTATE" = Proto.parse2 SETSTATE parseCommand "GETSTATE" = Proto.parse1 GETSTATE + parseCommand "SETURLPRESENT" = Proto.parse2 SETURLPRESENT + parseCommand "SETURLMISSING" = Proto.parse2 SETURLMISSING + parseCommand "GETURLS" = Proto.parse2 GETURLS parseCommand "DEBUG" = Proto.parse1 DEBUG parseCommand _ = Proto.parseFail @@ -212,6 +233,7 @@ type ErrorMsg = String type Setting = String type ProtocolVersion = Int +type Size = Maybe Integer supportedProtocolVersions :: [ProtocolVersion] supportedProtocolVersions = [1] @@ -240,6 +262,12 @@ serialize = show deserialize = readish +instance Proto.Serializable Size where + 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" serialize LocallyAvailable = "LOCAL" @@ -251,3 +279,12 @@ 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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -122,6 +122,8 @@ , remotetype = remote , mkUnavailable = return Nothing , getInfo = return $ gitRepoInfo r + , claimUrl = Nothing + , checkUrl = Nothing } return $ Just $ specialRemote' specialcfg c (simplyPrepare $ store this rsyncopts) diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -160,6 +160,8 @@ , remotetype = remote , mkUnavailable = unavailable r u c gc , getInfo = return $ gitRepoInfo r + , claimUrl = Nothing + , checkUrl = Nothing } unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -46,30 +46,32 @@ (simplyPrepare $ checkKey this) this where - this = Remote { - uuid = u, - cost = cst, - name = Git.repoDescribe r, - storeKey = storeKeyDummy, - retrieveKeyFile = retreiveKeyFileDummy, - retrieveKeyFileCheap = retrieveCheap this, - removeKey = removeKeyDummy, - checkPresent = checkPresentDummy, - checkPresentCheap = False, - whereisKey = Nothing, - remoteFsck = Nothing, - repairRepo = Nothing, - config = c, - repo = r, - gitconfig = gc, - localpath = Nothing, - readonly = False, - availability = GloballyAvailable, - remotetype = remote, - mkUnavailable = return Nothing, - getInfo = includeCredsInfo c (AWS.creds u) $ + this = Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyDummy + , retrieveKeyFile = retreiveKeyFileDummy + , retrieveKeyFileCheap = retrieveCheap this + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy + , checkPresentCheap = False + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , repo = r + , gitconfig = gc + , localpath = Nothing + , readonly = False + , availability = GloballyAvailable + , remotetype = remote + , mkUnavailable = return Nothing + , getInfo = includeCredsInfo c (AWS.creds u) $ [ ("glacier vault", getVault c) ] - } + , claimUrl = Nothing + , checkUrl = Nothing + } specialcfg = (specialRemoteCfg c) -- Disabled until jobList gets support for chunks. { chunkConfig = NoChunks diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs --- a/Remote/Helper/AWS.hs +++ b/Remote/Helper/AWS.hs @@ -5,21 +5,19 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings, TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Remote.Helper.AWS where import Common.Annex import Creds -import qualified Aws -import qualified Aws.S3 as S3 import qualified Data.Map as M import qualified Data.ByteString as B import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text (Text) -import Data.IORef creds :: UUID -> CredPairStorage creds u = CredPairStorage @@ -28,13 +26,6 @@ , credPairRemoteKey = Just "s3creds" } -genCredentials :: CredPair -> IO Aws.Credentials -genCredentials (keyid, secret) = Aws.Credentials - <$> pure (encodeUtf8 (T.pack keyid)) - <*> pure (encodeUtf8 (T.pack secret)) - <*> newIORef [] - <*> pure Nothing - data Service = S3 | Glacier deriving (Eq) @@ -82,7 +73,3 @@ s3DefaultHost :: String s3DefaultHost = "s3.amazonaws.com" - -mkLocationConstraint :: Region -> S3.LocationConstraint -mkLocationConstraint "US" = S3.locationUsClassic -mkLocationConstraint r = r diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -39,30 +39,32 @@ (simplyPrepare $ retrieve hooktype) (simplyPrepare $ remove hooktype) (simplyPrepare $ checkKey r hooktype) - Remote { - uuid = u, - cost = cst, - name = Git.repoDescribe r, - storeKey = storeKeyDummy, - retrieveKeyFile = retreiveKeyFileDummy, - retrieveKeyFileCheap = retrieveCheap hooktype, - removeKey = removeKeyDummy, - checkPresent = checkPresentDummy, - checkPresentCheap = False, - whereisKey = Nothing, - remoteFsck = Nothing, - repairRepo = Nothing, - config = c, - localpath = Nothing, - repo = r, - gitconfig = gc, - readonly = False, - availability = GloballyAvailable, - remotetype = remote, - mkUnavailable = gen r u c $ - gc { remoteAnnexHookType = Just "!dne!" }, - getInfo = return [("hooktype", hooktype)] - } + Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyDummy + , retrieveKeyFile = retreiveKeyFileDummy + , retrieveKeyFileCheap = retrieveCheap hooktype + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy + , checkPresentCheap = False + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , localpath = Nothing + , repo = r + , gitconfig = gc + , readonly = False + , availability = GloballyAvailable + , remotetype = remote + , mkUnavailable = gen r u c $ + gc { remoteAnnexHookType = Just "!dne!" } + , getInfo = return [("hooktype", hooktype)] + , claimUrl = Nothing + , checkUrl = Nothing + } where hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -30,6 +30,7 @@ import qualified Remote.Directory import qualified Remote.Rsync import qualified Remote.Web +import qualified Remote.BitTorrent #ifdef WITH_WEBDAV import qualified Remote.WebDAV #endif @@ -52,6 +53,7 @@ , Remote.Directory.remote , Remote.Rsync.remote , Remote.Web.remote + , Remote.BitTorrent.remote #ifdef WITH_WEBDAV , Remote.WebDAV.remote #endif diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -84,6 +84,8 @@ , remotetype = remote , mkUnavailable = return Nothing , getInfo = return [("url", url)] + , claimUrl = Nothing + , checkUrl = Nothing } where specialcfg = (specialRemoteCfg c) diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Remote.S3 (remote, iaHost, configIA, iaItemUrl) where @@ -26,6 +27,7 @@ import Control.Monad.Trans.Resource import Control.Monad.Catch import Data.Conduit +import Data.IORef import Common.Annex import Types.Remote @@ -65,35 +67,37 @@ (prepareS3 this info $ checkKey this) this where - this = Remote { - uuid = u, - cost = cst, - name = Git.repoDescribe r, - storeKey = storeKeyDummy, - retrieveKeyFile = retreiveKeyFileDummy, - retrieveKeyFileCheap = retrieveCheap, - removeKey = removeKeyDummy, - checkPresent = checkPresentDummy, - checkPresentCheap = False, - whereisKey = Nothing, - remoteFsck = Nothing, - repairRepo = Nothing, - config = c, - repo = r, - gitconfig = gc, - localpath = Nothing, - readonly = False, - availability = GloballyAvailable, - remotetype = remote, - mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc, - getInfo = includeCredsInfo c (AWS.creds u) $ catMaybes + this = Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyDummy + , retrieveKeyFile = retreiveKeyFileDummy + , retrieveKeyFileCheap = retrieveCheap + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy + , checkPresentCheap = False + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , repo = r + , gitconfig = gc + , localpath = Nothing + , readonly = False + , availability = GloballyAvailable + , remotetype = remote + , mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc + , getInfo = includeCredsInfo c (AWS.creds u) $ catMaybes [ Just ("bucket", fromMaybe "unknown" (getBucketName c)) , if configIA c then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucketName c) else Nothing , Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c)) ] - } + , claimUrl = Nothing + , checkUrl = Nothing + } s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) s3Setup mu mcreds c = do @@ -162,7 +166,7 @@ _ -> singlepartupload k f p -- Store public URL to item in Internet Archive. when (isIA (hinfo h) && not (isChunkKey k)) $ - setUrlPresent k (iaKeyUrl r k) + setUrlPresent webUUID k (iaKeyUrl r k) return True where singlepartupload k f p = do @@ -306,7 +310,7 @@ showAction $ "creating bucket in " ++ datacenter void $ sendS3Handle h $ S3.PutBucket (bucket $ hinfo h) Nothing $ - AWS.mkLocationConstraint $ + mkLocationConstraint $ T.pack datacenter writeUUIDFile c u h @@ -389,7 +393,7 @@ withS3Handle :: RemoteConfig -> UUID -> S3Info -> (S3Handle -> Annex a) -> Annex a withS3Handle c u info a = do creds <- getRemoteCredPairFor "S3" c (AWS.creds u) - awscreds <- liftIO $ AWS.genCredentials $ fromMaybe nocreds creds + awscreds <- liftIO $ genCredentials $ fromMaybe nocreds creds let awscfg = AWS.Configuration AWS.Timestamp awscreds (AWS.defaultLog AWS.Error) bracketIO (newManager httpcfg) closeManager $ \mgr -> a $ S3Handle mgr awscfg s3cfg info @@ -503,3 +507,14 @@ iaKeyUrl r k = "http://archive.org/download/" ++ b ++ "/" ++ getBucketObject (config r) k where b = fromMaybe "" $ getBucketName $ config r + +genCredentials :: CredPair -> IO AWS.Credentials +genCredentials (keyid, secret) = AWS.Credentials + <$> pure (T.encodeUtf8 (T.pack keyid)) + <*> pure (T.encodeUtf8 (T.pack secret)) + <*> newIORef [] + <*> pure Nothing + +mkLocationConstraint :: AWS.Region -> S3.LocationConstraint +mkLocationConstraint "US" = S3.locationUsClassic +mkLocationConstraint r = r diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -64,29 +64,31 @@ hdl <- liftIO $ TahoeHandle <$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc) <*> newEmptyTMVarIO - return $ Just $ Remote { - uuid = u, - cost = cst, - name = Git.repoDescribe r, - storeKey = store u hdl, - retrieveKeyFile = retrieve u hdl, - retrieveKeyFileCheap = \_ _ -> return False, - removeKey = remove, - checkPresent = checkKey u hdl, - checkPresentCheap = False, - whereisKey = Nothing, - remoteFsck = Nothing, - repairRepo = Nothing, - config = c, - repo = r, - gitconfig = gc, - localpath = Nothing, - readonly = False, - availability = GloballyAvailable, - remotetype = remote, - mkUnavailable = return Nothing, - getInfo = return [] - } + return $ Just $ Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = store u hdl + , retrieveKeyFile = retrieve u hdl + , retrieveKeyFileCheap = \_ _ -> return False + , removeKey = remove + , checkPresent = checkKey u hdl + , checkPresentCheap = False + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , repo = r + , gitconfig = gc + , localpath = Nothing + , readonly = False + , availability = GloballyAvailable + , remotetype = remote + , mkUnavailable = return Nothing + , getInfo = return [] + , claimUrl = Nothing + , checkUrl = Nothing + } tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) tahoeSetup mu _ c = do diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -1,4 +1,4 @@ -{- Web remotes. +{- Web remote. - - Copyright 2011 Joey Hess - @@ -16,6 +16,7 @@ import Annex.Content import Config.Cost import Logs.Web +import Annex.UUID import Types.Key import Utility.Metered import qualified Annex.Url as Url @@ -42,32 +43,34 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r _ c gc = - return $ Just Remote { - uuid = webUUID, - cost = expensiveRemoteCost, - name = Git.repoDescribe r, - storeKey = uploadKey, - retrieveKeyFile = downloadKey, - retrieveKeyFileCheap = downloadKeyCheap, - removeKey = dropKey, - checkPresent = checkKey, - checkPresentCheap = False, - whereisKey = Just getUrls, - remoteFsck = Nothing, - repairRepo = Nothing, - config = c, - gitconfig = gc, - localpath = Nothing, - repo = r, - readonly = True, - availability = GloballyAvailable, - remotetype = remote, - mkUnavailable = return Nothing, - getInfo = return [] - } + return $ Just Remote + { uuid = webUUID + , cost = expensiveRemoteCost + , name = Git.repoDescribe r + , storeKey = uploadKey + , retrieveKeyFile = downloadKey + , retrieveKeyFileCheap = downloadKeyCheap + , removeKey = dropKey + , checkPresent = checkKey + , checkPresentCheap = False + , whereisKey = Just getWebUrls + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , gitconfig = gc + , localpath = Nothing + , repo = r + , readonly = True + , availability = GloballyAvailable + , remotetype = remote + , mkUnavailable = return Nothing + , getInfo = return [] + , claimUrl = Nothing -- implicitly claims all urls + , checkUrl = Nothing + } downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool -downloadKey key _file dest _p = get =<< getUrls key +downloadKey key _file dest _p = get =<< getWebUrls key where get [] = do warning "no known url" @@ -85,7 +88,7 @@ warning "quvi support needed for this url" return False #endif - DefaultDownloader -> downloadUrl [u'] dest + _ -> downloadUrl [u'] dest downloadKeyCheap :: Key -> FilePath -> Annex Bool downloadKeyCheap _ _ = return False @@ -97,12 +100,12 @@ dropKey :: Key -> Annex Bool dropKey k = do - mapM_ (setUrlMissing k) =<< getUrls k + mapM_ (setUrlMissing webUUID k) =<< getWebUrls k return True checkKey :: Key -> Annex Bool checkKey key = do - us <- getUrls key + us <- getWebUrls key if null us then return False else either error return =<< checkKey' key us @@ -117,7 +120,7 @@ #else return $ Left "quvi support needed for this url" #endif - DefaultDownloader -> do + _ -> do Url.withUrlOptions $ catchMsgIO . Url.checkBoth u' (keySize key) where @@ -127,3 +130,9 @@ case r of Right _ -> return r Left _ -> firsthit rest r a + +getWebUrls :: Key -> Annex [URLString] +getWebUrls key = filter supported <$> getUrls key + where + supported u = snd (getDownloader u) + `elem` [WebDownloader, QuviDownloader] diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -51,30 +51,32 @@ (prepareDAV this $ checkKey this chunkconfig) this where - this = Remote { - uuid = u, - cost = cst, - name = Git.repoDescribe r, - storeKey = storeKeyDummy, - retrieveKeyFile = retreiveKeyFileDummy, - retrieveKeyFileCheap = retrieveCheap, - removeKey = removeKeyDummy, - checkPresent = checkPresentDummy, - checkPresentCheap = False, - whereisKey = Nothing, - remoteFsck = Nothing, - repairRepo = Nothing, - config = c, - repo = r, - gitconfig = gc, - localpath = Nothing, - readonly = False, - availability = GloballyAvailable, - remotetype = remote, - mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc, - getInfo = includeCredsInfo c (davCreds u) $ + this = Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyDummy + , retrieveKeyFile = retreiveKeyFileDummy + , retrieveKeyFileCheap = retrieveCheap + , removeKey = removeKeyDummy + , checkPresent = checkPresentDummy + , checkPresentCheap = False + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , repo = r + , gitconfig = gc + , localpath = Nothing + , readonly = False + , availability = GloballyAvailable + , remotetype = remote + , mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc + , getInfo = includeCredsInfo c (davCreds u) $ [("url", fromMaybe "unknown" (M.lookup "url" c))] - } + , claimUrl = Nothing + , checkUrl = Nothing + } chunkconfig = getChunkConfig c webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) diff --git a/Types/CleanupActions.hs b/Types/CleanupActions.hs --- a/Types/CleanupActions.hs +++ b/Types/CleanupActions.hs @@ -9,9 +9,12 @@ import Types.UUID +import Utility.Url + data CleanupAction = RemoteCleanup UUID | StopHook UUID | FsckCleanup | SshCachingCleanup + | TorrentCleanup URLString deriving (Eq, Ord) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -42,6 +42,7 @@ , annexDebug :: Bool , annexWebOptions :: [String] , annexQuviOptions :: [String] + , annexAriaTorrentOptions :: [String] , annexWebDownloadCommand :: Maybe String , annexCrippledFileSystem :: Bool , annexLargeFiles :: Maybe String @@ -77,6 +78,7 @@ , annexDebug = getbool (annex "debug") False , annexWebOptions = getwords (annex "web-options") , annexQuviOptions = getwords (annex "quvi-options") + , annexAriaTorrentOptions = getwords (annex "aria-torrent-options") , annexWebDownloadCommand = getmaybe (annex "web-download-command") , annexCrippledFileSystem = getbool (annex "crippledfilesystem") False , annexLargeFiles = getmaybe (annex "largefiles") diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -25,10 +25,12 @@ import Types.GitConfig import Types.Availability import Types.Creds +import Types.UrlContents import Config.Cost import Utility.Metered import Git.Types import Utility.SafeCommand +import Utility.Url type RemoteConfigKey = String type RemoteConfig = M.Map RemoteConfigKey String @@ -100,7 +102,13 @@ -- available for use. All its actions should fail. mkUnavailable :: a (Maybe (RemoteA a)), -- Information about the remote, for git annex info to display. - getInfo :: a [(String, String)] + getInfo :: a [(String, String)], + -- Some remotes can download from an url (or uri). + claimUrl :: Maybe (URLString -> a Bool), + -- Checks that the url is accessible, and gets information about + -- its contents, without downloading the full content. + -- Throws an exception if the url is inaccessible. + checkUrl :: Maybe (URLString -> a UrlContents) } instance Show (RemoteA a) where diff --git a/Types/UrlContents.hs b/Types/UrlContents.hs new file mode 100644 --- /dev/null +++ b/Types/UrlContents.hs @@ -0,0 +1,47 @@ +{- git-annex URL contents + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Types.UrlContents ( + UrlContents(..), + SafeFilePath, + mkSafeFilePath, + fromSafeFilePath +) where + +import Utility.Url +import Utility.Path + +import System.FilePath + +data UrlContents + -- An URL contains a file, whose size may be known. + -- There might be a nicer filename to use. + = UrlContents (Maybe Integer) (Maybe SafeFilePath) + -- Sometimes an URL points to multiple files, each accessible + -- by their own URL. + | UrlMulti [(URLString, Maybe Integer, SafeFilePath)] + +-- This is a FilePath, from an untrusted source, +-- sanitized so it doesn't contain any directory traversal tricks +-- and is always relative. It can still contain subdirectories. +-- Any unusual characters are also filtered out. +newtype SafeFilePath = SafeFilePath FilePath + deriving (Show) + +mkSafeFilePath :: FilePath -> SafeFilePath +mkSafeFilePath p = SafeFilePath $ if null p' then "file" else p' + where + p' = joinPath $ filter safe $ map sanitizeFilePath $ splitDirectories p + safe s + | isDrive s = False + | s == ".." = False + | s == ".git" = False + | null s = False + | otherwise = True + +fromSafeFilePath :: SafeFilePath -> FilePath +fromSafeFilePath (SafeFilePath p) = p diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs new file mode 100644 --- /dev/null +++ b/Utility/DottedVersion.hs @@ -0,0 +1,36 @@ +{- dotted versions, such as 1.0.1 + - + - Copyright 2011-2014 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.DottedVersion where + +import Common + +data DottedVersion = DottedVersion String Integer + deriving (Eq) + +instance Ord DottedVersion where + compare (DottedVersion _ x) (DottedVersion _ y) = compare x y + +instance Show DottedVersion where + show (DottedVersion s _) = s + +{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to + - a somewhat arbitrary integer representation. -} +normalize :: String -> DottedVersion +normalize v = DottedVersion v $ + sum $ mult 1 $ reverse $ extend precision $ take precision $ + map readi $ split "." v + where + extend n l = l ++ replicate (n - length l) 0 + mult _ [] = [] + mult n (x:xs) = (n*x) : mult (n*10^width) xs + readi :: String -> Integer + readi s = case reads s of + ((x,_):_) -> x + _ -> 0 + precision = 10 -- number of segments of the version to compare + width = length "yyyymmddhhmmss" -- maximum width of a segment diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -143,3 +143,36 @@ where k = 1024 chunkOverhead = 2 * sizeOf (undefined :: Int) -- GHC specific + +{- Parses the String looking for a command's progress output, and returns + - Maybe the number of bytes rsynced so far, and any any remainder of the + - string that could be an incomplete progress output. That remainder + - should be prepended to future output, and fed back in. This interface + - allows the command's output to be read in any desired size chunk, or + - even one character at a time. + -} +type ProgressParser = String -> (Maybe BytesProcessed, String) + +{- Runs a command and runs a ProgressParser on its output, in order + - to update the meter. The command's output is also sent to stdout. -} +commandMeter :: ProgressParser -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool +commandMeter progressparser meterupdate cmd params = liftIO $ catchBoolIO $ + withHandle StdoutHandle createProcessSuccess p $ + feedprogress zeroBytesProcessed [] + where + p = proc cmd (toCommand params) + + feedprogress prev buf h = do + s <- hGetSomeString h 80 + if null s + then return True + else do + putStr s + hFlush stdout + let (mbytes, buf') = progressparser (buf++s) + case mbytes of + Nothing -> feedprogress prev buf' h + (Just bytes) -> do + when (bytes /= prev) $ + meterupdate bytes + feedprogress bytes buf' h diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -267,7 +267,8 @@ - sane FilePath. - - All spaces and punctuation and other wacky stuff are replaced - - with '_', except for '.' "../" will thus turn into ".._", which is safe. + - with '_', except for '.' + - "../" will thus turn into ".._", which is safe. -} sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -60,31 +60,6 @@ fixup (File f) = File (toCygPath f) fixup p = p -{- Runs rsync, but intercepts its progress output and updates a meter. - - The progress output is also output to stdout. - - - - The params must enable rsync's --progress mode for this to work. - -} -rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool -rsyncProgress meterupdate params = catchBoolIO $ - withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) - where - p = proc "rsync" (toCommand $ rsyncParamsFixup params) - feedprogress prev buf h = do - s <- hGetSomeString h 80 - if null s - then return True - else do - putStr s - hFlush stdout - let (mbytes, buf') = parseRsyncProgress (buf++s) - case mbytes of - Nothing -> feedprogress prev buf' h - (Just bytes) -> do - when (bytes /= prev) $ - meterupdate $ toBytesProcessed bytes - feedprogress bytes buf' h - {- Checks if an rsync url involves the remote shell (ssh or rsh). - Use of such urls with rsync requires additional shell - escaping. -} @@ -106,14 +81,15 @@ | rsyncUrlIsShell s = False | otherwise = ':' `notElem` s -{- Parses the String looking for rsync progress output, and returns - - Maybe the number of bytes rsynced so far, and any any remainder of the - - string that could be an incomplete progress output. That remainder - - should be prepended to future output, and fed back in. This interface - - allows the output to be read in any desired size chunk, or even one - - character at a time. +{- Runs rsync, but intercepts its progress output and updates a meter. + - The progress output is also output to stdout. - - - Strategy: Look for chunks prefixed with \r (rsync writes a \r before + - The params must enable rsync's --progress mode for this to work. + -} +rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool +rsyncProgress meterupdate = commandMeter parseRsyncProgress meterupdate "rsync" + +{- Strategy: Look for chunks prefixed with \r (rsync writes a \r before - the first progress output, and each thereafter). The first number - after the \r is the number of bytes processed. After the number, - there must appear some whitespace, or we didn't get the whole number, @@ -122,20 +98,23 @@ - In some locales, the number will have one or more commas in the middle - of it. -} -parseRsyncProgress :: String -> (Maybe Integer, String) +parseRsyncProgress :: ProgressParser parseRsyncProgress = go [] . reverse . progresschunks where go remainder [] = (Nothing, remainder) go remainder (x:xs) = case parsebytes (findbytesstart x) of Nothing -> go (delim:x++remainder) xs - Just b -> (Just b, remainder) + Just b -> (Just (toBytesProcessed b), remainder) delim = '\r' + {- Find chunks that each start with delim. - The first chunk doesn't start with it - (it's empty when delim is at the start of the string). -} progresschunks = drop 1 . split [delim] findbytesstart s = dropWhile isSpace s + + parsebytes :: String -> Maybe Integer parsebytes s = case break isSpace s of ([], _) -> Nothing (_, []) -> Nothing diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -191,9 +191,18 @@ wget = go "wget" $ headerparams ++ quietopt "-q" ++ wgetparams {- Regular wget needs --clobber to continue downloading an existing - file. On Android, busybox wget is used, which does not - - support, or need that option. -} + - support, or need that option. + - + - When the wget version is new enough, pass options for + - a less cluttered download display. + -} #ifndef __ANDROID__ - wgetparams = [Params "--clobber -c -O"] + wgetparams = catMaybes + [ if Build.SysConfig.wgetquietprogress + then Just $ Params "-q --show-progress" + else Nothing + , Just $ Params "--clobber -c -O" + ] #else wgetparams = [Params "-c -O"] #endif diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,26 @@ +git-annex (5.20141219) unstable; urgency=medium + + * Webapp: When adding a new box.com remote, use the new style chunking. + Thanks, Jon Ander Peñalba. + * External special remote protocol now includes commands for setting + and getting the urls associated with a key. + * Urls can now be claimed by remotes. This will allow creating, + for example, a external special remote that handles magnet: and + *.torrent urls. + * Use wget -q --show-progress for less verbose wget output, + when built with wget 1.16. + * Added bittorrent special remote. + * addurl behavior change: When downloading an url ending in .torrent, + it will download files from bittorrent, instead of the old behavior + of adding the torrent file to the repository. + * Added Recommends on aria2. + * When possible, build with the haskell torrent library for parsing + torrent files. As a fallback, can instead use btshowmetainfo from + bittornado | bittorrent. + * Fix build with -f-S3. + + -- Joey Hess Fri, 19 Dec 2014 16:53:26 -0400 + git-annex (5.20141203) unstable; urgency=medium * proxy: New command for direct mode repositories, allows bypassing diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -99,6 +99,8 @@ quvi, git-remote-gcrypt (>= 0.20130908-6), nocache, + aria2, + bittornado | bittorrent, Suggests: graphviz, bup, diff --git a/doc/bugs/Attempting_to_repair_repository_almost_every_day.mdwn b/doc/bugs/Attempting_to_repair_repository_almost_every_day.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Attempting_to_repair_repository_almost_every_day.mdwn @@ -0,0 +1,5 @@ +I'm using the webapp on my two main computers with up-to-date Debian (one has testing and the other one sid) and I have consistency checks scheduled every day. + +The problem is that almost every time the check runs I'm getting the "Attempting to repair" message and git-annex starts using 100% CPU for quite a while, but after it it seams to have done no change to the git tree or the files. + +The two computers are never on at the same time, but they are constantly syncing files (through box.com), I don't now if downloading files while the check is in progress might have something to do. diff --git a/doc/bugs/Build_error_when_S3_is_disabled.mdwn b/doc/bugs/Build_error_when_S3_is_disabled.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Build_error_when_S3_is_disabled.mdwn @@ -0,0 +1,39 @@ +With release 5.20141203, I'm getting the following build error. + + Remote/Helper/AWS.hs:15:18: + Could not find module ‘Aws’ + Use -v to see a list of the files searched for. + + Remote/Helper/AWS.hs:16:18: + Could not find module ‘Aws.S3’ + Use -v to see a list of the files searched for. + +I'm installing dependencies with cabal but have disabled S3 support +('-f-S3'). This setup has worked for previous releases (I'm on a machine running Arch Linux). + + _features=(-f-Android + -f-Assistant + -fDbus + -fDNS + -fInotify + -fPairing + -fProduction + -f-S3 + -fTestSuite + -fTDFA + -f-Webapp + -f-WebDAV + -fXMPP + -fFeed + -fQuvi + -fCryptoHash) + + cabal update + cabal install c2hs + + cabal install --user --force-reinstalls --only-dependencies "${_features[@]}" + cabal configure "${_features[@]}" + + make + +> [[fixed|done]] --[[Joey]] diff --git a/doc/bugs/Cannot_set_direct_mode_with_non_default_worktree.mdwn b/doc/bugs/Cannot_set_direct_mode_with_non_default_worktree.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Cannot_set_direct_mode_with_non_default_worktree.mdwn @@ -0,0 +1,45 @@ +### Please describe the problem. +I am trying to switch to direct mode with the git work tree in a different directory than default much like described in http://git-annex.branchable.com/forum/Detached_git_work_tree__63__/ + + +### What steps will reproduce the problem? +- Create a new git repo with the GIT_WORK_TREE and GIT_DIR set. +- git annex init test +- git annex direct + + +### What version of git-annex are you using? On what operating system? +5.20141125 package in Debian unstable + + +### Please provide any additional information below. + +[[!format sh """ ++dbn@loaner:~/annex $ mkdir -p test/worktree ++dbn@loaner:~/annex $ cd test/ ++dbn@loaner:~/annex/test $ git init +Initialized empty Git repository in /home/dbn/annex/test/.git/ ++dbn@loaner:~/annex/test $ git annex init test +init test ok +(Recording state in git...) ++dbn@loaner:~/annex/test $ git annex direct --debug +commit +[2014-12-08 03:05:45 PST] call: git ["--git-dir=/home/dbn/annex/test/.git","--work-tree=/home/dbn/annex/test/worktree","commit","-a","-m","commit before switching to direct mode"] +On branch master + +Initial commit + +nothing to commit +ok +[2014-12-08 03:05:45 PST] read: git ["--git-dir=/home/dbn/annex/test/.git","--work-tree=/home/dbn/annex/test/worktree","ls-files","--cached","-z","--","/home/dbn/annex/test/worktree"] +direct [2014-12-08 03:05:45 PST] read: git ["--git-dir=/home/dbn/annex/test/.git","--work-tree=/home/dbn/annex/test/worktree","symbolic-ref","HEAD"] +[2014-12-08 03:05:45 PST] read: git ["--git-dir=/home/dbn/annex/test/.git","--work-tree=/home/dbn/annex/test/worktree","show-ref","--hash","refs/heads/master"] +[2014-12-08 03:05:45 PST] call: git ["--git-dir=/home/dbn/annex/test/.git","--work-tree=/home/dbn/annex/test/worktree","checkout","-q","-B","annex/direct/master"] +[2014-12-08 03:05:45 PST] call: git ["--git-dir=/home/dbn/annex/test/.git","--work-tree=/home/dbn/annex/test/worktree","config","core.bare","true"] +[2014-12-08 03:05:45 PST] read: git ["config","--null","--list"] +fatal: core.bare and core.worktree do not make sense + +git-annex: user error (git ["config","--null","--list"] exited 128) +failed +git-annex: direct: 1 failed +"""]] diff --git a/doc/bugs/Direct_mode_sync_fails_to_transfer_a_10GB_file.mdwn b/doc/bugs/Direct_mode_sync_fails_to_transfer_a_10GB_file.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/Direct_mode_sync_fails_to_transfer_a_10GB_file.mdwn @@ -0,0 +1,58 @@ +### Please describe the problem. + +On Windows, a 10GB file of mine is successfully indexed (``git annex add``'ed), but ``git annex sync --content`` always fails with rsync, saying "recvkey: received key with wrong size". This is the largest file I've tested so far, and the only one that's failed. + +### What steps will reproduce the problem? + +1. Copy a 10GB file to a working copy (mine is ''PNG_Sequence.rar'', 10 361 629 980 bytes). +2. Run ``git annex add`` +3. Run ``git annex sync --content`` + +### What version of git-annex are you using? On what operating system? + +Windows 7 x64 with: + + git-annex version: 5.20141128-g70f997e + build flags: Assistant Webapp Webapp-secure Pairing Testsuite S3 WebDAV DNS Feed + s Quvi TDFA CryptoHash + key/value backends: SHA256E SHA1E SHA512E SHA224E SHA384E SKEIN256E SKEIN512E SH + A256 SHA1 SHA512 SHA224 SHA384 SKEIN256 SKEIN512 WORM URL + remote types: git gcrypt S3 bup directory rsync web webdav tahoe glacier ddar ho + ok external + +### Please provide any additional information below. + +[[!format sh """ +# If you can, paste a complete transcript of the problem occurring here. +# If the problem is with the git-annex assistant, paste in .git/annex/daemon.log + +commit (Recording state in git...) +ok +pull origin +ok +copy Art/PlanetPioneers/PNG_Sequence.rar copy Art/PlanetPioneers/PNG_Sequence.ra +r (checking origin...) (to origin...) + recvkey: received key with wrong size; discarding + +sent 39 bytes received 12 bytes 102.00 bytes/sec +rsync error: syntax or usage error (code 1) at /home/lapo/package/rsync-3.0.9-1/ +src/rsync-3.0.9/main.c(1052) [sender=3.0.9]total size is 10361629980 speedup is + 203169215.29 + rsync failed -- run git annex again to resume file transfer +failed +pull origin +ok +push origin +Counting objects: 24, done. +Delta compression using up to 8 threads. +Compressing objects: 100% (11/11), done. +Writing objects: 100% (13/13), 1.06 KiB | 0 bytes/s, done. +Total 13 (delta 7), reused 0 (delta 0) +To ssh://gitannex@serv-gitannex:/home/gitannex/git-annex-test.git + f8f70de..41bec92 git-annex -> synced/git-annex + 090ca15..e9e842b annex/direct/master -> synced/master +ok +git-annex: sync: 1 failed + +# End of transcript or log. +"""]] diff --git a/doc/bugs/S3_memory_leaks/comment_7_1ac572b79caa23e3f791e4f8461fcddd._comment b/doc/bugs/S3_memory_leaks/comment_7_1ac572b79caa23e3f791e4f8461fcddd._comment new file mode 100644 --- /dev/null +++ b/doc/bugs/S3_memory_leaks/comment_7_1ac572b79caa23e3f791e4f8461fcddd._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawmUJBh1lYmvfCCiGr3yrdx-QhuLCSRnU5c" + nickname="Justin" + subject="comment 7" + date="2014-12-06T18:15:50Z" + content=""" +The new version works really great for me. I've been copying to S3 over the past few days with no issues on my raspberry pi. + +Thanks a ton for getting this out. +"""]] diff --git a/doc/bugs/S3_upload_not_using_multipart.mdwn b/doc/bugs/S3_upload_not_using_multipart.mdwn --- a/doc/bugs/S3_upload_not_using_multipart.mdwn +++ b/doc/bugs/S3_upload_not_using_multipart.mdwn @@ -57,6 +57,6 @@ > enough version of the aws library. You need to configure the remote to > use an appropriate value for multipart, eg: > -> git annex enableremote cloud multipart=1GiB +> git annex enableremote cloud partsize=1GiB > > --[[Joey]] diff --git a/doc/bugs/ssh-options_seems_to_be_ignored.mdwn b/doc/bugs/ssh-options_seems_to_be_ignored.mdwn new file mode 100644 --- /dev/null +++ b/doc/bugs/ssh-options_seems_to_be_ignored.mdwn @@ -0,0 +1,45 @@ +### Please describe the problem. +The docs say I can set ssh options via `annex.ssh-options` or `remote.NAME.annex-ssh-options`. I tried, and the setting appears to be completely ignored. + +Apologies in advance if I've made a stupid typo. + +### What steps will reproduce the problem? + +I tried all of these: + + git config --local --replace-all annex.ssh-options "-i ~/.ssh/id_git_rsa" + git config --local --replace-all remote.Watt.annex-ssh-options "-i ~/.ssh/id_git_rsa" + +`git config -l | grep Watt` confirms it took: + + remote.Watt.url=ssh://watt.home/home/anthony/Music/ + remote.Watt.fetch=+refs/heads/*:refs/remotes/Watt/* + remote.Watt.annex-uuid=e74b57e5-e78c-4f3d-bde6-4803a0c33837 + remote.Watt.annex-ssh-options=-i ~/.ssh/id_git_rsa + +Then I ran `git annex sync Watt`, and was prompted for a password: + + anthony@Forest:~/Music$ git annex sync Watt + commit ok + pull Watt + Password: + +Running `ps ww $(pidof ssh)` shows that the `-i` option is missing: + + PID TTY STAT TIME COMMAND + 22188 pts/4 S+ 0:00 ssh -S .git/annex/ssh/watt.home -o ControlMaster=auto -o ControlPersist=yes watt.home git-upload-pack '/home/anthony/Music/' + + +### What version of git-annex are you using? On what operating system? + +Debian testing 5.20141125 + +### Please provide any additional information below. + +[[!format sh """ +# If you can, paste a complete transcript of the problem occurring here. +# If the problem is with the git-annex assistant, paste in .git/annex/daemon.log + + +# End of transcript or log. +"""]] diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn --- a/doc/design/external_special_remote_protocol.mdwn +++ b/doc/design/external_special_remote_protocol.mdwn @@ -91,14 +91,14 @@ The following requests *must* all be supported by the special remote. * `INITREMOTE` - Request that the remote initialize itself. This is where any one-time + Requests the remote to initialize itself. This is where any one-time setup tasks can be done, for example creating an Amazon S3 bucket. Note: This may be run repeatedly over time, as a remote is initialized in different repositories, or as the configuration of a remote is changed. (Both `git annex initremote` and `git-annex enableremote` run this.) So any one-time setup tasks should be done idempotently. * `PREPARE` - Tells the special remote it's time to prepare itself to be used. + Tells the remote that it's time to prepare itself to be used. Only INITREMOTE can come before this. * `TRANSFER STORE|RETRIEVE Key File` Requests the transfer of a key. For STORE, the File is the file to upload; @@ -110,21 +110,29 @@ Multiple transfers might be requested by git-annex, but it's fine for the program to serialize them and only do one at a time. * `CHECKPRESENT Key` - Requests the remote check if a key is present in it. + Requests the remote to check if a key is present in it. * `REMOVE Key` - Requests the remote remove a key's contents. + Requests the remote to remove a key's contents. The following requests can optionally be supported. If not handled, replying with `UNSUPPORTED-REQUEST` is acceptable. * `GETCOST` - Requests the remote return a use cost. Higher costs are more expensive. + Requests the remote to return a use cost. Higher costs are more expensive. (See Config/Cost.hs for some standard costs.) * `GETAVAILABILITY` - Requests the remote send back an `AVAILABILITY` reply. + Requests the remote to send back an `AVAILABILITY` reply. If the remote replies with `UNSUPPORTED-REQUEST`, its availability - is asssumed to be global. So, only remotes that are only reachable + is assumed to be global. So, only remotes that are only reachable locally need to worry about implementing this. +* `CLAIMURL Url` + Asks the remote if it wishes to claim responsibility for downloading + an url. If so, the remote should send back an `CLAIMURL-SUCCESS` reply. + If not, it can send `CLAIMURL-FAILURE`. +* `CHECKURL Url` + Asks the remote to check if the url's content can currently be downloaded + (without downloading it). The remote replies with one of `CHECKURL-FAILURE`, + `CHECKURL-CONTENTS`, or `CHECKURL-MULTI`. More optional requests may be added, without changing the protocol version, so if an unknown request is seen, reply with `UNSUPPORTED-REQUEST`. @@ -167,6 +175,24 @@ Indicates the INITREMOTE succeeded and the remote is ready to use. * `INITREMOTE-FAILURE ErrorMsg` Indicates that INITREMOTE failed. +* `CLAIMURL-SUCCESS` + Indicates that the CLAIMURL url will be handled by this remote. +* `CLAIMURL-FAILURE` + Indicates that the CLAIMURL url wil not be handled by this remote. +* `CHECKURL-CONTENTS Size|UNKNOWN Filename` + Indicates that the requested url has been verified to exist. + The Size is the size in bytes, or use "UNKNOWN" if the size could not be + determined. + The Filename can be empty (in which case a default is used), + or can specify a filename that is suggested to be used for this url. +* `CHECKURL-MULTI Url Size|UNKNOWN Filename ...` + Indicates that the requested url has been verified to exist, + and contains multiple files, which can each be accessed using + their own url. + Note that since a list is returned, neither the Url nor the Filename + can contain spaces. +* `CHECKURL-FAILURE` + Indicates that the requested url could not be accessed. * `UNSUPPORTED-REQUEST` Indicates that the special remote does not know how to handle a request. @@ -247,6 +273,17 @@ * `GETSTATE Key` Gets any state that has been stored for the key. (git-annex replies with VALUE followed by the state.) +* `SETURLPRESENT Key Url` + Records an url (or uri) where the Key can be downloaded from. +* `SETURLMISSING Key Url` + Records that the key can no longer be downloaded from the specified + url (or uri). +* `GETURLS Key Prefix` + Gets the recorded urls where a Key can be downloaded from. + Only urls that start with the Prefix will be returned. The Prefix + may be empty to get all urls. + (git-annex replies one or more times with VALUE for each url. + The final VALUE has an empty value, indicating the end of the url list.) * `DEBUG message` Tells git-annex to display the message if --debug is enabled. @@ -288,7 +325,5 @@ the remote. However, \n and probably \0 need to be escaped somehow in the file data, which adds complication. * uuid discovery during INITREMOTE. -* Support for getting and setting the list of urls that can be associated - with a key. * Hook into webapp. Needs a way to provide some kind of prompt to the user in the webapp, etc. diff --git a/doc/devblog/day_236__release_day.mdwn b/doc/devblog/day_236__release_day.mdwn new file mode 100644 --- /dev/null +++ b/doc/devblog/day_236__release_day.mdwn @@ -0,0 +1,10 @@ +Today's release has a month's accumulated changes, including several nice +new features: `git annex undo`, `git annex proxy`, `git annex diffdriver`, +and I was able to land the s3-aws branch in this release too, so lots of +improvements to the S3 support. + +Spent several hours getting the autobuilders updated, with the haskell +`aws` library installed. Android and armel builds are still out of date. + +Also fixed two Windows bugs related to the location of the bundled ssh +program. diff --git a/doc/devblog/day_237__extending_addurl.mdwn b/doc/devblog/day_237__extending_addurl.mdwn new file mode 100644 --- /dev/null +++ b/doc/devblog/day_237__extending_addurl.mdwn @@ -0,0 +1,14 @@ +Worked on [[todo/extensible_addurl]] today. When `git annex addurl` is run, +remotes will be asked if they claim the url, and whichever remote does will +be used to download it, and location tracking will indicate that remote +contains the object. This is a masive 1000 line patch touching 30 files, +including follow-on changes in `rmurl` and `whereis` and even `rekey`. + +It should now be possible to build an external special remote that handles +*.torrent and magnet: urls and passes them off to a bittorrent client for +download, for example. + +Another use for this would be to make an external special remote that +uses youtube-dl or some other program than quvi for downloading web videos. +The builtin quvi support could probably be moved out of the web special +remote, to a separate remote. I haven't tried to do that yet. diff --git a/doc/devblog/day_238__extending_addurl_further.mdwn b/doc/devblog/day_238__extending_addurl_further.mdwn new file mode 100644 --- /dev/null +++ b/doc/devblog/day_238__extending_addurl_further.mdwn @@ -0,0 +1,67 @@ +Some more work on the interface that lets remotes claim urls for `git annex +addurl`. Added support for remotes suggesting a filename to use when +adding an url. Also, added support for urls that result in multiple files +when downloaded. The obvious use case for that is an url to a torrent that +contains multiple files. + +Then, got `git annex importfeed` to also check if a remote claims an url. + +Finally, I put together a quick demo external remote using this new +interface. [[special_remotes/external/git-annex-remote-torrent]] +adds support for torrent files to git-annex, using [aria2c](http://aria2.sourceforge.net/) to download them. +It supports multi-file torrents, but not magnet links. (I'll probably +rewrite this more robustly and efficiently in haskell sometime soon.) + +Here's a demo: + +
+# git annex initremote torrent type=external encryption=none externaltype=torrent
+initremote torrent ok
+(Recording state in git...)
+# ls
+# git annex addurl  --fast file:///home/joey/my.torrent
+  % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current
+                                 Dload  Upload   Total   Spent    Left  Speed
+100   198  100   198    0     0  3946k      0 --:--:-- --:--:-- --:--:-- 3946k
+addurl _home_joey_my.torrent/bar (using torrent) ok
+addurl _home_joey_my.torrent/baz (using torrent) ok
+addurl _home_joey_my.torrent/foo (using torrent) ok
+(Recording state in git...)
+# ls _home_joey_my.torrent/
+bar@  baz@  foo@
+# git annex get _home_joey_my.torrent/baz
+get _home_joey_my.torrent/baz (from torrent...) 
+  % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current
+                                 Dload  Upload   Total   Spent    Left  Speed
+  0     0    0     0    0     0      0      0 --:--:-- --:--:-- --:--:-100   198  100   198    0     0  3580k      0 --:--:-- --:--:-- --:--:-- 3580k
+
+12/11 18:14:56 [NOTICE] IPv4 DHT: listening on UDP port 6946
+
+12/11 18:14:56 [NOTICE] IPv4 BitTorrent: listening on TCP port 6961
+
+12/11 18:14:56 [NOTICE] IPv6 BitTorrent: listening on TCP port 6961
+
+12/11 18:14:56 [NOTICE] Seeding is over.
+12/11 18:14:57 [NOTICE] Download complete: /home/joey/tmp/tmp.Le89hJSXyh/tor
+
+12/11 18:14:57 [NOTICE] Your share ratio was 0.0, uploaded/downloaded=0B/0B
+                                                                               
+Download Results:
+gid   |stat|avg speed  |path/URI
+======+====+===========+=======================================================
+71f6b6|OK  |       0B/s|/home/joey/tmp/tmp.Le89hJSXyh/tor/baz
+
+Status Legend:
+(OK):download completed.
+ok                      
+(Recording state in git...)
+# git annex find
+_home_joey_my.torrent/baz
+# git annex whereis _home_joey_my.torrent/baz
+whereis _home_joey_my.torrent/baz (2 copies) 
+  	1878241d-ee49-446d-8cce-041c46442d94 -- [torrent]
+   	52412020-2bb3-4aa4-ae16-0da22ba48875 -- joey@darkstar:~/tmp/repo [here]
+
+  torrent: file:///home/joey/my.torrent#2
+ok
+
diff --git a/doc/devblog/day_239-240__bittorrent_remote.mdwn b/doc/devblog/day_239-240__bittorrent_remote.mdwn new file mode 100644 --- /dev/null +++ b/doc/devblog/day_239-240__bittorrent_remote.mdwn @@ -0,0 +1,16 @@ +Spent a couple days adding a [[bittorrent_special_remote|special_remotes/bittorrent]] +to git-annex. This is better than the demo external torrent remote I made +on Friday: It's built into git-annex; it supports magnet links; it even +parses aria2c's output so the webapp can display progress bars. + +Besides needing `aria2` to download torrents, it also currently depends on +the `btshowmetainfo` command from the original bittorrent client (or +bittornado). I looked into using + instead, +but that package is out of date and doesn't currently build. I've got a +patch fixing that, but am waiting to hear back from the library's author. + +There is a bit of a behavior change here; while before `git annex addurl` of +a torrent file would add the torrent file itself to the repository, it now will +download and add the contents of the torrent. I think/hope this behavior +change is ok.. diff --git a/doc/forum/Auto_update_not_working.mdwn b/doc/forum/Auto_update_not_working.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Auto_update_not_working.mdwn @@ -0,0 +1,6 @@ +Hello, + +I've installed to ~/software/ using the prebuilt tarballs. I'm using the assistant with auto updates set to ask. Everytime I start the assistant it claims a new that a new version of git-annex has been installed. I click Finish Upgrade, it does the upgrade and it says to have finished upgrading to version 5.20141105-g8b19598. Next boot / restart everything starts again and it upgrades always to the same version. + +Thanks! +Florian diff --git a/doc/forum/Git_Annex_not_dropping_unused_content.mdwn b/doc/forum/Git_Annex_not_dropping_unused_content.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/Git_Annex_not_dropping_unused_content.mdwn @@ -0,0 +1,9 @@ +I've deleted some files, but their content remains in the objects directory, and *git annex unused* does not list them. + +I've read in this post that if other branches contain the files, then it won't count them as unused. My repo appears to have a few branches left over from views I've used. + + remotes/sdrive/views/(added=14_09);(tag=Shared) + remotes/sdrive/views/(added=14_09);Images_=_ + remotes/sdrive/views/added=_ + +How can I delete these? Is git annex going to create a new branch for every new view I create? diff --git a/doc/forum/How_to_hide_broken_symlinks.mdwn b/doc/forum/How_to_hide_broken_symlinks.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/How_to_hide_broken_symlinks.mdwn @@ -0,0 +1,45 @@ +This is a method for hiding broken links using git-annex views. + +Each annex will need it's own name for this system to work. For this example I'll use "localdrive." After getting file content, run: + + git-annex metadata --not --in=here --metadata in=localdrive . -s in-=localdrive + git-annex metadata --in=here --not --metadata in=localdrive . -s in+=localdrive + git-annex view /=* + git-annex vfilter in=localdrive + +Unused links will be hidden. Folder structures will remain the same. + +To switch back use: + + git-annex vpop 2 + +Because this is a lot to type, I've placed these in a bash script in the base folder (ignored with .gitignore so it isn't sent to other repos). The local repo name can be changed by editing THISREPO: + + #!/bin/bash + + THISREPO='localdrive' + + git-annex metadata --not --in=here --metadata in=$THISREPO . -s in-=$THISREPO + git-annex metadata --in=here --not --metadata in=$THISREPO . -s in+=$THISREPO + git-annex view /=* + git-annex vfilter in=$THISREPO + + exit 0 + +## Hiding Broken Links in Preferred Content Repos + +If you have a repo with preferred content settings, this can be shortened to a single script which can be run to "refresh" the view: + + #!/bin/bash + + THISREPO='pcrepo' + + git-annex vpop 2 + git-annex sync + git-annex get --auto + git-annex metadata --not --in=here --metadata in=$THISREPO . -s in-=$THISREPO + git-annex metadata --in=here --not --metadata in=$THISREPO . -s in+=$THISREPO + git-annex view /=* + git-annex vfilter in=$THISREPO + + exit 0 diff --git a/doc/forum/s3_server_side_encryption.mdwn b/doc/forum/s3_server_side_encryption.mdwn new file mode 100644 --- /dev/null +++ b/doc/forum/s3_server_side_encryption.mdwn @@ -0,0 +1,9 @@ +AWS S3 offers a feature to enable server-side encryption of files. +If I understand correctly, this is enabled by sending a specific HTTP header with the request to upload the file in question. +So, this header needs to be set every time we want to upload a new file. + +Is this feature already supported / being considered for future versions? + +If not, am I correct in assuming it would have to be implemented in https://github.com/joeyh/git-annex/blob/master/Remote/S3.hs ? + +Thank you diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -225,9 +225,12 @@ alternate locations from which the file can be downloaded. In this mode, addurl can be used both to add new files, or to add urls to existing files. - When quvi is installed, urls are automatically tested to see if they + When `quvi` is installed, urls are automatically tested to see if they point to a video hosting site, and the video is downloaded instead. + Urls to torrent files (including magnet links) will cause the content of + the torrent to be downloaded, using `aria2c`. + * `rmurl file url` Record that the file is no longer available at the url. @@ -1727,6 +1730,10 @@ Options to pass to quvi when using it to find the url to download for a video. + +* `annex.aria-torrent-options` + + Options to pass to aria2c when using it to download a torrent. * `annex.http-headers` diff --git a/doc/install/Docker.mdwn b/doc/install/Docker.mdwn --- a/doc/install/Docker.mdwn +++ b/doc/install/Docker.mdwn @@ -15,7 +15,7 @@ So's the armel autobuilder container. `docker pull joeyh/git-annex-armel-builder`, and its companion container -`docker pull joeyh/git-annex-armel-builder-companion` +`docker pull joeyh/git-annex-armel-companion` # building autobuilder containers using Propellor diff --git a/doc/install/fromsource/comment_47_6de25c1e450e1e3b1d18d2c76235ccb8._comment b/doc/install/fromsource/comment_47_6de25c1e450e1e3b1d18d2c76235ccb8._comment new file mode 100644 --- /dev/null +++ b/doc/install/fromsource/comment_47_6de25c1e450e1e3b1d18d2c76235ccb8._comment @@ -0,0 +1,7 @@ +[[!comment format=mdwn + username="thnetos" + subject="Where to start reading the source code?" + date="2014-12-15T22:04:06Z" + content=""" +Do you have any recommendations for the overall haskell architecture of the project? Where to start looking if I want to read through the source code? +"""]] diff --git a/doc/internals.mdwn b/doc/internals.mdwn --- a/doc/internals.mdwn +++ b/doc/internals.mdwn @@ -17,7 +17,7 @@ Each subdirectory has the [[name_of_a_key|key_format]] in one of the [[key-value_backends|backends]]. The file inside also has the name of the key. This two-level structure is used because it allows the write bit to be removed -from the subdirectories as well as from the files. That prevents accidentially +from the subdirectories as well as from the files. That prevents accidentally deleting or changing the file contents. See [[lockdown]] for details. In [[direct_mode]], file contents are not stored in here, and instead @@ -158,7 +158,7 @@ ## `group-preferred-content.log` Contains standard preferred content settings for groups. (Overriding or -supplimenting the ones built into git-annex.) +supplementing the ones built into git-annex.) The file format is one line per group, staring with a timestamp, then a space, then the group name followed by a space and then the preferred @@ -182,8 +182,9 @@ ## `aaa/bbb/*.log.web` These log files record urls used by the -[[web_special_remote|special_remotes/web]]. Their format is similar -to the location tracking files, but with urls rather than UUIDs. +[[web_special_remote|special_remotes/web]] and sometimes by other remotes. +Their format is similar to the location tracking files, but with urls +rather than UUIDs. ## `aaa/bbb/*.log.rmt` @@ -205,7 +206,7 @@ Lines are timestamped, and record when values are added (`field +value`), but also when values are removed (`field -value`). Removed values are retained in the log so that when merging an old line that sets a value -that was later unset, the value is not accidentially added back. +that was later unset, the value is not accidentally added back. For example: @@ -214,8 +215,8 @@ The value can be completely arbitrary data, although it's typically reasonably short. If the value contains any whitespace -(including \r or \r), it will be base64 encoded. Base64 encoded values -are indicated by prefixing them with "!" +(including \r or \n), it will be base64 encoded. Base64 encoded values +are indicated by prefixing them with "!". ## `aaa/bbb/*.log.cnk` @@ -237,7 +238,7 @@ The file format is simply one line per repository, with the uuid followed by a space and then its schedule, followed by a timestamp. -There can be multiple events in the schedule, separated by "; " +There can be multiple events in the schedule, separated by "; ". The format of the scheduled events is the same described in the SCHEDULED JOBS section of the man page. diff --git a/doc/internals/hashing/comment_2_086ea37acf15e2a8694b8386222b73f6._comment b/doc/internals/hashing/comment_2_086ea37acf15e2a8694b8386222b73f6._comment new file mode 100644 --- /dev/null +++ b/doc/internals/hashing/comment_2_086ea37acf15e2a8694b8386222b73f6._comment @@ -0,0 +1,11 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawnx8kHW66N3BqmkVpgtXDlYMvr8TJ5VvfY" + nickname="Yaroslav" + subject="comment 2" + date="2014-12-04T20:26:47Z" + content=""" +1c to support Péter's statement: + + $> git annex examinekey --format='${hashdirmixed}' \"SHA256E-s0--e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855\" + pX/ZJ/% +"""]] diff --git a/doc/news/version_5.20141013.mdwn b/doc/news/version_5.20141013.mdwn deleted file mode 100644 --- a/doc/news/version_5.20141013.mdwn +++ /dev/null @@ -1,7 +0,0 @@ -git-annex 5.20141013 released with [[!toggle text="these changes"]] -[[!toggleable text=""" - * Adjust cabal file to support building w/o assistant on the hurd. - * Support building with yesod 1.4. - * S3: Fix embedcreds=yes handling for the Internet Archive. - * map: Handle .git prefixed remote repos. Closes: #[614759](http://bugs.debian.org/614759) - * repair: Prevent auto gc from happening when fetching from a remote."""]] diff --git a/doc/news/version_5.20141219.mdwn b/doc/news/version_5.20141219.mdwn new file mode 100644 --- /dev/null +++ b/doc/news/version_5.20141219.mdwn @@ -0,0 +1,20 @@ +git-annex 5.20141219 released with [[!toggle text="these changes"]] +[[!toggleable text=""" + * Webapp: When adding a new box.com remote, use the new style chunking. + Thanks, Jon Ander Peñalba. + * External special remote protocol now includes commands for setting + and getting the urls associated with a key. + * Urls can now be claimed by remotes. This will allow creating, + for example, a external special remote that handles magnet: and + *.torrent urls. + * Use wget -q --show-progress for less verbose wget output, + when built with wget 1.16. + * Added bittorrent special remote. + * addurl behavior change: When downloading an url ending in .torrent, + it will download files from bittorrent, instead of the old behavior + of adding the torrent file to the repository. + * Added Recommends on aria2. + * When possible, build with the haskell torrent library for parsing + torrent files. As a fallback, can instead use btshowmetainfo from + bittornado | bittorrent. + * Fix build with -f-S3."""]] diff --git a/doc/related_software.mdwn b/doc/related_software.mdwn --- a/doc/related_software.mdwn +++ b/doc/related_software.mdwn @@ -15,3 +15,7 @@ [an extension](https://github.com/magit/magit-annex) for git annex. * [DataLad](http://datalad.org/) uses git-annex to provide access to scientific data available from various sources. +* The [Baobáxia](https://github.com/RedeMocambos/baobaxia) project + built by the Brazilian [Mocambos network](http://www.mocambos.net/) + is [using git-annex to connect isolated communities](http://www.modspil.dk/itpolitik/baob_xia.html). + Repositories sync over satellite internet and/or sneakernet. diff --git a/doc/special_remotes.mdwn b/doc/special_remotes.mdwn --- a/doc/special_remotes.mdwn +++ b/doc/special_remotes.mdwn @@ -17,6 +17,7 @@ * [[webdav]] * [[tahoe]] * [[web]] +* [[bittorrent]] * [[xmpp]] * [[hook]] diff --git a/doc/special_remotes/S3.mdwn b/doc/special_remotes/S3.mdwn --- a/doc/special_remotes/S3.mdwn +++ b/doc/special_remotes/S3.mdwn @@ -60,6 +60,8 @@ but can be enabled or changed at any time. time. + NOTE: there is a [[bug|/bugs/S3_upload_not_using_multipart/]] which depends on the AWS library. See [[this comment|http://git-annex.branchable.com/bugs/S3_upload_not_using_multipart/#comment-4c45dac68866d3550c0b32ed466e2c6a]] (the latest as of now). + * `fileprefix` - By default, git-annex places files in a tree rooted at the top of the S3 bucket. When this is set, it's prefixed to the filenames used. For example, you could set it to "foo/" in one special remote, diff --git a/doc/special_remotes/bittorrent.mdwn b/doc/special_remotes/bittorrent.mdwn new file mode 100644 --- /dev/null +++ b/doc/special_remotes/bittorrent.mdwn @@ -0,0 +1,29 @@ +Similar to the [[web]] special remote, git-annex can use BitTorrent as +a source for files that are added to the git-annex repository. + +It supports both `.torrent` files, and `magnet:` links. When you run `git +annex addurl` with either of these, it will download the contents of the +torrent and add it to the git annex repository. + +See [[tips/using_the_web_as_a_special_remote]] for usage examples. + +git-annex uses [aria2](http://aria2.sourceforge.net/) to download torrents. + +If git-annex is not built using the haskell torrent library to parse +torrents, it also needs the needs the `btshowmetainfo` program, from +either bittornado or the original BitTorrent client. + +## notes + +Currently git-annex only supports downloading content from a torrent; +it cannot upload or remove content. + +Multi-file torrents are supported; to handle them, `git annex addurl` +will add a directory containing all the files from the torrent. + +It's hard to say if a torrent is healthy enough to let a file be downloaded +from it, and harder to predict if a torrent will stay healthy. So, +git-annex takes a cautious approach and when dropping a file, won't +treat this special remote as one of the required [[copies]]. It's probably +a good idea to configure git-annex to fully distrust this remote, by +running `git annex untrust bittorrent` diff --git a/doc/special_remotes/bup/comment_12_fca579678edde073716f099c767767e1._comment b/doc/special_remotes/bup/comment_12_fca579678edde073716f099c767767e1._comment new file mode 100644 --- /dev/null +++ b/doc/special_remotes/bup/comment_12_fca579678edde073716f099c767767e1._comment @@ -0,0 +1,10 @@ +[[!comment format=mdwn + username="https://www.google.com/accounts/o8/id?id=AItOawkEYZEqLf3Aj_FGV7S0FvsMplmGqqb555M" + nickname="Sergiusz" + subject="bup-join local-arch/2014-12-03-235617 " + date="2014-12-04T19:38:07Z" + content=""" +How can I restore the previous commit from bup archives created with bup-split? Yes, I know I can use bup-join local-arch~1 git notation, but I would like to use bup-join local-arch/2014-12-03-235617 (bup-ls local-arch results) ...but this method does not work ... + +s. +"""]] diff --git a/doc/special_remotes/external.mdwn b/doc/special_remotes/external.mdwn --- a/doc/special_remotes/external.mdwn +++ b/doc/special_remotes/external.mdwn @@ -14,14 +14,18 @@ * Install it in PATH. * When the user runs `git annex initremote foo type=external externaltype=$bar`, it will use your program. +* See [[design/external_special_remote_protocol]] for what the program + needs to do. There's an example at the end of this page. * If things don't seem to work, pass `--debug` and you'll see, amoung other things, a transcript of git-annex's communication with your program. * If you build a new special remote, please add it to the list of [[special_remotes]]. +Here's an example of using an external special remote to add torrent +support to git-annex: [[external/git-annex-remote-torrent]] + Here's a simple shell script example, which can easily be adapted to run whatever commands you need. Or better, re-written in some better -language of your choice. See [[design/external_special_remote_protocol]] -for the details. +language of your choice. [[!inline pages="special_remotes/external/example.sh" feeds=no]] diff --git a/doc/special_remotes/external/git-annex-remote-torrent b/doc/special_remotes/external/git-annex-remote-torrent new file mode 100644 --- /dev/null +++ b/doc/special_remotes/external/git-annex-remote-torrent @@ -0,0 +1,203 @@ +#!/bin/sh +# This is a demo git-annex external special remote program, +# which adds basic torrent download support to git-annex. +# +# Uses aria2c. Also needs the original bittorrent (or bittornado) for the +# btshowmetainfo command. +# +# Install in PATH as git-annex-remote-torrent +# +# Enable remote by running: +# git annex initremote torrent type=external encryption=none externaltype=torrent +# git annex untrust torrent +# +# Copyright 2014 Joey Hess; licenced under the GNU GPL version 3 or higher. + +set -e + +# This program speaks a line-based protocol on stdin and stdout. +# When running any commands, their stdout should be redirected to stderr +# (or /dev/null) to avoid messing up the protocol. +runcmd () { + "$@" >&2 +} + +# Gets a VALUE response and stores it in $RET +getvalue () { + read resp + # Tricky POSIX shell code to split first word of the resp, + # preserving all other whitespace + case "${resp%% *}" in + VALUE) + RET="$(echo "$resp" | sed 's/^VALUE \?//')" + ;; + *) + RET="" + ;; + esac +} + +# Get a list of all known torrent urls for a key, +# storing it in a temp file. +geturls () { + key="$1" + tmp="$2" + + echo GETURLS "$key" + getvalue + while [ -n "$RET" ]; do + if istorrent "$RET"; then + echo "$RET" >> "$tmp" + fi + getvalue + done +} + +# Does the url end in .torrent? +# Note that we use #N on the url to indicate which file +# from a multi-file torrent is wanted. +istorrent () { + echo "$1" | egrep -q "\.torrent(#.*)?$" +} + +# Download a single file from a torrent. +# +# Note: Does not support resuming interrupted transfers. +# Note: Does not feed progress info back to git-annex, and since +# the destination file is only populated at the end, git-annex will fail +# to display a progress bar for this download. +downloadtorrent () { + torrent="$1" + n="$2" + dest="$3" + + tmpdir="$(mktemp -d)" + + # aria2c will create part of the directory structure + # contained in the torrent. It may download parts of other files + # in addition to the one we asked for. So, we need to find + # out the filename we want, and look for it. + wantdir="$(btshowmetainfo "$torrent" | grep "^directory name: " | sed "s/^directory name: //" || true)" + if [ -n "$wantdir" ]; then + wantfile="$(btshowmetainfo "$torrent" | grep '^ ' | sed 's/^ //' | head -n "$n" | tail -n 1 | sed 's/ ([0-9]*)$//')" + if ! runcmd aria2c --select-file="$n" "$torrent" -d "$tmpdir"; then + false + fi + else + wantfile="$(btshowmetainfo "$torrent" | egrep "^file name.*: " | sed "s/^file name.*: //")" + wantdir=. + if ! runcmd aria2c "$torrent" -d "$tmpdir"; then + false + fi + fi + if [ -e "$tmpdir/$wantdir/$wantfile" ]; then + mv "$tmpdir/$wantdir/$wantfile" "$dest" + rm -rf "$tmpdir" + else + rm -rf "$tmpdir" + false + fi +} + +# This has to come first, to get the protocol started. +echo VERSION 1 + +while read line; do + set -- $line + case "$1" in + INITREMOTE) + echo INITREMOTE-SUCCESS + ;; + PREPARE) + echo PREPARE-SUCCESS + ;; + CLAIMURL) + url="$2" + if istorrent "$url"; then + echo CLAIMURL-SUCCESS + else + echo CLAIMURL-FAILURE + fi + ;; + CHECKURL) + url="$2" + # List contents of torrent. + tmp=$(mktemp) + if ! runcmd curl -o "$tmp" "$url"; then + echo CHECKURL-FAILURE + else + oldIFS="$IFS" + IFS=" +" + printf "CHECKURL-MULTI" + n=0 + for l in $(btshowmetainfo "$tmp" | grep '^ ' | sed 's/^ //'); do + # Note that the file cannot contain spaces. + file="$(echo "$l" | sed 's/ ([0-9]*)$//' | sed 's/ /_/g')" + size="$(echo "$l" | sed 's/.* (\([0-9]*\))$/\1/')" + n=$(expr $n + 1) + printf " $url#$n $size $file" + done + if [ "$n" = 0 ]; then + file="$(btshowmetainfo "$tmp" | egrep "^file name.*: " | sed "s/^file name.*: //")" + size="$(btshowmetainfo "$tmp" | egrep "^file size.*: " | sed "s/^file size.*: \([0-9]*\).*/\1/")" + printf " $url $size $file" + fi + printf "\n" + IFS="$oldIFS" + fi + rm -f "$tmp" + ;; + TRANSFER) + key="$3" + file="$4" + case "$2" in + STORE) + echo TRANSFER-FAILURE STORE "$key" "upload not supported" + ;; + RETRIEVE) + urltmp=$(mktemp) + geturls "$key" "$urltmp" + url="$(head "$urltmp")" || true + rm -f "$urltmp" + if [ -z "$url" ]; then + echo TRANSFER-FAILURE RETRIEVE "$key" "no known torrent urls for this key" + else + tmp=$(mktemp) + if ! runcmd curl -o "$tmp" "$url"; then + echo TRANSFER-FAILURE RETRIEVE "$key" "failed downloading torrent file from $url" + else + filenum="$(echo "$url" | sed 's/(.*#\(\d*\)/\1/')" + if downloadtorrent "$tmp" "$filenum" "$file"; then + echo TRANSFER-SUCCESS RETRIEVE "$key" + else + echo TRANSFER-FAILURE RETRIEVE "$key" "failed to download torrent contents from $url" + fi + fi + rm -f "$tmp" + fi + ;; + esac + ;; + CHECKPRESENT) + key="$2" + # Let's just assume that torrents are never present + # for simplicity. + echo CHECKPRESENT-UNKNOWN "$key" "cannot reliably check torrent status" + ;; + REMOVE) + key="$2" + # Remove all torrent urls for the key. + tmp=$(mktemp) + geturls "$key" "$tmp" + for url in $(cat "$tmp"); do + echo SETURLMISSING "$key" "$url" + done + rm -f "$tmp" + echo REMOVE-SUCCESS "$key" + ;; + *) + echo UNSUPPORTED-REQUEST + ;; + esac +done diff --git a/doc/thanks.mdwn b/doc/thanks.mdwn --- a/doc/thanks.mdwn +++ b/doc/thanks.mdwn @@ -14,6 +14,8 @@ [NSF](https://www.nsf.gov/awardsearch/showAward?AWD_ID=1429999) as a part of the [DataLad project](http://datalad.org/). +Thanks also to these folks for their support: martin f. krafft and John Byrnes. + ## 2013-2014 Continued git-annex development was [crowd funded](https://campaign.joeyh.name/) @@ -132,7 +134,7 @@ Mica Semrick, Paul Staab, Rémi Vanicat, Martin Holtschneider, Jan Ivar Beddari, Peter Simons, Thomas Koch, Justin Geibel, Guillaume DELVIT, Shanti Bouchez, Oliver Brandt, François Deppierraz, Chad Walstrom, Tim Mattison, -Jakub Antoni Tyszko, Casa do Boneco, Florian Tham, martin f. krafft, +Jakub Antoni Tyszko, Casa do Boneco, Florian Tham, and 30 anonymous bitcoin users With an especial thanks to the WikiMedia foundation, diff --git a/doc/tips/using_the_web_as_a_special_remote.mdwn b/doc/tips/using_the_web_as_a_special_remote.mdwn --- a/doc/tips/using_the_web_as_a_special_remote.mdwn +++ b/doc/tips/using_the_web_as_a_special_remote.mdwn @@ -104,6 +104,18 @@ More details about youtube feeds at -- `git-annex importfeed` should handle all of them. +## bittorrent + +The [[bittorrent_special_remote|special_remotes/bittorrent]] lets git-annex +also download the content of torrent files, and magnet links to torrents. + +You can simply pass the url to a torrent to `git annex addurl` +the same as any other url. + +You have to have [aria2](http://aria2.sourceforge.net/) +and bittornado (or the original bittorrent) installed for this +to work. + ## podcasts This is done using `git annex importfeed`. See [[downloading podcasts]]. diff --git a/doc/todo/Bittorrent-like_features.mdwn b/doc/todo/Bittorrent-like_features.mdwn --- a/doc/todo/Bittorrent-like_features.mdwn +++ b/doc/todo/Bittorrent-like_features.mdwn @@ -45,3 +45,5 @@ This way, a torrent would just become another source for a specific file. When we `get` the file, it fires up `$YOUR_FAVORITE_TORRENT_CLIENT` to download the file. That way we avoid the implementation complexity of shoving a complete bittorrent client within the assistant. The `get` operation would block until the torrent is downloaded, i guess... --[[anarcat]] + +> This is now [[implemented|special_remotes/bittorrent/]]. Including magnet link support, and multi-file torrent support. Leaving todo item open for the blue-sky stuff at top. --[[Joey]] diff --git a/doc/todo/extensible_addurl.mdwn b/doc/todo/extensible_addurl.mdwn new file mode 100644 --- /dev/null +++ b/doc/todo/extensible_addurl.mdwn @@ -0,0 +1,88 @@ +`git annex addurl` supports regular urls, as well as detecting videos that +quvi can download. We'd like to extend this to support extensible uri +handling. + +Use cases range from torrent download support, to pulling data +from scientific data repositories that use their own APIs. + +The basic idea is to have external special remotes (or perhaps built-in +ones in some cases), which addurl can use to download an object, referred +to by some uri-like thing. The uri starts with "$downloader:" to indicate +that it's not a regular url and so is not handled by the web special +remote. + + git annex addurl torrent:$foo + git annex addurl CERN:$bar + +Problem: This requires mapping from the name of the downloader, which is +probably the same as the git-annex-remote-$downloader program implementing +the special remote protocol (but not always), to the UUID of a remote. +That's assuming we want location tracking to be able to know that a file is +both available from CERN and from a torrent, for example. + +Solution: Add a new method to remotes: + + claimUrl :: Maybe (URLString -> Annex Bool) + +Remotes that implement this method (including special remotes) will +be queried when such an uri is added, to see which claims it. + +Once the remote is known, addurl --file will record that the Key is present +on that remote, and record the uri in the url log. + +---- + +What about using addurl to add a new file? In this mode, the Key is not yet +known. addurl currently handles this by generating a dummy Key for the url +(hitting the url to get its size), and running a Transfer using the dummy +key that downloads from the web. Once the download is done, the dummy Key +is upgraded to the final Key. + +Something similar could be done for other remotes, but the url log for the +dummy key would need to have the url added to it, for the remote to know +what to download, and then that could be removed after the download. Which +causes ugly churn in git, and would leave a mess if interrupted. + +One option is to add another new method to remotes: + + downloadUrl :: Maybe (URLString -> Annex FilePath) + +Or, the url log could have support added for recording temporary key +urls in memory. (done) + +Another problem is that the size of the Key isn't known. addurl +could always operate in relaxed mode, where it generates a size-less Key. +Or, yet another method could be added: (done) + + sizeUrl :: URLString -> Annex (Maybe Integer) + +---- + +Retrieval of the Key works more or less as usual. The only +difference being that remotes that support this interface can look +at the url log to find the one with the right "$downloader:" prefix, +and so know where to download from. (Much as the web special remote already +does.) + +Prerequisite: Expand the external special remote interface to support +accessing the url log. (done) + +---- + +It would also be nice to be able to easily configure a regexp that normal +urls, if they match, are made to use a particular downloader. So, for +torrents, this would make matching urls have torrent: prefixed to them. + + git config annex.downloader.torrent.regexp '(^magnet:|\.torrent$)' + +It might also be useful to allow bypassing the complexity of the external +special remote interface, and let a downloader be specified simply by: + + git config annex.downloader.torrent.command 'aria2c %url $file' + +This could be implemented in either the web special remote or even in an +external special remote. + +Some other discussion at + +> [[done]]! --[[Joey]] diff --git a/doc/todo/inject_on_import.mdwn b/doc/todo/inject_on_import.mdwn new file mode 100644 --- /dev/null +++ b/doc/todo/inject_on_import.mdwn @@ -0,0 +1,21 @@ +Would it be possible to add an `--inject` option to import? + +Say, for example, I have an annex on computer A which has a subset of files and a directory of files which are potentional duplicates of files in the annex. + +I would like to do something like this: + + mkdir ~/annex/import + cd ~/annex/import + git annex import --deduplicate --inject ~/directory/of/files + +This would do the same as `--deduplicate`, except if the file is not present in the annex, it would be injected. For example: + +Annex knows about A and B, A is present but B is not. +$DIR contains A, B and C. + +A would be deleted from $DIR due to `--deduplicate`. +B would be injected into the repo (making it present) due to `--inject`, then deleted from $DIR. +C would be added to the annex, resulting in this + + $ ls ~/annex/import + C diff --git a/doc/todo/parallel_get.mdwn b/doc/todo/parallel_get.mdwn new file mode 100644 --- /dev/null +++ b/doc/todo/parallel_get.mdwn @@ -0,0 +1,73 @@ +Wish: `git annex get [files] -jN` should run up to N downloads of files +concurrently. + +This can already be done by just starting up N separate git-annex +processes all trying to get the same files. They'll coordinate themselves +to avoid downloading the same file twice. + +But, the output of concurrent git annex get's in a single teminal is a +mess. + +It would be nice to have something similar to docker's output when fetching +layers of an image. Something like: + + get foo1 ok + get foo2 ok + get foo3 -> 5% 100 KiB/s + get foo4 -> 3% 90 KiB/s + get foo5 -> 20% 1 MiB/s + +Where the bottom N lines are progress displays for the downloads that are +currently in progress. When a download finishes, it can scroll up the +screen with "ok". + + get foo1 ok + get foo2 ok + get foo5 ok + get foo3 -> 5% 100 KiB/s + get foo4 -> 3% 90 KiB/s + get foo6 -> 0% 110 Kib/S + +This display could perhaps be generalized for other concurrent actions. +For example, drop: + + drop foo1 ok + drop foo2 failed + Not enough copies ... + drop foo3 -> (checking r1...) + drop foo4 -> (checking r2...) + +But, do get first. + +Pain points: + +1. Currently, git-annex lets tools like rsync and wget display their own + progress. This makes sense for the single-file at a time get, because + rsync can display better output than just a percentage. (This is especially + the case with aria2c for torrents, which displays seeder/leecher info in + addition to percentage.) + + But in multi-get mode, the progress display would be simplified. git-annex + can already get percent done information, either as reported by individiual + backends, or by falling back to polling the file as it's downloaded. + +2. The mechanics of updating the screen for a multi-line progress output + require some terminal handling code. Using eg, curses, in a mode that + doesn't take over the whole screen display, but just moves the cursor + up to the line for the progress that needs updating and redraws that + line. Doing this portably is probably going to be a pain, especially + I have no idea if it can be done on Windows. + + An alternative would be a display more like apt uses for concurrent + downloads, all on one line: + + get foo1 ok + get foo2 ok + get [foo3 -> 5% 100 KiB/s] [foo4 -> 3% 90 KiB/s] [foo5 -> 20% 1 MiB/s] + + The problem with that is it has to avoid scrolling off the right + side, so it probably has to truncate the line. Since filenames + are often longer than "fooN", it probably has to elipsise the filename. + This approach is just not as flexible or nice in general. + +See also: [[parallel_possibilities]] diff --git a/git-annex.1 b/git-annex.1 --- a/git-annex.1 +++ b/git-annex.1 @@ -208,9 +208,12 @@ alternate locations from which the file can be downloaded. In this mode, addurl can be used both to add new files, or to add urls to existing files. .IP -When quvi is installed, urls are automatically tested to see if they +When \fBquvi\fP is installed, urls are automatically tested to see if they point to a video hosting site, and the video is downloaded instead. .IP +Urls to torrent files (including magnet links) will cause the content of +the torrent to be downloaded, using \fBaria2c\fP. +.IP .IP "\fBrmurl file url\fP" Record that the file is no longer available at the url. .IP @@ -1552,6 +1555,9 @@ .IP "\fBannex.quvi\-options\fP" Options to pass to quvi when using it to find the url to download for a video. +.IP +.IP "\fBannex.aria\-torrent\-options\fP" +Options to pass to aria2c when using it to download a torrent. .IP .IP "\fBannex.http\-headers\fP" HTTP headers to send when downloading from the web. Multiple lines of diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 5.20141203 +Version: 5.20141219 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess @@ -93,6 +93,9 @@ Flag DesktopNotify Description: Enable desktop environment notifications +Flag TorrentParser + Description: Use haskell torrent library to parse torrent files + Flag EKG Description: Enable use of EKG to monitor git-annex as it runs (at http://localhost:4242/) Default: False @@ -151,7 +154,7 @@ CPP-Options: -DWITH_CRYPTOHASH if flag(S3) - Build-Depends: conduit, resourcet, conduit-extra, aws (>= 0.9.2) + Build-Depends: conduit, resourcet, conduit-extra, aws (>= 0.9.2), http-client CPP-Options: -DWITH_S3 if flag(WebDAV) @@ -233,6 +236,10 @@ if flag(Tahoe) Build-Depends: aeson CPP-Options: -DWITH_TAHOE + + if flag(TorrentParser) + Build-Depends: torrent (>= 10000.0.0) + CPP-Options: -DWITH_TORRENTPARSER if flag(EKG) Build-Depends: ekg diff --git a/standalone/android/buildchroot-inchroot b/standalone/android/buildchroot-inchroot --- a/standalone/android/buildchroot-inchroot +++ b/standalone/android/buildchroot-inchroot @@ -16,7 +16,7 @@ apt-get -y install happy alex apt-get -y install llvm-3.4 apt-get -y install ca-certificates curl file m4 autoconf zlib1g-dev -apt-get -y install libgnutls-dev libxml2-dev libgsasl7-dev pkg-config c2hs +apt-get -y install libgnutls28-dev libxml2-dev libgsasl7-dev pkg-config c2hs apt-get -y install ant default-jdk rsync wget gnupg lsof apt-get -y install gettext unzip python apt-get -y install locales automake diff --git a/standalone/android/install-haskell-packages b/standalone/android/install-haskell-packages --- a/standalone/android/install-haskell-packages +++ b/standalone/android/install-haskell-packages @@ -32,9 +32,9 @@ ver="$(grep " $pkg " ../cabal.config | cut -d= -f 3 | sed 's/,$//')" fi if [ -z "$ver" ]; then - cabal unpack $pkg + cabal unpack --pristine $pkg else - cabal unpack $pkg-$ver + cabal unpack --pristine $pkg-$ver fi cd $pkg* git init diff --git a/standalone/linux/cabal.config b/standalone/linux/cabal.config new file mode 100644 --- /dev/null +++ b/standalone/linux/cabal.config @@ -0,0 +1,208 @@ +constraints: Crypto ==4.2.5.1, + DAV ==1.0.3, + HTTP ==4000.2.17, + HUnit ==1.2.5.2, + IfElse ==0.85, + MissingH ==1.2.1.0, + MonadRandom ==0.1.13, + QuickCheck ==2.7.6, + SHA ==1.6.1, + SafeSemaphore ==0.10.1, + aeson ==0.7.0.6, + ansi-terminal ==0.6.1.1, + ansi-wl-pprint ==0.6.7.1, + appar ==0.1.4, + asn1-encoding ==0.8.1.3, + asn1-parse ==0.8.1, + asn1-types ==0.2.3, + async ==2.0.1.5, + attoparsec ==0.11.3.4, + attoparsec-conduit ==1.1.0, + authenticate ==1.3.2.10, + base-unicode-symbols ==0.2.2.4, + base16-bytestring ==0.1.1.6, + base64-bytestring ==1.0.0.1, + bifunctors ==4.1.1.1, + bloomfilter ==2.0.0.0, + byteable ==0.1.1, + byteorder ==1.0.4, + case-insensitive ==1.2.0.1, + cereal ==0.4.0.1, + cipher-aes ==0.2.8, + cipher-des ==0.0.6, + cipher-rc4 ==0.1.4, + clientsession ==0.9.0.3, + comonad ==4.2, + conduit ==1.1.6, + conduit-extra ==1.1.3, + connection ==0.2.3, + contravariant ==0.6.1.1, + cookie ==0.4.1.2, + cprng-aes ==0.5.2, + crypto-api ==0.13.2, + crypto-cipher-types ==0.0.9, + crypto-numbers ==0.2.3, + crypto-pubkey ==0.2.4, + crypto-pubkey-types ==0.4.2.2, + crypto-random ==0.0.7, + cryptohash ==0.11.6, + cryptohash-conduit ==0.1.1, + css-text ==0.1.2.1, + shakespeare-text ==1.0.2, + data-default ==0.5.3, + data-default-class ==0.0.1, + data-default-instances-base ==0.0.1, + data-default-instances-containers ==0.0.1, + data-default-instances-dlist ==0.0.1, + data-default-instances-old-locale ==0.0.1, + dataenc ==0.14.0.7, + dbus ==0.10.8, + distributive ==0.4.4, + dlist ==0.7.0.1, + dns ==1.3.0, + edit-distance ==0.2.1.2, + either ==4.3, + email-validate ==1.0.0, + entropy ==0.2.1, + errors ==1.4.7, + exceptions ==0.6.1, + failure ==0.2.0.3, + fast-logger ==2.1.5, + fdo-notify ==0.3.1, + feed ==0.3.9.2, + file-embed ==0.0.6, + fingertree ==0.1.0.0, + free ==4.9, + gnuidn ==0.2, + gnutls ==0.1.4, + gsasl ==0.3.5, + hS3 ==0.5.7, + hamlet ==1.1.9.2, + hashable ==1.2.1.0, + hinotify ==0.3.5, + hjsmin ==0.1.4.7, + hslogger ==1.2.1, + http-client ==0.3.8.2, + http-client-tls ==0.2.2, + http-conduit ==2.1.2.3, + http-date ==0.0.2, + http-types ==0.8.5, + hxt ==9.3.1.4, + hxt-charproperties ==9.1.1.1, + hxt-regex-xmlschema ==9.0.4, + hxt-unicode ==9.0.2.2, + idna ==0.2, + iproute ==1.2.11, + json ==0.5, + keys ==3.10.1, + language-javascript ==0.5.13, + lens ==4.4.0.2, + libxml-sax ==0.7.5, + mime-mail ==0.4.1.2, + mime-types ==0.1.0.4, + mmorph ==1.0.3, + monad-control ==0.3.2.2, + monad-logger ==0.3.6.1, + monad-loops ==0.4.2.1, + monads-tf ==0.1.0.2, + mtl ==2.1.2, + nats ==0.1.2, + network ==2.4.1.2, + network-conduit ==1.1.0, + network-info ==0.2.0.5, + network-multicast ==0.0.10, + network-protocol-xmpp ==0.4.6, + network-uri ==2.6.0.1, + optparse-applicative ==0.10.0, + parallel ==3.2.0.4, + path-pieces ==0.1.4, + pem ==0.2.2, + persistent ==1.3.3, + persistent-template ==1.3.2.2, + pointed ==4.0, + prelude-extras ==0.4, + profunctors ==4.0.4, + publicsuffixlist ==0.1, + punycode ==2.0, + random ==1.0.1.1, + ranges ==0.2.4, + reducers ==3.10.2.1, + reflection ==1.2.0.1, + regex-base ==0.93.2, + regex-compat ==0.95.1, + regex-posix ==0.95.2, + regex-tdfa ==1.2.0, + resource-pool ==0.2.1.1, + resourcet ==1.1.2.3, + safe ==0.3.8, + securemem ==0.1.3, + semigroupoids ==4.2, + semigroups ==0.15.3, + shakespeare ==1.2.1.1, + shakespeare-css ==1.0.7.4, + shakespeare-i18n ==1.0.0.5, + shakespeare-js ==1.2.0.4, + silently ==1.2.4.1, + simple-sendfile ==0.2.14, + skein ==1.0.9, + socks ==0.5.4, + split ==0.2.2, + stm ==2.4.2, + stm-chans ==3.0.0.2, + streaming-commons ==0.1.4.1, + stringprep ==0.1.5, + stringsearch ==0.3.6.5, + syb ==0.4.0, + system-fileio ==0.3.14, + system-filepath ==0.4.12, + tagged ==0.7.2, + tagsoup ==0.13.1, + tagstream-conduit ==0.5.5.1, + tasty ==0.10, + tasty-hunit ==0.9, + tasty-quickcheck ==0.8.1, + tasty-rerun ==1.1.3, + text ==1.1.1.0, + text-icu ==0.6.3.7, + tf-random ==0.5, + tls ==1.2.9, + transformers ==0.3.0.0, + transformers-base ==0.4.1, + transformers-compat ==0.3.3.3, + unbounded-delays ==0.1.0.8, + unix-compat ==0.4.1.3, + unix-time ==0.2.2, + unordered-containers ==0.2.5.0, + utf8-string ==0.3.7, + uuid ==1.3.3, + vault ==0.3.0.3, + vector ==0.10.0.1, + void ==0.6.1, + wai ==3.0.1.1, + wai-app-static ==3.0.0.1, + wai-extra ==3.0.1.2, + wai-logger ==2.1.1, + warp ==3.0.0.5, + warp-tls ==3.0.0, + word8 ==0.1.1, + x509 ==1.4.11, + x509-store ==1.4.4, + x509-system ==1.4.5, + x509-validation ==1.5.0, + xml ==1.3.13, + xml-conduit ==1.2.1, + xml-hamlet ==0.4.0.9, + xml-types ==0.3.4, + xss-sanitize ==0.3.5.2, + yaml ==0.8.9.3, + yesod ==1.2.6.1, + yesod-auth ==1.3.4.6, + yesod-core ==1.2.20.1, + yesod-default ==1.2.0, + yesod-form ==1.3.16, + yesod-persistent ==1.2.3.1, + yesod-routes ==1.2.0.7, + yesod-static ==1.2.4, + zlib ==0.5.4.1, + bytestring ==0.10.4.0, + scientific ==0.3.3.1 diff --git a/standalone/linux/install-haskell-packages b/standalone/linux/install-haskell-packages --- a/standalone/linux/install-haskell-packages +++ b/standalone/linux/install-haskell-packages @@ -3,13 +3,10 @@ # to all the necessary haskell packages being installed, with the # necessary patches to work on architectures that lack template haskell. # -# Note that the newest version of packages are installed. -# It attempts to reuse patches for older versions, but -# new versions of packages often break cross-compilation by adding TH, -# etc -# -# Future work: Convert to using the method used here: -# https://github.com/kaoskorobase/ghc-ios-cabal-scripts/ +# The cabal.config is used to pin the haskell packages to the last +# versions that have been gotten working. To update, delete the +# cabal.config, run this script with an empty cabal and fix up the broken +# patches, and then use cabal freeze to generate a new cabal.config. set -e @@ -26,14 +23,22 @@ patched () { pkg=$1 - shift 1 - cabal unpack $pkg$1 + ver=$2 + if [ -z "$ver" ]; then + ver="$(grep " $pkg " ../cabal.config | cut -d= -f 3 | sed 's/,$//')" + fi + if [ -z "$ver" ]; then + cabal unpack --pristine $pkg + else + cabal unpack --pristine $pkg-$ver + fi cd $pkg* git init git config user.name dummy git config user.email dummy@example.com git add . git commit -m "pre-patched state of $pkg" + ln -sf ../../cabal.config for patch in ../../haskell-patches/${pkg}_* ../../../no-th/haskell-patches/${pkg}_*; do if [ -e "$patch" ]; then echo trying $patch @@ -45,16 +50,19 @@ fi done cabalinstall - rm -rf $pkg* + rm -f cabal.config cd .. + rm -rf $pkg* } installgitannexdeps () { pushd ../.. + ln -sf standalone/linux/cabal.config echo "cabal install QuickCheck -f-templateHaskell" - cabal install QuickCheck -f-templateHaskell + cabal install -j1 QuickCheck -f-templateHaskell echo cabal install --only-dependencies "$@" - cabal install --only-dependencies "$@" + cabal install -j1 --only-dependencies "$@" + rm -f cabal.config popd } @@ -71,14 +79,12 @@ patched yesod-routes patched monad-logger patched skein + patched shakespeare-js + patched hamlet patched yesod-core patched persistent patched persistent-template - # Newer versions of file-embed cause ghc -ddump-splices - # to output invalid character codes. - # Note that the system generating the splices should also - # use this version of file-embed. - patched file-embed -0.0.6 + patched file-embed patched process-conduit patched yesod-static patched yesod-persistent