From dbec638415e9addd804eb86898222380cb521298 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 19 May 2018 16:10:03 +0000 Subject: [PATCH] Generate commit diff data for git repos --- src/Data/List/Local.hs | 28 +++++++++++++++- src/Vervis/Git.hs | 72 ++++++++++++++++++++++++++++++++++++++---- src/Vervis/Patch.hs | 13 ++++---- vervis.cabal | 1 + 4 files changed, 99 insertions(+), 15 deletions(-) diff --git a/src/Data/List/Local.hs b/src/Data/List/Local.hs index 787b14c..761b0e3 100644 --- a/src/Data/List/Local.hs +++ b/src/Data/List/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2018 by fr33domlover . - - ♡ 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) diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 5caa352..4cd47ca 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -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) diff --git a/src/Vervis/Patch.hs b/src/Vervis/Patch.hs index 71ca966..e131d8e 100644 --- a/src/Vervis/Patch.hs +++ b/src/Vervis/Patch.hs @@ -13,7 +13,7 @@ - . -} --- | 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 diff --git a/vervis.cabal b/vervis.cabal index a2fa926..318f0c6 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -278,6 +278,7 @@ library , pandoc-types -- for PathPiece instance for CI, Web.PathPieces.Local , path-pieces + , patience , persistent , persistent-email-address , persistent-migration