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