1{- git-update-index library 2 - 3 - Copyright 2011-2020 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE BangPatterns, OverloadedStrings, CPP #-} 9 10module Git.UpdateIndex ( 11 Streamer, 12 pureStreamer, 13 streamUpdateIndex, 14 streamUpdateIndex', 15 withUpdateIndex, 16 lsTree, 17 lsSubTree, 18 updateIndexLine, 19 stageFile, 20 unstageFile, 21 stageSymlink, 22 stageDiffTreeItem, 23 refreshIndex, 24) where 25 26import Common 27import Git 28import Git.Types 29import Git.Command 30import Git.FilePath 31import Git.Sha 32import qualified Git.DiffTreeItem as Diff 33 34import qualified Data.ByteString as S 35import qualified Data.ByteString.Lazy as L 36import Control.Monad.IO.Class 37 38{- Streamers are passed a callback and should feed it lines in the form 39 - read by update-index, and generated by ls-tree. -} 40type Streamer = (L.ByteString -> IO ()) -> IO () 41 42{- A streamer with a precalculated value. -} 43pureStreamer :: L.ByteString -> Streamer 44pureStreamer !s = \streamer -> streamer s 45 46{- Streams content into update-index from a list of Streamers. -} 47streamUpdateIndex :: Repo -> [Streamer] -> IO () 48streamUpdateIndex repo as = withUpdateIndex repo $ \h -> 49 forM_ as $ streamUpdateIndex' h 50 51data UpdateIndexHandle = UpdateIndexHandle Handle 52 53streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO () 54streamUpdateIndex' (UpdateIndexHandle h) a = a $ \s -> do 55 L.hPutStr h s 56 L.hPutStr h "\0" 57 58withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a 59withUpdateIndex repo a = bracket setup cleanup go 60 where 61 params = map Param ["update-index", "-z", "--index-info"] 62 63 setup = liftIO $ createProcess $ 64 (gitCreateProcess params repo) 65 { std_in = CreatePipe } 66 go p = do 67 r <- a (UpdateIndexHandle (stdinHandle p)) 68 liftIO $ do 69 hClose (stdinHandle p) 70 void $ checkSuccessProcess (processHandle p) 71 return r 72 73 cleanup = liftIO . cleanupProcess 74 75{- A streamer that adds the current tree for a ref. Useful for eg, copying 76 - and modifying branches. -} 77lsTree :: Ref -> Repo -> Streamer 78lsTree (Ref x) repo streamer = do 79 (s, cleanup) <- pipeNullSplit params repo 80 mapM_ streamer s 81 void $ cleanup 82 where 83 params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x] 84lsSubTree :: Ref -> FilePath -> Repo -> Streamer 85lsSubTree (Ref x) p repo streamer = do 86 (s, cleanup) <- pipeNullSplit params repo 87 mapM_ streamer s 88 void $ cleanup 89 where 90 params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x, p] 91 92{- Generates a line suitable to be fed into update-index, to add 93 - a given file with a given sha. -} 94updateIndexLine :: Sha -> TreeItemType -> TopFilePath -> L.ByteString 95updateIndexLine sha treeitemtype file = L.fromStrict $ 96 fmtTreeItemType treeitemtype 97 <> " blob " 98 <> fromRef' sha 99 <> "\t" 100 <> indexPath file 101 102stageFile :: Sha -> TreeItemType -> FilePath -> Repo -> IO Streamer 103stageFile sha treeitemtype file repo = do 104 p <- toTopFilePath (toRawFilePath file) repo 105 return $ pureStreamer $ updateIndexLine sha treeitemtype p 106 107{- A streamer that removes a file from the index. -} 108unstageFile :: FilePath -> Repo -> IO Streamer 109unstageFile file repo = do 110 p <- toTopFilePath (toRawFilePath file) repo 111 return $ unstageFile' p 112 113unstageFile' :: TopFilePath -> Streamer 114unstageFile' p = pureStreamer $ L.fromStrict $ 115 "0 " 116 <> fromRef' deleteSha 117 <> "\t" 118 <> indexPath p 119 120{- A streamer that adds a symlink to the index. -} 121stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer 122stageSymlink file sha repo = do 123 !line <- updateIndexLine 124 <$> pure sha 125 <*> pure TreeSymlink 126 <*> toTopFilePath file repo 127 return $ pureStreamer line 128 129{- A streamer that applies a DiffTreeItem to the index. -} 130stageDiffTreeItem :: Diff.DiffTreeItem -> Streamer 131stageDiffTreeItem d = case toTreeItemType (Diff.dstmode d) of 132 Nothing -> unstageFile' (Diff.file d) 133 Just t -> pureStreamer $ updateIndexLine (Diff.dstsha d) t (Diff.file d) 134 135indexPath :: TopFilePath -> InternalGitPath 136indexPath = toInternalGitPath . getTopFilePath 137 138{- Refreshes the index, by checking file stat information. -} 139refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool 140refreshIndex repo feeder = withCreateProcess p go 141 where 142 params = 143 [ Param "update-index" 144 , Param "-q" 145 , Param "--refresh" 146 , Param "-z" 147 , Param "--stdin" 148 ] 149 150 p = (gitCreateProcess params repo) 151 { std_in = CreatePipe } 152 153 go (Just h) _ _ pid = do 154 feeder $ \f -> 155 S.hPut h (S.snoc f 0) 156 hFlush h 157 hClose h 158 checkSuccessProcess pid 159 go _ _ _ _ = error "internal" 160