1{- git-annex command
2 -
3 - Copyright 2015-2018 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE BangPatterns #-}
9
10module Command.RegisterUrl where
11
12import Command
13import Logs.Web
14import Command.FromKey (keyOpt)
15import qualified Remote
16
17cmd :: Command
18cmd = command "registerurl"
19	SectionPlumbing "registers an url for a key"
20	(paramPair paramKey paramUrl)
21	(seek <$$> optParser)
22
23data RegisterUrlOptions = RegisterUrlOptions
24	{ keyUrlPairs :: CmdParams
25	, batchOption :: BatchMode
26	}
27
28optParser :: CmdParamsDesc -> Parser RegisterUrlOptions
29optParser desc = RegisterUrlOptions
30	<$> cmdParams desc
31	<*> parseBatchOption False
32
33seek :: RegisterUrlOptions -> CommandSeek
34seek o = case (batchOption o, keyUrlPairs o) of
35	(Batch (BatchFormat sep _), _) ->
36		commandAction $ startMass setUrlPresent sep
37	-- older way of enabling batch input, does not support BatchNull
38	(NoBatch, []) -> commandAction $ startMass setUrlPresent BatchLine
39	(NoBatch, ps) -> withWords (commandAction . start setUrlPresent) ps
40
41start :: (Key -> URLString -> Annex ()) -> [String] -> CommandStart
42start a (keyname:url:[]) =
43	starting "registerurl" ai si $
44		perform a (keyOpt keyname) url
45  where
46	ai = ActionItemOther (Just url)
47	si = SeekInput [keyname, url]
48start _ _ = giveup "specify a key and an url"
49
50startMass :: (Key -> URLString -> Annex ()) -> BatchSeparator -> CommandStart
51startMass a sep =
52	starting "registerurl" (ActionItemOther (Just "stdin")) (SeekInput []) $
53		performMass a sep
54
55performMass :: (Key -> URLString -> Annex ()) -> BatchSeparator -> CommandPerform
56performMass a sep = go True =<< map (separate (== ' ')) <$> batchLines fmt
57  where
58	fmt = BatchFormat sep (BatchKeys False)
59	go status [] = next $ return status
60	go status ((keyname,u):rest) | not (null keyname) && not (null u) = do
61		let key = keyOpt keyname
62		ok <- perform' a key u
63		let !status' = status && ok
64		go status' rest
65	go _ _ = giveup "Expected pairs of key and url on stdin, but got something else."
66
67perform :: (Key -> URLString -> Annex ()) -> Key -> URLString -> CommandPerform
68perform a key url = do
69	ok <- perform' a key url
70	next $ return ok
71
72perform' :: (Key -> URLString -> Annex ()) -> Key -> URLString -> Annex Bool
73perform' a key url = do
74	r <- Remote.claimingUrl url
75	a key (setDownloader' url r)
76	return True
77