geturi = next $ isJust <$> downloadRemoteFile addunlockedmatcher r (downloadOptions o) uri file sz
downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key)
-downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ do
+downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do
let urlkey = Backend.URL.fromUrl uri sz
createWorkTreeDirectory (parentDir file)
ifM (Annex.getState Annex.fast <||> pure (relaxedOption o))
( do
- addWorkTree o addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing
+ addWorkTree canadd addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing
return (Just urlkey)
, do
-- Set temporary url for the urlkey
setTempUrl urlkey loguri
let downloader = \dest p ->
fst <$> Remote.verifiedAction (Remote.retrieveKeyFile r urlkey af dest p)
- ret <- downloadWith o addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file
+ ret <- downloadWith canadd addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file
removeTempUrl urlkey
return ret
)
( tryyoutubedl tmp
, normalfinish tmp
)
- normalfinish tmp = checkCanAdd o file $ do
+ normalfinish tmp = checkCanAdd o file $ \canadd -> do
showDestinationFile file
createWorkTreeDirectory (parentDir file)
- Just <$> finishDownloadWith o addunlockedmatcher tmp webUUID url file
+ Just <$> finishDownloadWith canadd addunlockedmatcher tmp webUUID url file
-- Ask youtube-dl what filename it will download first,
-- so it's only used when the file contains embedded media.
tryyoutubedl tmp = youtubeDlFileNameHtmlOnly url >>= \case
youtubeDl url workdir >>= \case
Right (Just mediafile) -> do
cleanuptmp
- checkCanAdd o dest $ do
+ checkCanAdd o dest $ \canadd -> do
showDestinationFile dest
- addWorkTree o addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile)
+ addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile)
return $ Just mediakey
Right Nothing -> normalfinish tmp
Left msg -> do
- Downloads the url, sets up the worktree file, and returns the
- real key.
-}
-downloadWith :: DownloadOptions -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key)
-downloadWith o addunlockedmatcher downloader dummykey u url file =
+downloadWith :: CanAddFile -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key)
+downloadWith canadd addunlockedmatcher downloader dummykey u url file =
go =<< downloadWith' downloader dummykey u url afile
where
afile = AssociatedFile (Just (toRawFilePath file))
go Nothing = return Nothing
- go (Just tmp) = Just <$> finishDownloadWith o addunlockedmatcher tmp u url file
+ go (Just tmp) = Just <$> finishDownloadWith canadd addunlockedmatcher tmp u url file
{- Like downloadWith, but leaves the dummy key content in
- the returned location. -}
then return (Just tmp)
else return Nothing
-finishDownloadWith :: DownloadOptions -> AddUnlockedMatcher -> FilePath -> UUID -> URLString -> FilePath -> Annex Key
-finishDownloadWith o addunlockedmatcher tmp u url file = do
+finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> FilePath -> UUID -> URLString -> FilePath -> Annex Key
+finishDownloadWith canadd addunlockedmatcher tmp u url file = do
backend <- chooseBackend file
let source = KeySource
{ keyFilename = toRawFilePath file
, inodeCache = Nothing
}
key <- fst <$> genKey source nullMeterUpdate backend
- addWorkTree o addunlockedmatcher u url file key (Just tmp)
+ addWorkTree canadd addunlockedmatcher u url file key (Just tmp)
return key
{- Adds the url size to the Key. -}
}
{- Adds worktree file to the repository. -}
-addWorkTree :: DownloadOptions -> AddUnlockedMatcher -> UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex ()
-addWorkTree o addunlockedmatcher u url file key mtmp = case mtmp of
+addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex ()
+addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of
Nothing -> go
Just tmp -> do
-- Move to final location for large file check.
-- than the work tree file.
liftIO $ renameFile file tmp
go
- else void $ Command.Add.addSmall
- (checkGitIgnoreOption o)
- (toRawFilePath file)
+ else void $ Command.Add.addSmall noci (toRawFilePath file)
where
go = do
maybeShowJSON $ JSONChunk [("key", serializeKey key)]
setUrlPresent key url
logChange key u InfoPresent
- ifM (addAnnexedFile (checkGitIgnoreOption o) addunlockedmatcher file key mtmp)
+ ifM (addAnnexedFile noci addunlockedmatcher file key mtmp)
( do
when (isJust mtmp) $
logStatus key InfoPresent
, maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . nukeFile)) mtmp
)
+
+ -- git does not need to check ignores, because that has already
+ -- been done, as witnessed by the CannAddFile.
+ noci = CheckGitIgnore False
nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)
nodownloadWeb addunlockedmatcher o url urlinfo file
| otherwise = takeFileName mediafile
nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key)
-nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ do
+nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do
showDestinationFile file
createWorkTreeDirectory (parentDir file)
- addWorkTree o addunlockedmatcher webUUID url file key Nothing
+ addWorkTree canadd addunlockedmatcher webUUID url file key Nothing
return (Just key)
url2file :: URI -> Maybe Int -> Int -> FilePath
addprefix f = maybe f (++ f) (prefixOption o)
addsuffix f = maybe f (f ++) (suffixOption o)
-checkCanAdd :: DownloadOptions -> FilePath -> Annex (Maybe a) -> Annex (Maybe a)
+data CanAddFile = CanAddFile
+
+checkCanAdd :: DownloadOptions -> FilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a)
checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file))
( do
warning $ file ++ " already exists; not overwriting"
( do
warning $ "not adding " ++ file ++ " which is .gitignored (use --no-check-gitignore to override)"
return Nothing
- , a
+ , a CanAddFile
)
)
import qualified Utility.Format
import Utility.Tmp
import Utility.Metered
-import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..))
+import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..), checkCanAdd)
import Annex.UUID
import Backend.URL (fromUrl)
import Annex.Content
-- don't use youtube-dl
, rawOption = True
}
- let go urlinfo = maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f
+ let go urlinfo = Just . maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f
if relaxedOption (downloadOptions opts)
then go Url.assumeUrlExists
else Url.withUrlOptions (Url.getUrlInfo url) >>= \case
Right urlinfo -> go urlinfo
Left err -> do
warning err
- return []
+ return (Just [])
else do
res <- tryNonAsync $ maybe
(error $ "unable to checkUrl of " ++ Remote.name r)
(flip id url)
(Remote.checkUrl r)
case res of
- Left _ -> return []
+ Left _ -> return (Just [])
Right (UrlContents sz _) ->
- maybeToList <$>
+ Just . maybeToList <$>
downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz
Right (UrlMulti l) -> do
kl <- forM l $ \(url', sz, subf) ->
downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' (f </> sanitizeFilePath subf) sz
- return $ if all isJust kl
+ return $ Just $ if all isJust kl
then catMaybes kl
else []
Nothing -> return True
Just f -> do
showStartOther "addurl" (Just url) (SeekInput [])
- ks <- getter f
- if null ks
- then do
+ getter f >>= \case
+ Just ks
+ -- Download problem.
+ | null ks -> do
+ showEndFail
+ checkFeedBroken (feedurl todownload)
+ | otherwise -> do
+ forM_ ks $ \key ->
+ ifM (annexGenMetaData <$> Annex.getGitConfig)
+ ( addMetaData key $ extractMetaData todownload
+ , addMetaData key $ minimalMetaData todownload
+ )
+ showEndOk
+ return True
+ -- Was not able to add anything,
+ -- but not because of a download
+ -- problem.
+ Nothing -> do
showEndFail
- checkFeedBroken (feedurl todownload)
- else do
- forM_ ks $ \key ->
- ifM (annexGenMetaData <$> Annex.getGitConfig)
- ( addMetaData key $ extractMetaData todownload
- , addMetaData key $ minimalMetaData todownload
- )
- showEndOk
- return True
+ return False
{- Find a unique filename to save the url to.
- If the file exists, prefixes it with a number.
let ext = case takeExtension mediafile of
[] -> ".m"
s -> s
- ok <- rundownload linkurl ext $ \f -> do
- addWorkTree (downloadOptions opts) addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile)
- return [mediakey]
+ ok <- rundownload linkurl ext $ \f ->
+ checkCanAdd (downloadOptions opts) f $ \canadd -> do
+ addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile)
+ return (Just [mediakey])
return (Just ok)
-- youtude-dl didn't support it, so
-- download it as if the link were
addmediafast linkurl mediaurl mediakey =
ifM (pure (not (rawOption (downloadOptions opts)))
<&&> youtubeDlSupported linkurl)
- ( rundownload linkurl ".m" $ \f -> do
- addWorkTree (downloadOptions opts) addunlockedmatcher webUUID mediaurl f mediakey Nothing
- return [mediakey]
+ ( rundownload linkurl ".m" $ \f ->
+ checkCanAdd (downloadOptions opts) f $ \canadd -> do
+ addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey Nothing
+ return (Just [mediakey])
, performDownload addunlockedmatcher opts cache todownload
{ location = Enclosure linkurl }
)
projects / git-annex.git / commitdiff