blob: 87b24149d8fe338457cf621ae3bab6d5176c3947 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
{- 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 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
import Config
def :: [Command]
def = [withOptions [fileOption, pathdepthOption] $
command "addurl" (paramRepeating paramUrl) seek "add urls to annex"]
fileOption :: Option
fileOption = Option.field [] "file" paramFile "specify what file the url is added to"
pathdepthOption :: Option
pathdepthOption = Option.field [] "pathdepth" paramNumber "path components to use in filename"
seek :: [CommandSeek]
seek = [withField fileOption return $ \f ->
withField pathdepthOption (return . maybe Nothing readish) $ \d ->
withStrings $ start f d]
start :: Maybe FilePath -> Maybe Int -> String -> CommandStart
start optfile pathdepth 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 pathdepth) optfile
showStart "addurl" file
next $ perform s file
perform :: String -> FilePath -> CommandPerform
perform url file = ifAnnexed file addurl geturl
where
geturl = do
liftIO $ createDirectoryIfMissing True (parentDir file)
ifM (Annex.getState Annex.fast)
( nodownload url file , download url file )
addurl (key, _backend) = do
headers <- getHttpHeaders
ifM (liftIO $ Url.check url headers $ keySize key)
( do
setUrlPresent key url
next $ return True
, do
warning $ "failed to verify url: " ++ url
stop
)
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 <- chooseBackend file
let source = KeySource { keyFilename = file, contentLocation = file}
k <- genKey source 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
headers <- getHttpHeaders
(exists, size) <- liftIO $ Url.exists url headers
if exists
then do
let key = Backend.URL.fromUrl url size
setUrlPresent key url
next $ Command.Add.cleanup file key False
else do
warning $ "unable to access url: " ++ url
stop
url2file :: URI -> Maybe Int -> FilePath
url2file url pathdepth = case pathdepth of
Nothing -> filesize $ escape fullurl
Just depth
| depth > 0 -> frombits $ drop depth
| depth < 0 -> frombits $ reverse . take (negate depth) . reverse
| otherwise -> error "bad --pathdepth"
where
fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
frombits a = join "/" $ a urlbits
urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl
auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
filesize = take 255
escape = replace "/" "_" . replace "?" "_"
|
