72 lines
1.9 KiB
Haskell
72 lines
1.9 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 Utility.Url as Url
|
|
import qualified Command.Add
|
|
import qualified Annex
|
|
import qualified Backend.URL
|
|
import Annex.Content
|
|
import Logs.Web
|
|
|
|
def :: [Command]
|
|
def = [command "addurl" (paramRepeating paramUrl) seek "add urls to annex"]
|
|
|
|
seek :: [CommandSeek]
|
|
seek = [withStrings start]
|
|
|
|
start :: String -> CommandStart
|
|
start s = notBareRepo $ go $ parseURI s
|
|
where
|
|
go Nothing = error $ "bad url " ++ s
|
|
go (Just url) = do
|
|
file <- liftIO $ url2file url
|
|
showStart "addurl" file
|
|
next $ perform s file
|
|
|
|
perform :: String -> FilePath -> CommandPerform
|
|
perform url file = do
|
|
fast <- Annex.getState Annex.fast
|
|
if fast then nodownload url file else download url file
|
|
|
|
download :: String -> FilePath -> CommandPerform
|
|
download url file = do
|
|
showAction $ "downloading " ++ url ++ " "
|
|
let dummykey = Backend.URL.fromUrl url
|
|
tmp <- fromRepo $ gitAnnexTmpLocation dummykey
|
|
liftIO $ createDirectoryIfMissing True (parentDir tmp)
|
|
stopUnless (liftIO $ Url.download url tmp) $ do
|
|
[(backend, _)] <- Backend.chooseBackends [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
|
|
let key = Backend.URL.fromUrl url
|
|
setUrlPresent key url
|
|
next $ Command.Add.cleanup file key False
|
|
|
|
url2file :: URI -> IO FilePath
|
|
url2file url = do
|
|
whenM (doesFileExist file) $
|
|
error $ "already have this url in " ++ file
|
|
return file
|
|
where
|
|
file = escape $ uriRegName auth ++ uriPath url ++ uriQuery url
|
|
escape = replace "/" "_" . replace "?" "_"
|
|
auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
|