cbaebf538a
Now gitattributes are looked up, efficiently, in only the places that
really need them, using the same approach used for cat-file.
The old CheckAttr code seemed very fragile, in the way it streamed files
through git check-attr.
I actually found that cad8824852
was still deadlocking with ghc 7.4, at the end of adding a lot of files.
This should fix that problem, and avoid future ones.
The best part is that this removes withAttrFilesInGit and withNumCopies,
which were complicated Seek methods, as well as simplfying the types
for several other Seek methods that had a Backend tupled in.
88 lines
2.5 KiB
Haskell
88 lines
2.5 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.AddUrl where
|
|
|
|
import Network.URI
|
|
|
|
import Common.Annex
|
|
import Command
|
|
import qualified Backend
|
|
import qualified Command.Add
|
|
import qualified Annex
|
|
import qualified Backend.URL
|
|
import qualified Utility.Url as Url
|
|
import Annex.Content
|
|
import Logs.Web
|
|
import qualified Option
|
|
import Types.Key
|
|
|
|
def :: [Command]
|
|
def = [withOptions [fileOption] $
|
|
command "addurl" (paramRepeating paramUrl) seek "add urls to annex"]
|
|
|
|
fileOption :: Option
|
|
fileOption = Option.field [] "file" paramFile "specify what file the url is added to"
|
|
|
|
seek :: [CommandSeek]
|
|
seek = [withField fileOption return $ \f ->
|
|
withStrings $ start f]
|
|
|
|
start :: Maybe FilePath -> String -> CommandStart
|
|
start optfile s = notBareRepo $ go $ fromMaybe bad $ parseURI s
|
|
where
|
|
bad = fromMaybe (error $ "bad url " ++ s) $
|
|
parseURI $ escapeURIString isUnescapedInURI s
|
|
go url = do
|
|
let file = fromMaybe (url2file url) optfile
|
|
showStart "addurl" file
|
|
next $ perform s file
|
|
|
|
perform :: String -> FilePath -> CommandPerform
|
|
perform url file = ifAnnexed file addurl geturl
|
|
where
|
|
geturl = do
|
|
whenM (liftIO $ doesFileExist file) $
|
|
error $ "not overwriting existing " ++ file
|
|
fast <- Annex.getState Annex.fast
|
|
if fast then nodownload url file else download url file
|
|
addurl (key, _backend) = do
|
|
unlessM (liftIO $ Url.check url (keySize key)) $
|
|
error $ "failed to verify url: " ++ url
|
|
setUrlPresent key url
|
|
next $ return True
|
|
|
|
download :: String -> FilePath -> CommandPerform
|
|
download url file = do
|
|
showAction $ "downloading " ++ url ++ " "
|
|
let dummykey = Backend.URL.fromUrl url Nothing
|
|
tmp <- fromRepo $ gitAnnexTmpLocation dummykey
|
|
liftIO $ createDirectoryIfMissing True (parentDir tmp)
|
|
stopUnless (downloadUrl [url] tmp) $ do
|
|
backend <- Backend.chooseBackend file
|
|
k <- Backend.genKey tmp backend
|
|
case k of
|
|
Nothing -> stop
|
|
Just (key, _) -> do
|
|
moveAnnex key tmp
|
|
setUrlPresent key url
|
|
next $ Command.Add.cleanup file key True
|
|
|
|
nodownload :: String -> FilePath -> CommandPerform
|
|
nodownload url file = do
|
|
(exists, size) <- liftIO $ Url.exists url
|
|
unless exists $
|
|
error $ "unable to access url: " ++ url
|
|
let key = Backend.URL.fromUrl url size
|
|
setUrlPresent key url
|
|
next $ Command.Add.cleanup file key False
|
|
|
|
url2file :: URI -> FilePath
|
|
url2file url = escape $ uriRegName auth ++ uriPath url ++ uriQuery url
|
|
where
|
|
escape = replace "/" "_" . replace "?" "_"
|
|
auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
|