cd544e548b
giveup changed to filter out control characters. (It is too low level to make it use StringContainingQuotedPath.) error still does not, but it should only be used for internal errors, where the message is not attacker-controlled. Changed a lot of existing error to giveup when it is not strictly an internal error. Of course, other exceptions can still be thrown, either by code in git-annex, or a library, that include some attacker-controlled value. This does not guard against those. Sponsored-by: Noam Kremen on Patreon
101 lines
3 KiB
Haskell
101 lines
3 KiB
Haskell
{- git check-attr interface
|
|
-
|
|
- Copyright 2010-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Git.CheckAttr where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Command
|
|
import qualified Utility.CoProcess as CoProcess
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
import System.IO.Error
|
|
import qualified Data.ByteString as B
|
|
|
|
type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], RawFilePath)
|
|
|
|
type Attr = String
|
|
|
|
{- Starts git check-attr running to look up the specified attributes
|
|
- and returns a handle. -}
|
|
checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
|
|
checkAttrStart attrs repo = do
|
|
currdir <- R.getCurrentDirectory
|
|
h <- gitCoProcessStart True params repo
|
|
return (h, attrs, currdir)
|
|
where
|
|
params =
|
|
[ Param "check-attr"
|
|
, Param "-z"
|
|
, Param "--stdin"
|
|
] ++ map Param attrs ++
|
|
[ Param "--" ]
|
|
|
|
checkAttrStop :: CheckAttrHandle -> IO ()
|
|
checkAttrStop (h, _, _) = CoProcess.stop h
|
|
|
|
checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String
|
|
checkAttr h want file = checkAttrs h [want] file >>= return . \case
|
|
(v:_) -> v
|
|
[] -> ""
|
|
|
|
{- Gets attributes of a file. When an attribute is not specified,
|
|
- returns "" for it. -}
|
|
checkAttrs :: CheckAttrHandle -> [Attr] -> RawFilePath -> IO [String]
|
|
checkAttrs (h, attrs, currdir) want file = do
|
|
l <- CoProcess.query h send (receive "")
|
|
return (getvals l want)
|
|
where
|
|
getvals _ [] = []
|
|
getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of
|
|
["unspecified"] -> "" : getvals l xs
|
|
[v] -> v : getvals l xs
|
|
_ -> giveup $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file
|
|
|
|
send to = B.hPutStr to $ file' `B.snoc` 0
|
|
receive c from = do
|
|
s <- hGetSomeString from 1024
|
|
if null s
|
|
then eofError
|
|
else do
|
|
let v = c ++ s
|
|
maybe (receive v from) return (parse v)
|
|
eofError = ioError $ mkIOError userErrorType "git check-attr EOF" Nothing Nothing
|
|
parse s
|
|
-- new null separated output
|
|
| '\0' `elem` s = if "\0" `isSuffixOf` s
|
|
then
|
|
let bits = segment (== '\0') s
|
|
in if length bits == (numattrs * 3) + 1
|
|
then Just $ getattrvalues bits []
|
|
else Nothing -- more attributes to come
|
|
else Nothing -- output incomplete
|
|
-- old one line per value output
|
|
| otherwise = if "\n" `isSuffixOf` s
|
|
then
|
|
let ls = lines s
|
|
in if length ls == numattrs
|
|
then Just $ map (\(attr, val) -> (attr, oldattrvalue attr val))
|
|
(zip attrs ls)
|
|
else Nothing -- more attributes to come
|
|
else Nothing -- line incomplete
|
|
numattrs = length attrs
|
|
|
|
{- git check-attr chokes on some absolute filenames,
|
|
- so make sure the filename is relative. -}
|
|
file' = relPathDirToFileAbs currdir $ absPathFrom currdir file
|
|
oldattrvalue attr l = end bits !! 0
|
|
where
|
|
bits = split sep l
|
|
sep = ": " ++ attr ++ ": "
|
|
getattrvalues (_filename:attr:val:rest) c = getattrvalues rest ((attr,val):c)
|
|
getattrvalues _ c = c
|
|
|
|
{- User may enter this to override a previous attr setting, when they wish
|
|
- to not specify an attr for some files. -}
|
|
unspecifiedAttr :: String
|
|
unspecifiedAttr = "!"
|