-- (for an unknown reason).
-- http://thread.gmane.org/gmane.comp.version-control.git/297237
inRepo $ Git.Command.run [Param "reset", Param "HEAD", Param "--quiet"]
- showAction $ "Merging into " ++ fromRef (Git.Ref.base origbranch)
+ showAction $ UnquotedString $ "Merging into " ++ fromRef (Git.Ref.base origbranch)
merged <- autoMergeFrom' tomerge Nothing mergeconfig commitmode True
(const $ resolveMerge (Just updatedorig) tomerge True)
if merged
" into " ++ fromRef name
localtransitions <- getLocalTransitions
unless (null tomerge) $ do
- showSideAction merge_desc
+ showSideAction (UnquotedString merge_desc)
mapM_ checkBranchDifferences refs
mergeIndex jl refs
let commitrefs = nub $ fullname:refs
Right () -> return ()
Left e -> do
showLongNote $ "Detected a filesystem where Sqlite does not work."
- showLongNote $ "(" ++ show e ++ ")"
- showLongNote $ "To work around this problem, you can set annex.dbdir " ++
+ showLongNote $ UnquotedString $ "(" ++ show e ++ ")"
+ showLongNote $ "To work around this problem, you can set annex.dbdir " <>
"to a directory on another filesystem."
showLongNote $ "For example: git config annex.dbdir $HOME/cache/git-annex"
giveup "Not initialized."
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings #-}
module Annex.NumCopies (
module Types.NumCopies,
notEnoughCopies key neednum needmin have skip bad nolocmsg lockunsupported = do
showNote "unsafe"
if length have < fromNumCopies neednum
- then showLongNote $
+ then showLongNote $ UnquotedString $
"Could only verify the existence of " ++
show (length have) ++ " out of " ++ show (fromNumCopies neednum) ++
" necessary " ++ pluralcopies (fromNumCopies neednum)
else do
- showLongNote $ "Unable to lock down " ++ show (fromMinCopies needmin) ++
+ showLongNote $ UnquotedString $ "Unable to lock down " ++ show (fromMinCopies needmin) ++
" " ++ pluralcopies (fromMinCopies needmin) ++
" of file necessary to safely drop it."
if null lockunsupported
then showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)"
- else showLongNote $ "These remotes do not support locking: "
+ else showLongNote $ UnquotedString $ "These remotes do not support locking: "
++ Remote.listRemoteNames lockunsupported
Remote.showTriedRemotes bad
Nothing -> cu
case (lookupName c, findType c) of
(Just name, Right t) -> do
- showSideAction $ "Auto enabling special remote " ++ name
+ showSideAction $ UnquotedString $ "Auto enabling special remote " ++ name
dummycfg <- liftIO dummyRemoteGitConfig
tryNonAsync (setup t (AutoEnable c) (Just u) Nothing c dummycfg) >>= \case
Left e -> warning (UnquotedString (show e))
if numretries < maxretries
then do
let retrydelay = Seconds (initretrydelay * 2^(numretries-1))
- showSideAction $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying."
+ showSideAction $ UnquotedString $ "Delaying " ++ show (fromSeconds retrydelay) ++ "s before retrying."
liftIO $ threadDelaySeconds retrydelay
return True
else return False
liftIO $ catchDefaultIO (Just False) $
finalizeIncrementalVerifier iv
| otherwise = do
- showAction (descIncrementalVerifier iv)
+ showAction (UnquotedString (descIncrementalVerifier iv))
liftIO $ catchDefaultIO (Just False) $
withBinaryFile (fromRawFilePath f) ReadMode $ \h -> do
hSeek h AbsoluteSeek endpos
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE DeriveDataTypeable, CPP #-}
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, CPP #-}
module Assistant.Threads.Watcher (
watchThread,
exists <- liftIO $ R.doesPathExist file
case (exists, fast) of
(True, False) -> do
- showAction descChecksum
+ showAction (UnquotedString descChecksum)
sameCheckSum key
<$> hashFile hash file nullMeterUpdate
_ -> return True
let file' = joinPath $ map (truncateFilePath pathmax) $
splitDirectories file
startingAddUrl si uri o $ do
- showNote $ "from " ++ Remote.name r
- showDestinationFile file'
+ showNote $ UnquotedString $ "from " ++ Remote.name r
+ showDestinationFile (toRawFilePath file')
performRemote addunlockedmatcher r o uri (toRawFilePath file') sz
performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform
addUrlChecked o url file u checkexistssize key =
ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key))
( do
- showDestinationFile (fromRawFilePath file)
+ showDestinationFile file
next $ return True
, checkexistssize key >>= \case
Just (exists, samesize, url')
, normalfinish tmp backend
)
normalfinish tmp backend = checkCanAdd o file $ \canadd -> do
- showDestinationFile (fromRawFilePath file)
+ showDestinationFile file
createWorkTreeDirectory (parentDir file)
Just <$> finishDownloadWith canadd addunlockedmatcher tmp backend webUUID url file
-- Ask youtube-dl what filename it will download first,
Right (Just mediafile) -> do
cleanuptmp
checkCanAdd o dest $ \canadd -> do
- showDestinationFile (fromRawFilePath dest)
+ showDestinationFile dest
addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile))
return $ Just mediakey
Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp backend)
ai = OnlyActionOn urlkey (ActionItemOther (Just (UnquotedString url)))
urlkey = Backend.URL.fromUrl url Nothing
-showDestinationFile :: FilePath -> Annex ()
+showDestinationFile :: RawFilePath -> Annex ()
showDestinationFile file = do
- showNote ("to " ++ file)
- maybeShowJSON $ JSONChunk [("file", file)]
+ showNote ("to " <> QuotedPath file)
+ maybeShowJSON $ JSONChunk [("file", fromRawFilePath file)]
{- The Key should be a dummy key, based on the URL, which is used
- for this download, before we can examine the file and find its real key.
nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> RawFilePath -> Annex (Maybe Key)
nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do
- showDestinationFile (fromRawFilePath file)
+ showDestinationFile file
createWorkTreeDirectory (parentDir file)
addWorkTree canadd addunlockedmatcher webUUID url file key Nothing
return (Just key)
if afile == afile'
then showLongNote "That file is required content. It cannot be dropped!"
else showLongNote $ "That file has the same content as another file"
- ++ case afile' of
- AssociatedFile (Just f) -> " (" ++ fromRawFilePath f ++ "),"
+ <> case afile' of
+ AssociatedFile (Just f) -> " (" <> QuotedPath f <> "),"
AssociatedFile Nothing -> ""
- ++ " which is required content. It cannot be dropped!"
+ <> " which is required content. It cannot be dropped!"
showLongNote "(Use --force to override this check, or adjust required content configuration.)"
return False
perform :: Maybe Remote -> NumCopies -> MinCopies -> Key -> CommandPerform
perform from numcopies mincopies key = case from of
Just r -> do
- showAction $ "from " ++ Remote.name r
+ showAction $ UnquotedString $ "from " ++ Remote.name r
Command.Drop.performRemote pcc key (AssociatedFile Nothing) numcopies mincopies r ud
Nothing -> ifM (inAnnex key)
( droplocal
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings, CPP #-}
module Command.EnableTor where
let ps = [Param (cmdname cmd), Param (show curruserid)]
sucommand <- liftIO $ mkSuCommand gitannex ps
cleanenv <- liftIO $ cleanStandaloneEnvironment
- maybe noop showLongNote
+ maybe noop (showLongNote . UnquotedString)
(describePasswordPrompt' sucommand)
ifM (liftIO $ runSuCommand sucommand cleanenv)
( next checkHiddenService
case lastact of
Just ent | notexpired ent -> checktrust (== DeadTrusted) $
starting "unexpire" ai si $ do
- showNote =<< whenactive
+ showNote . UnquotedString =<< whenactive
unless noact $
trustSet u SemiTrusted
next $ return True
_ -> checktrust (/= DeadTrusted) $
starting "expire" ai si $ do
- showNote =<< whenactive
+ showNote . UnquotedString =<< whenactive
unless noact $
trustSet u DeadTrusted
next $ return True
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Command.Forget where
import Command
dispatch =<< Remote.hasKey remote key
where
dispatch (Left err) = do
- showNote err
+ showNote (UnquotedString err)
return False
dispatch (Right True) = withtmp $ \tmpfile ->
getfile tmpfile >>= \case
Nothing -> go True Nothing
Just (Right verification) -> go True (Just (tmpfile, verification))
Just (Left _) -> do
- qp <- coreQuotePath <$> Annex.getGitConfig
- warning $ UnquotedString (decodeBS (actionItemDesc qp ai)) <> ": failed to download file from remote"
+ warning $ actionItemDesc ai
+ <> ": failed to download file from remote"
void $ go True Nothing
return False
dispatch (Right False) = go False Nothing
return True
(False, True) -> do
fix InfoMissing
- qp <- coreQuotePath <$> Annex.getGitConfig
warning $
"** Based on the location log, " <>
- QuotedPath (actionItemDesc qp ai) <>
+ actionItemDesc ai <>
"\n** was expected to be present, " <>
"but its content is missing."
return False
if null missinglocs
then return True
else do
- qp <- coreQuotePath <$> Annex.getGitConfig
missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs
warning $
"** Required content " <>
- QuotedPath (actionItemDesc qp ai) <>
+ actionItemDesc ai <>
" is missing from these repositories:\n" <>
UnquotedString missingrequired
return False
return same
badsize a b = do
msg <- bad key
- qp <- coreQuotePath <$> Annex.getGitConfig
- warning $
- QuotedPath (actionItemDesc qp ai)
+ warning $ actionItemDesc ai
<> ": Bad file size ("
<> UnquotedString (compareSizes storageUnits True a b)
<> "); "
checkKeyUpgrade backend key ai (AssociatedFile (Just file)) =
case Types.Backend.canUpgradeKey backend of
Just a | a key -> do
- qp <- coreQuotePath <$> Annex.getGitConfig
- warning $
- QuotedPath (actionItemDesc qp ai)
+ warning $ actionItemDesc ai
<> ": Can be upgraded to an improved key format. "
<> "You can do so by running: git annex migrate --backend="
- <> UnquotedString (decodeBS (formatKeyVariety (fromKey keyVariety key)))
+ <> UnquotedByteString (formatKeyVariety (fromKey keyVariety key))
<> " "
<> QuotedPath file
return True
ok <- verifier key file
unless ok $ do
msg <- bad key
- qp <- coreQuotePath <$> Annex.getGitConfig
- warning $
- QuotedPath (actionItemDesc qp ai)
+ warning $ actionItemDesc ai
<> ": Bad file content; "
<> UnquotedString msg
return ok
withTSDelta (liftIO . genInodeCache content) >>= \case
Nothing -> noop
Just ic' -> whenM (compareInodeCaches ic ic') $ do
- qp <- coreQuotePath <$> Annex.getGitConfig
- warning $
- QuotedPath (actionItemDesc qp ai)
+ warning $ actionItemDesc ai
<> ": Stale or missing inode cache; updating."
Database.Keys.addInodeCaches key [ic]
getKey' key afile = dispatch
where
dispatch [] = do
- showNote "not available"
+ showNote (UnquotedString "not available")
showlocs []
return False
dispatch remotes = notifyTransfer Download afile $ \witness -> do
either (const False) id <$> Remote.hasKey r key
| otherwise = return True
docopy r witness = do
- showAction $ "from " ++ Remote.name r
+ showAction $ UnquotedString $ "from " ++ Remote.name r
logStatusAfter key $
download r key afile stdRetry witness
si = SeekInput []
deletedup k = do
- showNote $ "duplicate of " ++ serializeKey k
+ showNote $ UnquotedString $ "duplicate of " ++ serializeKey k
verifyExisting k destfile
( do
liftIO $ R.removeLink srcfile
(reinject k)
(importfile ld k)
_ -> importfile ld k
- skipbecause s = showNote (s ++ "; skipping") >> next (return True)
+ skipbecause s = do
+ showNote (s <> "; skipping")
+ next (return True)
verifyExisting :: Key -> RawFilePath -> (CommandPerform, CommandPerform) -> CommandPerform
verifyExisting key destfile (yes, no) = do
import Text.Feed.Types
import qualified Data.Set as S
import qualified Data.Map as M
-import Data.Char
import Data.Time.Clock
import Data.Time.Format
import Data.Time.Calendar
go tmpf = liftIO (parseFeedFromFile' tmpf) >>= \case
Nothing -> debugfeedcontent tmpf "parsing the feed failed"
Just f -> do
- case map sanitizetitle $ decodeBS $ fromFeedText $ getFeedTitle f of
+ case decodeBS $ fromFeedText $ getFeedTitle f of
"" -> noop
- t -> showNote ('"' : t ++ "\"")
+ t -> showNote (UnquotedString ('"' : t ++ "\""))
case findDownloads url f of
[] -> debugfeedcontent tmpf "bad feed content; no enclosures to download"
l -> do
, void $ feedProblem url
"problem downloading some item(s) from feed"
)
- sanitizetitle c
- | isControl c = '_'
- | otherwise = c
debugfeedcontent tmpf msg = do
feedcontent <- liftIO $ readFile tmpf
fastDebug "Command.ImportFeed" $ unlines
noInfo :: String -> SeekInput -> String -> Annex ()
noInfo s si msg = do
showStartMessage (StartMessage "info" (ActionItemOther (Just (UnquotedString s))) si)
- showNote msg
+ showNote (UnquotedString msg)
showEndFail
Annex.incError
desc = "transfers in progress"
line qp uuidmap t i = unwords
[ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing"
- , fromRawFilePath $ actionItemDesc qp $ mkActionItem
+ , fromRawFilePath $ quote qp $ actionItemDesc $ mkActionItem
(transferKey t, associatedFile i)
, if transferDirection t == Upload then "to" else "from"
, maybe (fromUUID $ transferUUID t) Remote.name $
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Command.Map where
import qualified Data.Map as M
runViewer :: FilePath -> [(String, [CommandParam])] -> Annex Bool
runViewer file [] = do
- showLongNote $ "left map in " ++ file
+ showLongNote $ UnquotedString $ "left map in " ++ file
return True
runViewer file ((c, ps):rest) = ifM (liftIO $ inSearchPath c)
( do
- showLongNote $ "running: " ++ c ++ unwords (toCommand ps)
+ showLongNote $ UnquotedString $ "running: " ++ c ++ unwords (toCommand ps)
showOutput
liftIO $ boolSystem c ps
, runViewer file rest
case toJSON' (AddJSONActionItemFields m) of
Object o -> maybeShowJSON $ AesonObject o
_ -> noop
- showLongNote $ unlines $ concatMap showmeta $
+ showLongNote $ UnquotedString $ unlines $ concatMap showmeta $
map unwrapmeta (fromMetaData m)
return True
where
srcuuid <- getUUID
case isthere of
Left err -> do
- showNote err
+ showNote (UnquotedString err)
stop
Right False -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> do
- showAction $ "to " ++ Remote.name dest
+ showAction $ UnquotedString $ "to " ++ Remote.name dest
ok <- notifyTransfer Upload afile $
upload dest key afile stdRetry
if ok
fromPerform' :: Bool -> Bool -> Remote -> Key -> AssociatedFile -> Annex (RemoveWhen -> CommandPerform)
fromPerform' present updatelocationlog src key afile = do
- showAction $ "from " ++ Remote.name src
+ showAction $ UnquotedString $ "from " ++ Remote.name src
destuuid <- getUUID
logMove (Remote.uuid src) destuuid present key $ \deststartedwithcopy ->
if present
faileddropremote = do
showLongNote "(Use --force to override this check, or adjust numcopies.)"
- showLongNote $ "Content not dropped from " ++ Remote.name src ++ "."
+ showLongNote $ UnquotedString $ "Content not dropped from " ++ Remote.name src ++ "."
logMoveCleanup deststartedwithcopy
next $ return False
haskey <- Remote.hasKey dest key
case haskey of
Left err -> do
- showNote err
+ showNote (UnquotedString err)
stop
Right True -> do
- showAction $ "from " ++ Remote.name src
- showAction $ "to " ++ Remote.name dest
+ showAction $ UnquotedString $
+ "from " ++ Remote.name src
+ showAction $ UnquotedString $
+ "to " ++ Remote.name dest
-- The log may not indicate dest's copy
-- yet, so make sure it does.
logChange key (Remote.uuid dest) InfoPresent
return True
showMetaDataChange :: MetaData -> Annex ()
-showMetaDataChange = showLongNote . unlines . concatMap showmeta . fromMetaData
+showMetaDataChange = showLongNote . UnquotedString . unlines . concatMap showmeta . fromMetaData
where
showmeta (f, vs) = map (showmetavalue f) $ S.toList vs
showmetavalue f v = T.unpack (fromMetaField f) <> showset v <> "=" <> decodeBS (fromMetaValue v)
_ -> Remote.claimingUrl url
case needremote of
Just nr | nr /= r -> do
- showNote $ "The url " ++ url ++ " is claimed by remote " ++ Remote.name r
+ showNote $ UnquotedString $ "The url " ++ url ++ " is claimed by remote " ++ Remote.name r
next $ return False
_ -> do
a r key (setDownloader' url r)
warncannotupdateexport r mtb exported currb = case mtb of
Nothing -> inRepo (Git.Ref.tree currb) >>= \case
Just currt | not (any (== currt) (exportedTreeishes exported)) ->
- showLongNote $ unwords
+ showLongNote $ UnquotedString $ unwords
[ notupdating
, "to reflect changes to the tree, because export"
, "tracking is not enabled. "
, "(Set " ++ gitconfig ++ " to enable it.)"
]
_ -> noop
- Just b -> showLongNote $ unwords
+ Just b -> showLongNote $ UnquotedString $ unwords
[ notupdating
, "because " ++ Git.fromRef b ++ " does not exist."
, "(As configured by " ++ gitconfig ++ ")"
check file msg a c = do
l <- a
let unusedlist = number c l
- unless (null l) $ showLongNote $ msg unusedlist
+ unless (null l) $
+ showLongNote $ UnquotedString $ msg unusedlist
updateUnusedLog (toRawFilePath file) (M.fromList unusedlist)
return $ c + length l
- differ from those referenced in the index. -}
withKeysReferencedDiffGitRef :: (Key -> Annex ()) -> Git.Ref -> Annex ()
withKeysReferencedDiffGitRef a ref = do
- showAction $ "checking " ++ Git.Ref.describe ref
+ showAction $ UnquotedString $ "checking " ++ Git.Ref.describe ref
withKeysReferencedDiff a
(inRepo $ DiffTree.diffIndex ref)
DiffTree.srcsha
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Command.VAdd where
import Command
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Command.VCycle where
import Command
forM_ l (removeemptydir top)
liftIO $ void cleanup
unlessM (liftIO $ doesDirectoryExist here) $ do
- showLongNote (cwdmissing (fromRawFilePath top))
+ showLongNote $ UnquotedString $ cwdmissing (fromRawFilePath top)
return ok
where
removeemptydir top d = do
case formatOption o of
Nothing -> do
let num = length safelocations
- showNote $ show num ++ " " ++ copiesplural num
+ showNote $ UnquotedString $ show num ++ " " ++ copiesplural num
pp <- ppwhereis "whereis" safelocations urls
- unless (null safelocations) $ showLongNote pp
+ unless (null safelocations) $
+ showLongNote (UnquotedString pp)
pp' <- ppwhereis "untrusted" untrustedlocations urls
- unless (null untrustedlocations) $ showLongNote $ untrustedheader ++ pp'
-
+ unless (null untrustedlocations) $
+ showLongNote $ UnquotedString $
+ untrustedheader ++ pp'
mapM_ (showRemoteUrls remotemap) urls
Just formatter -> liftIO $ do
let vs = Command.Find.formatVars key
showRemoteUrls remotemap (uu, us)
| null us = noop
| otherwise = case M.lookup uu remotemap of
- Just r -> showLongNote $
+ Just r -> showLongNote $ UnquotedString $
unlines $ map (\u -> name r ++ ": " ++ u) us
Nothing -> noop
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Creds (
module Types.Creds,
CredPairStorage(..),
import Common
import Git
-import qualified Git.Filename as Filename
+import Git.Filename
import qualified System.FilePath.ByteString as P
import qualified System.FilePath.Posix.ByteString
import GHC.Generics
import Control.DeepSeq
-import qualified Data.ByteString as S
{- A RawFilePath, relative to the top of the git repository. -}
newtype TopFilePath = TopFilePath { getTopFilePath :: RawFilePath }
deriving (Show, Eq, Ord)
{- Git uses the branch:file form to refer to a BranchFilePath -}
-descBranchFilePath :: Filename.QuotePath -> BranchFilePath -> S.ByteString
-descBranchFilePath qp (BranchFilePath b f) =
- fromRef' b <> ":" <> Filename.quote qp (getTopFilePath f)
+descBranchFilePath :: BranchFilePath -> StringContainingQuotedPath
+descBranchFilePath (BranchFilePath b f) =
+ UnquotedByteString (fromRef' b) <> ":" <> QuotedPath (getTopFilePath f)
{- Path to a TopFilePath, within the provided git repo. -}
fromTopFilePath :: TopFilePath -> Git.Repo -> RawFilePath
-- Eg: QuotedPath f <> ": not found"
data StringContainingQuotedPath
= UnquotedString String
+ | UnquotedByteString S.ByteString
| QuotedPath RawFilePath
| StringContainingQuotedPath :+: StringContainingQuotedPath
deriving (Show, Eq)
instance Quoteable StringContainingQuotedPath where
quote _ (UnquotedString s) = safeOutput (encodeBS s)
+ quote _ (UnquotedByteString s) = safeOutput s
quote qp (QuotedPath p) = quote qp p
quote qp (a :+: b) = quote qp a <> quote qp b
noquote (UnquotedString s) = encodeBS s
+ noquote (UnquotedByteString s) = s
noquote (QuotedPath p) = p
noquote (a :+: b) = noquote a <> noquote b
instance Sem.Semigroup StringContainingQuotedPath where
UnquotedString a <> UnquotedString b = UnquotedString (a <> b)
+ UnquotedByteString a <> UnquotedByteString b = UnquotedByteString (a <> b)
a <> b = a :+: b
instance Monoid StringContainingQuotedPath where
- mempty = UnquotedString mempty
+ mempty = UnquotedByteString mempty
-- Encoding and then decoding roundtrips only when the string does not
-- contain high unicode, because eg, both "\12345" and "\227\128\185"
describeTransfer qp t info = unwords
[ show $ transferDirection t
, show $ transferUUID t
- , decodeBS $ actionItemDesc qp $ ActionItemAssociatedFile
+ , decodeBS $ quote qp $ actionItemDesc $ ActionItemAssociatedFile
(associatedFile info)
(transferKey t)
, show $ bytesComplete info
import Messages.Concurrent
import Annex.Debug
import Annex.Concurrent.Utility
+import Utility.SafeOutput
+import Git.Filename
import qualified Messages.JSON as JSON
import qualified Annex
_ -> noop
showStartActionItem :: String -> ActionItem -> SeekInput -> Annex ()
-showStartActionItem command ai si = do
- qp <- coreQuotePath <$> Annex.getGitConfig
- outputMessage json $
- encodeBS command <> " " <> actionItemDesc qp ai <> " "
+showStartActionItem command ai si = outputMessage json id $
+ UnquotedString command <> " " <> actionItemDesc ai <> " "
where
json = JSON.start command (actionItemFile ai) (actionItemKey ai) si
showStartNothing :: String -> SeekInput -> Annex ()
-showStartNothing command si = outputMessage json $ encodeBS $
+showStartNothing command si = outputMessage json id $ UnquotedString $
command ++ " "
where
json = JSON.start command Nothing Nothing si
showEndMessage (StartNoMessage _) = const noop
showEndMessage (CustomOutput _) = const noop
-showNote :: String -> Annex ()
-showNote s = outputMessage (JSON.note s) $ encodeBS $ "(" ++ s ++ ") "
+showNote :: StringContainingQuotedPath -> Annex ()
+showNote s = outputMessage (JSON.note (decodeBS (noquote s))) id $ "(" <> s <> ") "
-showAction :: String -> Annex ()
-showAction s = showNote $ s ++ "..."
+showAction :: StringContainingQuotedPath -> Annex ()
+showAction s = showNote $ s <> "..."
-showSideAction :: String -> Annex ()
+showSideAction :: StringContainingQuotedPath -> Annex ()
showSideAction m = Annex.getState Annex.output >>= go
where
go st
Annex.changeState $ \s -> s { Annex.output = st' }
| sideActionBlock st == InBlock = return ()
| otherwise = go'
- go' = outputMessage JSON.none $ encodeBS $ "(" ++ m ++ "...)\n"
+ go' = outputMessage JSON.none id $ "(" <> m <> "...)\n"
showStoringStateAction :: Annex ()
showStoringStateAction = showSideAction "recording state in git"
{- Make way for subsequent output of a command. -}
showOutput :: Annex ()
showOutput = unlessM commandProgressDisabled $
- outputMessage JSON.none "\n"
+ outputMessage JSON.none id "\n"
-showLongNote :: String -> Annex ()
-showLongNote s = outputMessage (JSON.note s) (formatLongNote (encodeBS s))
+showLongNote :: StringContainingQuotedPath -> Annex ()
+showLongNote s = outputMessage (JSON.note (decodeBS (noquote s))) formatLongNote s
formatLongNote :: S.ByteString -> S.ByteString
formatLongNote s = "\n" <> indent s <> "\n"
-- Used by external special remote, displayed same as showLongNote
-- to console, but json object containing the info is emitted immediately.
-showInfo :: String -> Annex ()
-showInfo s = outputMessage' outputJSON (JSON.info s) $
- formatLongNote (encodeBS s)
+showInfo :: StringContainingQuotedPath -> Annex ()
+showInfo s = outputMessage' outputJSON (JSON.info (decodeBS (noquote s))) formatLongNote s
showEndOk :: Annex ()
showEndOk = showEndResult True
showEndFail = showEndResult False
showEndResult :: Bool -> Annex ()
-showEndResult ok = outputMessage (JSON.end ok) $ endResult ok <> "\n"
+showEndResult ok = outputMessage (JSON.end ok) id $
+ UnquotedByteString (endResult ok) <> "\n"
endResult :: Bool -> S.ByteString
endResult True = "ok"
warning' :: Bool -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
warning' makeway consolewhitespacef w = do
when makeway $
- outputMessage JSON.none "\n"
+ outputMessage JSON.none id "\n"
outputError consolewhitespacef (w <> "\n")
{- Not concurrent output safe. -}
warningIO w = do
putStr "\n"
hFlush stdout
- hPutStrLn stderr w
+ hPutStrLn stderr (safeOutput w)
indent :: S.ByteString -> S.ByteString
indent = S.intercalate "\n" . map (" " <>) . S8.lines
{- Performs an action that outputs nonstandard/customized output, and
- in JSON mode wraps its output in JSON.start and JSON.end, so it's
- a complete JSON document.
- - This is only needed when showStart* and showEndOk is not used.
+ - This is only needed when showStartMessage and showEndOk is not used.
-}
showCustom :: String -> SeekInput -> Annex Bool -> Annex ()
showCustom command si a = do
- outputMessage (JSON.start command Nothing Nothing si) ""
+ outputMessage (JSON.start command Nothing Nothing si) id ""
r <- a
- outputMessage (JSON.end r) ""
+ outputMessage (JSON.end r) id ""
showHeader :: S.ByteString -> Annex ()
-showHeader h = outputMessage JSON.none (h <> ": ")
+showHeader h = outputMessage JSON.none id (UnquotedByteString h <> ": ")
showRaw :: S.ByteString -> Annex ()
-showRaw s = outputMessage JSON.none (s <> "\n")
+showRaw s = outputMessage JSON.none id (UnquotedByteString s <> "\n")
setupConsole :: IO ()
setupConsole = do
-- that are displayed at the same time from mixing together.
lock <- newMVar ()
return $ \s -> withMVar lock $ \() -> do
- S.hPutStr stderr (s <> "\n")
+ S.hPutStr stderr (safeOutput s <> "\n")
hFlush stderr
{- Should commands that normally output progress messages have that
withMessageState :: (MessageState -> Annex a) -> Annex a
withMessageState a = Annex.getState Annex.output >>= a
-outputMessage :: JSONBuilder -> S.ByteString -> Annex ()
+outputMessage :: JSONBuilder -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
outputMessage = outputMessage' bufferJSON
-outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> S.ByteString -> Annex ()
-outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case outputType s of
+outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
+outputMessage' jsonoutputter jsonbuilder consolewhitespacef msg = withMessageState $ \s -> case outputType s of
NormalOutput
| concurrentOutputEnabled s -> do
+ qp <- coreQuotePath <$> Annex.getGitConfig
liftIO $ clearProgressMeter s
- concurrentMessage s False (decodeBS msg) q
+ concurrentMessage s False (decodeBS (consolewhitespacef (quote qp msg))) q
| otherwise -> do
+ qp <- coreQuotePath <$> Annex.getGitConfig
liftIO $ clearProgressMeter s
- liftIO $ flushed $ S.putStr msg
+ liftIO $ flushed $ S.putStr (consolewhitespacef (quote qp msg))
JSONOutput _ -> void $ jsonoutputter jsonbuilder s
QuietOutput -> q
SerializedOutput h _ -> do
- liftIO $ outputSerialized h $ OutputMessage msg
+ qp <- coreQuotePath <$> Annex.getGitConfig
+ liftIO $ outputSerialized h $ OutputMessage $ consolewhitespacef $ quote qp msg
void $ jsonoutputter jsonbuilder s
-- Buffer changes to JSON until end is reached and then emit it.
{- Progress dots. -}
showProgressDots :: Annex ()
-showProgressDots = outputMessage JSON.none "."
+showProgressDots = outputMessage JSON.none id "."
{- Runs a command, that may output progress to either stdout or
- stderr, as well as other messages.
runannex $ outputMessage'
(\_ _ -> return False)
id
- msg
+ id
+ (UnquotedByteString msg)
loop st
Left (OutputError msg) -> do
runannex $ outputError id $ UnquotedString msg
"Maybe add some of these git remotes (git remote add ...)"
ppuuidsskipped <- pp "skipped" uuidsskipped
"Also these untrusted repositories may contain the file"
- showLongNote $ case ppremotesmakeavailable ++ ppenablespecialremotes ++ ppaddgitremotes ++ ppuuidsskipped of
+ showLongNote $ UnquotedString $ case ppremotesmakeavailable ++ ppenablespecialremotes ++ ppaddgitremotes ++ ppuuidsskipped of
[] -> nolocmsg
s -> s
)
ignored <- filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) remotes
unless (null ignored) $
- showLongNote $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"
+ showLongNote $ UnquotedString $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")"
where
filteruuids l x = filter (`notElem` x) l
showTriedRemotes :: [Remote] -> Annex ()
showTriedRemotes [] = noop
showTriedRemotes remotes =
- showLongNote $ "Unable to access these remotes: "
+ showLongNote $ UnquotedString $ "Unable to access these remotes: "
++ listRemoteNames remotes
listRemoteNames :: [Remote] -> String
mapM_ (send . VALUE) =<< getUrlsWithPrefix key prefix
send (VALUE "") -- end of list
handleRemoteRequest (DEBUG msg) = fastDebug "Remote.External" msg
- handleRemoteRequest (INFO msg) = showInfo msg
+ handleRemoteRequest (INFO msg) = showInfo (UnquotedString msg)
handleRemoteRequest (VERSION _) = senderror "too late to send VERSION"
handleExceptionalMessage (ERROR err) = giveup $ "external special remote error: " ++ err
Left _ -> True
encsetup a = use "encryption setup" . a =<< highRandomQuality
use m a = do
- showNote m
+ showNote (UnquotedString m)
cipher <- liftIO a
- showNote (describeCipher cipher)
+ showNote (UnquotedString (describeCipher cipher))
return (storeCipher cipher c', EncryptionIsSetup)
highRandomQuality = ifM (Annex.getRead Annex.fast)
( return False
cantCheck v = giveup $ "unable to check " ++ describe v
showLocking :: Describable a => a -> Annex ()
-showLocking v = showAction $ "locking " ++ describe v
+showLocking v = showAction $ UnquotedString $ "locking " ++ describe v
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Remote.Helper.Ssh where
import Annex.Common
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, OverloadedStrings #-}
module Remote.Rsync (
remote,
case r of
Right True -> noop
_ -> do
- showAction $ "creating bucket in " ++ datacenter
+ showAction $ UnquotedString $ "creating bucket in " ++ datacenter
void $ liftIO $ runResourceT $ sendS3Handle h $
(S3.putBucket (bucket info))
{ S3.pbCannedAcl = acl info
module Types.ActionItem (
module Types.ActionItem,
- Git.Filename.StringContainingQuotedPath(..),
+ StringContainingQuotedPath(..),
) where
import Key
import Types.Transfer
import Git.FilePath
-import qualified Git.Filename
+import Git.Filename (StringContainingQuotedPath(..))
import Utility.FileSystemEncoding
-import qualified Data.ByteString as S
-
data ActionItem
= ActionItemAssociatedFile AssociatedFile Key
| ActionItemKey Key
| ActionItemBranchFilePath BranchFilePath Key
| ActionItemFailedTransfer Transfer TransferInfo
| ActionItemTreeFile RawFilePath
- | ActionItemOther (Maybe Git.Filename.StringContainingQuotedPath)
+ | ActionItemOther (Maybe StringContainingQuotedPath)
-- Use to avoid more than one thread concurrently processing the
-- same Key.
| OnlyActionOn Key ActionItem
instance MkActionItem (Transfer, TransferInfo) where
mkActionItem = uncurry ActionItemFailedTransfer
-actionItemDesc :: Git.Filename.QuotePath -> ActionItem -> S.ByteString
-actionItemDesc qp (ActionItemAssociatedFile (AssociatedFile (Just f)) _) =
- Git.Filename.quote qp f
-actionItemDesc _ (ActionItemAssociatedFile (AssociatedFile Nothing) k) =
- serializeKey' k
-actionItemDesc _ (ActionItemKey k) = serializeKey' k
-actionItemDesc qp (ActionItemBranchFilePath bfp _) = descBranchFilePath qp bfp
-actionItemDesc qp (ActionItemFailedTransfer t i) = actionItemDesc qp $
+actionItemDesc :: ActionItem -> StringContainingQuotedPath
+actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) =
+ QuotedPath f
+actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) =
+ UnquotedByteString (serializeKey' k)
+actionItemDesc (ActionItemKey k) =
+ UnquotedByteString (serializeKey' k)
+actionItemDesc (ActionItemBranchFilePath bfp _) =
+ descBranchFilePath bfp
+actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $
ActionItemAssociatedFile (associatedFile i) (transferKey t)
-actionItemDesc qp (ActionItemTreeFile f) = Git.Filename.quote qp f
-actionItemDesc _ (ActionItemOther Nothing) = mempty
-actionItemDesc qp (ActionItemOther (Just v)) = Git.Filename.quote qp v
-actionItemDesc qp (OnlyActionOn _ ai) = actionItemDesc qp ai
+actionItemDesc (ActionItemTreeFile f) = QuotedPath f
+actionItemDesc (ActionItemOther Nothing) = mempty
+actionItemDesc (ActionItemOther (Just v)) = v
+actionItemDesc (OnlyActionOn _ ai) = actionItemDesc ai
actionItemKey :: ActionItem -> Maybe Key
actionItemKey (ActionItemAssociatedFile _ k) = Just k
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Upgrade.V0 where
import Annex.Common
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Upgrade.V1 where
import System.Posix.Types
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Upgrade.V2 where
import Annex.Common
-- no origin exists, so just let the user
-- know about the new branch
void Annex.Branch.update
- showLongNote $
+ showLongNote $ UnquotedString $
"git-annex branch created\n" ++
"Be sure to push this branch when pushing to remotes.\n"
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Upgrade.V6 where
import Annex.Common
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Upgrade.V8 where
import Annex.Common
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Upgrade.V9 where
import Annex.Common
> (by default it does), so once this gets implemented, some users may want
> to set that config to false. --[[Joey]]
-> Update: Most git-annex commands now quote filenames, due to work on
-> ActionItem display. `git-annex find`, `git-annex info $file`,
-> and everywhere filenames get
-> embedded in info messages still need to be done.
+> Update: Messages now handles quoting of filenames, and also filtering
+> out any escape sequences in other things that get displayed (like Keys..)
+>
+> Still need to deal with `git-annex find` and `git-annex info $file`
+> and anything else that outputs without using Messages.
+> (Eg need to do `git-annex metadata`, `git-annex config --get` and `git-annex schedule` and `git-annex wanted`
+> and `git-annex required` and `git-annex group`)
----
and `git-annex find` that output keys might need to handle
that, when outputting to a terminal?
-Also:
-`git-annex metadata` could also contain an escape sequence. So could
-`git-annex config --get` and `git-annex schedule` and `git-annex wanted`
-and `git-annex required` and `git-annex group`. And so could the
-description of a repository. It seems that git-annex could just filter out
-control characters from all of these, since they are not filenames, and
-any control characters in them are surely malicious.
-
Also: git-annex initremote with autoenable may be able to cause a remote
with a malicious name to be set up?
projects / git-annex.git / commitdiff