mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-06 06:26:45 +09:00
315 lines
13 KiB
Haskell
315 lines
13 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
-
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
- rights to this software to the public domain worldwide. This software is
|
|
- distributed without any warranty.
|
|
-
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
- with this software. If not, see
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Vervis.Git
|
|
( readSourceView
|
|
, readChangesView
|
|
, listRefs
|
|
, readPatch
|
|
, lastCommitTime
|
|
)
|
|
where
|
|
|
|
import Control.Arrow ((***))
|
|
import Control.Monad (join)
|
|
import Control.Monad.Trans.Class (lift)
|
|
import Control.Monad.Trans.Except
|
|
import Patience (diff, Item (..))
|
|
import Data.Byteable (toBytes)
|
|
import Data.Foldable (foldlM, find)
|
|
import Data.Git.Diff
|
|
import Data.Git.Graph
|
|
import Data.Git.Harder
|
|
import Data.Git.Monad
|
|
import Data.Git.Ref (SHA1, fromHex, toHex)
|
|
import Data.Git.Storage (getObject_)
|
|
import Data.Git.Storage.Object (Object (..))
|
|
import Data.Git.Types hiding (ObjectType (..))
|
|
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)
|
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
|
import Data.Time.Calendar (Day (..))
|
|
import Data.Time.Clock (UTCTime (..))
|
|
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 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.Git as G
|
|
import qualified Data.List.NonEmpty as N (toList)
|
|
import qualified Data.Set as S (member, mapMonotonic, toList)
|
|
import qualified Data.Text as T (pack, unpack, break, strip)
|
|
import qualified Data.Text.Encoding as TE (decodeUtf8With)
|
|
import qualified Data.Text.Encoding.Error as TE (lenientDecode)
|
|
import qualified Data.Vector as V (fromList)
|
|
|
|
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
|
|
import Vervis.Readme
|
|
import Vervis.SourceTree
|
|
|
|
matchReadme :: (ModePerm, ObjId, Text, EntObjType) -> Bool
|
|
matchReadme (_, _, name, EntObjBlob) = isReadme name
|
|
matchReadme _ = False
|
|
|
|
-- | Find a README file in a directory. Return the filename and the file
|
|
-- content.
|
|
findReadme :: Git SHA1 -> TreeRows -> IO (Maybe (Text, BL.ByteString))
|
|
findReadme git rows =
|
|
case find matchReadme rows of
|
|
Nothing -> return Nothing
|
|
Just (_perm, oid, name, _etype) -> do
|
|
obj <- getObject_ git (unObjId oid) True
|
|
return $ case obj of
|
|
ObjBlob b -> Just (name, blobGetContent b)
|
|
_ -> Nothing
|
|
|
|
matchType :: EntObjType -> EntryType
|
|
matchType EntObjBlob = TypeBlob
|
|
matchType EntObjTree = TypeTree
|
|
|
|
rowToEntry :: (ModePerm, ObjId, Text, EntObjType) -> DirEntry
|
|
rowToEntry (_, _, name, etype) = DirEntry (matchType etype) name
|
|
|
|
loadSourceView
|
|
:: Git SHA1
|
|
-> Text
|
|
-> [Text]
|
|
-> IO (Set RefName, Set RefName, Maybe (SourceView BL.ByteString))
|
|
loadSourceView git refT dir = do
|
|
branches <- G.branchList git
|
|
tags <- G.tagList git
|
|
let refS = T.unpack refT
|
|
refN = RefName refS
|
|
msv <- if refN `S.member` branches || refN `S.member` tags
|
|
then do
|
|
tipOid <- resolveName git refS
|
|
mtree <- G.resolveTreeish git $ unObjId tipOid
|
|
case mtree of
|
|
Nothing -> return Nothing
|
|
Just tree -> do
|
|
let dir' = map (G.entName . encodeUtf8) dir
|
|
view <- viewPath git tree dir'
|
|
Just <$> case view of
|
|
RootView rows -> do
|
|
mreadme <- findReadme git rows
|
|
let ents = map rowToEntry rows
|
|
return $ SourceDir $
|
|
DirectoryView Nothing ents mreadme
|
|
TreeView name _ rows -> do
|
|
mreadme <- findReadme git rows
|
|
let ents = map rowToEntry rows
|
|
return $ SourceDir $
|
|
DirectoryView (Just name) ents mreadme
|
|
BlobView name _ body ->
|
|
return $ SourceFile $ FileView name body
|
|
else return Nothing
|
|
return (branches, tags, msv)
|
|
|
|
readSourceView
|
|
:: FilePath
|
|
-- ^ Repository path
|
|
-> Text
|
|
-- ^ Name of branch or tag
|
|
-> [Text]
|
|
-- ^ Path in the source tree pointing to a file or directory
|
|
-> IO (Set Text, Set Text, Maybe (SourceView Widget))
|
|
-- ^ Branches, tags, view of the selected item
|
|
readSourceView path ref dir = do
|
|
(bs, ts, msv) <-
|
|
G.withRepo (fromString path) $ \ git -> loadSourceView git ref dir
|
|
let toTexts = S.mapMonotonic $ T.pack . refNameRaw
|
|
return (toTexts bs, toTexts ts, renderSources dir <$> msv)
|
|
|
|
instance ResultList D.DList where
|
|
emptyList = D.empty
|
|
appendItem = flip D.snoc
|
|
|
|
readChangesView
|
|
:: FilePath
|
|
-- ^ Repository path
|
|
-> Text
|
|
-- ^ Name of branch or tag
|
|
-> Int
|
|
-- ^ Offset, i.e. latest commits to skip
|
|
-> Int
|
|
-- ^ Limit, i.e. how many latest commits to take after the offset
|
|
-> IO (Int, [LogEntry])
|
|
-- ^ Total number of ref's changes, and view of selected ref's change log
|
|
readChangesView path ref off lim = G.withRepo (fromString path) $ \ git -> do
|
|
oid <- resolveName git $ T.unpack ref
|
|
graph <- loadCommitGraphPT git [oid]
|
|
let mnodes = topsortUnmixOrder graph (NodeStack [noNodes graph])
|
|
nodes = case mnodes of
|
|
Nothing -> error "commit graph contains a cycle"
|
|
Just ns -> ns
|
|
pairs = D.toList $ fmap (nodeLabel graph) nodes
|
|
pairs' = take lim $ drop off pairs
|
|
toText = TE.decodeUtf8With TE.lenientDecode
|
|
Elapsed now <- timeCurrent
|
|
let mkrow oid commit = LogEntry
|
|
{ leAuthor = toText $ personName $ commitAuthor commit
|
|
, leHash = toText $ toHex $ unObjId oid
|
|
, leMessage = toText $ takeLine $ commitMessage commit
|
|
, leTime =
|
|
( utc t
|
|
, intervalToEventTime $
|
|
FriendlyConvert $
|
|
now - t
|
|
)
|
|
}
|
|
where
|
|
Elapsed t = gitTimeUTC $ personTime $ commitAuthor commit
|
|
utc (Seconds i) = posixSecondsToUTCTime $ fromIntegral i
|
|
return (noNodes graph, map (uncurry mkrow) pairs')
|
|
|
|
listRefs :: FilePath -> IO (Set Text, Set Text)
|
|
listRefs path = G.withRepo (fromString path) $ \ git ->
|
|
(,) <$> listBranches git <*> listTags git
|
|
|
|
patch :: [Edit] -> Commit SHA1 -> Patch
|
|
patch edits c = Patch
|
|
{ patchAuthorName = decodeUtf8 $ personName $ commitAuthor c
|
|
, patchAuthorEmail =
|
|
let b = personEmail $ commitAuthor c
|
|
in case emailAddress b of
|
|
Nothing -> error $ "Invalid email " ++ T.unpack (decodeUtf8 b)
|
|
Just e -> e
|
|
, patchTime =
|
|
let Elapsed (Seconds t) = gitTimeUTC $ personTime $ commitAuthor c
|
|
in posixSecondsToUTCTime $ fromIntegral t
|
|
, patchTitle = title
|
|
, patchDescription = desc
|
|
, patchDiff = edits
|
|
}
|
|
where
|
|
split t =
|
|
let (l, r) = T.break (\ c -> c == '\n' || c == '\r') t
|
|
in (T.strip l, T.strip r)
|
|
(title, desc) = split $ decodeUtf8 $ commitMessage c
|
|
|
|
ep2fp :: EntPath -> FilePath
|
|
ep2fp = T.unpack . decodeUtf8 . B.intercalate "/" . map getEntNameBytes
|
|
|
|
unModePerm :: ModePerm -> Word32
|
|
unModePerm (ModePerm w) = w
|
|
|
|
data Line = Line
|
|
{ lineNumber :: Int
|
|
, lineText :: Text
|
|
}
|
|
|
|
instance Eq Line where
|
|
Line _ t == Line _ s = t == s
|
|
|
|
instance Ord Line where
|
|
Line _ t `compare` Line _ s = t `compare` s
|
|
|
|
mkdiff :: [Text] -> [Text] -> [(Bool, Int, Hunk)]
|
|
mkdiff old new =
|
|
let eitherOldNew (Old a) = Just $ Left a
|
|
eitherOldNew (New a) = Just $ Right a
|
|
eitherOldNew (Both _ _) = Nothing
|
|
stripLineNumber = fmap lineText
|
|
mkhunk' (adds, pairs, rems) = Hunk
|
|
{ hunkAddFirst = stripLineNumber adds
|
|
, hunkRemoveAdd = map (stripLineNumber *** stripLineNumber) pairs
|
|
, hunkRemoveLast = stripLineNumber rems
|
|
}
|
|
line ((Line n _):_, _ , _) = (True, n)
|
|
line ([] , ((Line n _) :| _, _):_, _) = (False, n)
|
|
line ([] , [] , (Line n _):_) = (False, n)
|
|
line ([] , [] , []) = error "empty hunk"
|
|
mkhunk h =
|
|
let (n, l) = line h
|
|
in (n, l, mkhunk' h)
|
|
in map (mkhunk . groupEithers . N.toList) $
|
|
groupJusts $
|
|
map eitherOldNew $
|
|
diff (zipWith Line [1..] old) (zipWith Line [1..] new)
|
|
|
|
accumEdits :: BlobStateDiff SHA1 -> [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) (V.fromList $ map (decodeUtf8 . BL.toStrict) ols) (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 = G.withRepo (fromString path) $ \ git -> do
|
|
let ref = fromHex $ encodeUtf8 hash
|
|
c <- G.getCommit git ref
|
|
medits <- case commitParents c of
|
|
[] -> 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 <$> G.getCommit git p
|
|
return $ case medits of
|
|
Left parents -> (patch [] c, parents)
|
|
Right edits -> (patch edits c, [])
|
|
|
|
lastCommitTime :: FilePath -> IO (Maybe UTCTime)
|
|
lastCommitTime repo =
|
|
(either fail return =<<) $ fmap join $ withRepo (fromString repo) $ runExceptT $ do
|
|
branches <- S.toList <$> lift branchList
|
|
lct <- foldlM' utc0 branches $ \ time branch -> do
|
|
mcommit <- lift $ getCommit branch
|
|
case mcommit of
|
|
Nothing ->
|
|
throwE $
|
|
"lastCommitTime: Failed to get commit for branch " ++
|
|
refNameRaw branch
|
|
Just c ->
|
|
return $ max time $
|
|
utc $ gitTimeUTC $ personTime $ commitCommitter c
|
|
return $ if null branches
|
|
then Nothing
|
|
else Just lct
|
|
where
|
|
utc (Elapsed (Seconds i)) = posixSecondsToUTCTime $ fromIntegral i
|
|
utc0 = UTCTime (ModifiedJulianDay 0) 0
|
|
foldlM' i l f = foldlM f i l
|