forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Generate commit diff data for git repos

Browse source
This commit is contained in:
fr33domlover 2018-05-19 16:10:03 +00:00
parent 2fb00c914a
commit dbec638415
4 changed files with 99 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
src/Data/List/Local.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -15,11 +15,15 @@
module Data.List.Local
( -- groupByFst
groupJusts
, groupEithers
)
where
import Prelude
import Data.List.NonEmpty (NonEmpty (..), (<|))
-- | Takes a list of pairs and groups them by consecutive ranges with equal
-- first element. Returns a list of pairs, where each pair corresponds to one
-- such range.
@ -28,3 +32,25 @@ groupByFst [] = []
groupByFst ((x, y):ps) =
let (same, rest) = span ((== x) . fst) ps
in (x, y : map snd same) : groupByFst rest
-- | Group together sublists of Just items, and drop the Nothing items.
--
-- >>> groupJusts [Nothing, Nothing, Just 1, Just 4, Nothing, Just 2]
-- [[1, 4], [2]]
groupJusts :: [Maybe a] -> [NonEmpty a]
groupJusts maybes = prepend $ foldr go (Nothing, []) maybes
where
prepend (Nothing, l) = l
prepend (Just x , l) = x : l
go Nothing (Nothing, ls) = (Nothing , ls)
go Nothing (Just l , ls) = (Nothing , l : ls)
go (Just x) (Nothing, ls) = (Just $ x :| [], ls)
go (Just x) (Just l , ls) = (Just $ x <| l , ls)
groupEithers :: [Either a b] -> ([b], [(NonEmpty a, NonEmpty b)], [a])
groupEithers = foldr go ([], [], [])
where
go (Left x) ([] , [] , as) = ([], [] , x : as)
go (Left x) ([] , (xs, ys):ps, as) = ([], (x <| xs, ys) : ps , as)
go (Left x) (b:bs, ps , as) = ([], (x :| [], b :| bs) : ps, as)
go (Right y) (bs, ps, as) = (y : bs, ps, as)

72
src/Vervis/Git.hs
View file

@ -23,8 +23,12 @@ where
import Prelude
import Control.Arrow ((&&&), (***))
import Data.Algorithm.Patience (diff, Item (..))
import Data.Byteable (toBytes)
import Data.Foldable (find)
import Data.Git
import Data.Git.Diff
import Data.Git.Graph
import Data.Git.Harder
import Data.Git.Ref (fromHex, toHex)
@ -34,6 +38,7 @@ import Data.Git.Storage.Object (Object (..))
import Data.Git.Types (GitTime (..))
import Data.Graph.Inductive.Graph (noNodes)
import Data.Graph.Inductive.Query.Topsort
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Set (Set)
import Data.String (fromString)
import Data.Text (Text)
@ -41,12 +46,15 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Time.Clock ()
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Traversable (for)
import Data.Word (Word32)
import System.Hourglass (timeCurrent)
import Text.Email.Validate (emailAddress)
import Time.Types (Elapsed (..), Seconds (..))
import qualified Data.ByteString.Lazy as BL (ByteString)
import qualified Data.ByteString as B (intercalate)
import qualified Data.ByteString.Lazy as BL (ByteString, toStrict, length)
import qualified Data.DList as D (DList, empty, snoc, toList)
import qualified Data.List.NonEmpty as N (toList)
import qualified Data.Set as S (member, mapMonotonic)
import qualified Data.Text as T (pack, unpack, break, strip)
import qualified Data.Text.Encoding as TE (decodeUtf8With)
@ -55,6 +63,7 @@ import qualified Data.Text.Encoding.Error as TE (lenientDecode)
import Data.ByteString.Char8.Local (takeLine)
import Data.EventTime.Local
import Data.Git.Local
import Data.List.Local
import Vervis.Changes
import Vervis.Foundation (Widget)
import Vervis.Patch
@ -201,17 +210,66 @@ patch edits c = Patch
in (T.strip l, T.strip r)
(title, desc) = split $ decodeUtf8 $ commitMessage c
ep2fp :: EntPath -> FilePath
ep2fp = T.unpack . decodeUtf8 . B.intercalate "/" . map toBytes
unModePerm :: ModePerm -> Word32
unModePerm (ModePerm w) = w
mkdiff :: [Text] -> [Text] -> [(Int, Hunk)]
mkdiff old new =
let eitherOldNew (Old a) = Just $ Left a
eitherOldNew (New a) = Just $ Right a
eitherOldNew (Both _ _) = Nothing
stripLineNumber = fmap snd
mkhunk' (adds, pairs, rems) = Hunk
{ hunkAddFirst = stripLineNumber adds
, hunkRemoveAdd = map (stripLineNumber *** stripLineNumber) pairs
, hunkRemoveLast = stripLineNumber rems
}
line ((n, _):_, _ , _) = n
line ([] , ((n, _) :| _, _):_, _) = n
line ([] , [] , (n, _):_) = n
line ([] , [] , []) = error "empty hunk"
mkhunk = line &&& mkhunk'
in map (mkhunk . groupEithers . N.toList) $
groupJusts $
map eitherOldNew $
diff (zip [1..] old) (zip [1..] new)
accumEdits :: BlobStateDiff -> [Edit] -> [Edit]
accumEdits (OnlyOld bs) es =
case bsContent bs of
FileContent lines -> RemoveTextFile (ep2fp $ bsFilename bs) (unModePerm $ bsMode bs) (map (decodeUtf8 . BL.toStrict) lines) : es
BinaryContent b -> RemoveBinaryFile (ep2fp $ bsFilename bs) (unModePerm $ bsMode bs) (BL.length b) : es
accumEdits (OnlyNew bs) es =
case bsContent bs of
FileContent lines -> AddTextFile (ep2fp $ bsFilename bs) (unModePerm $ bsMode bs) (map (decodeUtf8 . BL.toStrict) lines) : es
BinaryContent b -> AddBinaryFile (ep2fp $ bsFilename bs) (unModePerm $ bsMode bs) (BL.length b) : es
accumEdits (OldAndNew old new) es =
if bsFilename old == bsFilename new
then if bsRef old == bsRef new
then if bsMode old == bsMode new
then es
else ChmodFile (ep2fp $ bsFilename new) (unModePerm $ bsMode old) (unModePerm $ bsMode new) : es
else case (bsContent old, bsContent new) of
(FileContent ols, FileContent nls) ->
case mkdiff (map (decodeUtf8 . BL.toStrict) ols) (map (decodeUtf8 . BL.toStrict) nls) of
[] -> error "file ref changed, diff is empty?"
h:hs -> EditTextFile (ep2fp $ bsFilename new) (h :| hs) (unModePerm $ bsMode old) (unModePerm $ bsMode new) : es
(BinaryContent b, FileContent nls) -> BinaryToText (ep2fp $ bsFilename new) (BL.length b) (unModePerm $ bsMode old) (map (decodeUtf8 . BL.toStrict) nls) (unModePerm $ bsMode new) : es
(FileContent ols, BinaryContent b) -> TextToBinary (ep2fp $ bsFilename new) (map (decodeUtf8 . BL.toStrict) ols) (unModePerm $ bsMode old) (BL.length b) (unModePerm $ bsMode new) : es
(BinaryContent from, BinaryContent to) -> EditBinaryFile (ep2fp $ bsFilename new) (BL.length from) (unModePerm $ bsMode old) (BL.length to) (unModePerm $ bsMode new) : es
else error "getDiffWith gave OldAndNew with different file paths"
readPatch :: FilePath -> Text -> IO (Patch, [Text])
readPatch path hash = withRepo (fromString path) $ \ git -> do
let ref = fromHex $ encodeUtf8 hash
c <- getCommit git ref
medits <- case commitParents c of
[] -> -- use the tree to generate list of AddFile diff parts
return $ Right []
[p] -> -- use getDiff to grab list of changes in the patch
return $ Right []
ps -> -- multiple parents! idk rn how to deal with this correctly
fmap Left $ for ps $ \ p ->
[] -> error "Use the tree to generate list of AddFile diff parts?"
[p] -> Right <$> getDiffWith accumEdits [] p ref git
ps -> fmap Left $ for ps $ \ p ->
decodeUtf8 . takeLine . commitMessage <$> getCommit git p
return $ case medits of
Left parents -> (patch [] c, parents)

13
src/Vervis/Patch.hs
View file

@ -13,7 +13,7 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- | Representation of commit in a repo for viewing.
-- | Representation of a commit in a repo for viewing.
--
-- Each version control system has its own specific details of how repository
-- changes are represented and encoded and stored internally. This module is
@ -28,17 +28,16 @@ where
import Prelude
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Data.Word (Word32)
import Text.Email.Validate (EmailAddress)
data Hunk = Hunk
{ hunkContextBefore :: [Text]
, hunkLineNumber :: Int
, hunkOldLines :: [Text]
, hunkNewLines :: [Text]
, hunkContextAfter :: [Text]
{ hunkAddFirst :: [Text]
, hunkRemoveAdd :: [(NonEmpty Text, NonEmpty Text)]
, hunkRemoveLast :: [Text]
}
data Edit
@ -48,7 +47,7 @@ data Edit
| RemoveBinaryFile FilePath Word32 Int64
| MoveFile FilePath Word32 FilePath Word32
| ChmodFile FilePath Word32 Word32
| EditTextFile FilePath [Hunk] Word32 Word32
| EditTextFile FilePath (NonEmpty (Int, Hunk)) Word32 Word32
| EditBinaryFile FilePath Int64 Word32 Int64 Word32
| TextToBinary FilePath [Text] Word32 Int64 Word32
| BinaryToText FilePath Int64 Word32 [Text] Word32

1
vervis.cabal
View file

@ -278,6 +278,7 @@ library
, pandoc-types
-- for PathPiece instance for CI, Web.PathPieces.Local
, path-pieces
, patience
, persistent
, persistent-email-address
, persistent-migration