1{- git check-attr interface 2 - 3 - Copyright 2010-2021 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8module Git.CheckAttr where 9 10import Common 11import Git 12import Git.Command 13import qualified Utility.CoProcess as CoProcess 14import qualified Utility.RawFilePath as R 15 16import System.IO.Error 17import qualified Data.ByteString as B 18 19type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], RawFilePath) 20 21type Attr = String 22 23{- Starts git check-attr running to look up the specified attributes 24 - and returns a handle. -} 25checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle 26checkAttrStart attrs repo = do 27 currdir <- R.getCurrentDirectory 28 h <- gitCoProcessStart True params repo 29 return (h, attrs, currdir) 30 where 31 params = 32 [ Param "check-attr" 33 , Param "-z" 34 , Param "--stdin" 35 ] ++ map Param attrs ++ 36 [ Param "--" ] 37 38checkAttrStop :: CheckAttrHandle -> IO () 39checkAttrStop (h, _, _) = CoProcess.stop h 40 41checkAttr :: CheckAttrHandle -> Attr -> RawFilePath -> IO String 42checkAttr h want file = checkAttrs h [want] file >>= return . \case 43 (v:_) -> v 44 [] -> "" 45 46{- Gets attributes of a file. When an attribute is not specified, 47 - returns "" for it. -} 48checkAttrs :: CheckAttrHandle -> [Attr] -> RawFilePath -> IO [String] 49checkAttrs (h, attrs, currdir) want file = do 50 l <- CoProcess.query h send (receive "") 51 return (getvals l want) 52 where 53 getvals _ [] = [] 54 getvals l (x:xs) = case map snd $ filter (\(attr, _) -> attr == x) l of 55 ["unspecified"] -> "" : getvals l xs 56 [v] -> v : getvals l xs 57 _ -> error $ "unable to determine " ++ x ++ " attribute of " ++ fromRawFilePath file 58 59 send to = B.hPutStr to $ file' `B.snoc` 0 60 receive c from = do 61 s <- hGetSomeString from 1024 62 if null s 63 then eofError 64 else do 65 let v = c ++ s 66 maybe (receive v from) return (parse v) 67 eofError = ioError $ mkIOError userErrorType "git check-attr EOF" Nothing Nothing 68 parse s 69 -- new null separated output 70 | '\0' `elem` s = if "\0" `isSuffixOf` s 71 then 72 let bits = segment (== '\0') s 73 in if length bits == (numattrs * 3) + 1 74 then Just $ getattrvalues bits [] 75 else Nothing -- more attributes to come 76 else Nothing -- output incomplete 77 -- old one line per value output 78 | otherwise = if "\n" `isSuffixOf` s 79 then 80 let ls = lines s 81 in if length ls == numattrs 82 then Just $ map (\(attr, val) -> (attr, oldattrvalue attr val)) 83 (zip attrs ls) 84 else Nothing -- more attributes to come 85 else Nothing -- line incomplete 86 numattrs = length attrs 87 88 {- git check-attr chokes on some absolute filenames, 89 - so make sure the filename is relative. -} 90 file' = relPathDirToFileAbs currdir $ absPathFrom currdir file 91 oldattrvalue attr l = end bits !! 0 92 where 93 bits = split sep l 94 sep = ": " ++ attr ++ ": " 95 getattrvalues (_filename:attr:val:rest) c = getattrvalues rest ((attr,val):c) 96 getattrvalues _ c = c 97 98{- User may enter this to override a previous attr setting, when they wish 99 - to not specify an attr for some files. -} 100unspecifiedAttr :: String 101unspecifiedAttr = "!" 102