From 5c288c7fdbd588e690d7e772f47da7c242c1cfd6 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 8 May 2016 14:28:03 +0000 Subject: [PATCH] Darcs change log view --- src/Darcs/Local/PatchInfo/Parser.hs | 259 ++++++++++++++++++++ src/Darcs/Local/PatchInfo/Types.hs | 68 +++++ src/Darcs/{Local.hs => Local/Repository.hs} | 55 +---- src/Data/Attoparsec/ByteString/Local.hs | 38 +++ src/Data/ByteString/Local.hs | 11 + src/Data/Time/Clock/Local.hs | 44 ++++ src/Vervis/Darcs.hs | 35 ++- src/Vervis/Handler/Repo.hs | 13 +- templates/repo/changes-darcs.hamlet | 19 ++ vervis.cabal | 15 +- 10 files changed, 500 insertions(+), 57 deletions(-) create mode 100644 src/Darcs/Local/PatchInfo/Parser.hs create mode 100644 src/Darcs/Local/PatchInfo/Types.hs rename src/Darcs/{Local.hs => Local/Repository.hs} (59%) create mode 100644 src/Data/Attoparsec/ByteString/Local.hs create mode 100644 src/Data/Time/Clock/Local.hs create mode 100644 templates/repo/changes-darcs.hamlet diff --git a/src/Darcs/Local/PatchInfo/Parser.hs b/src/Darcs/Local/PatchInfo/Parser.hs new file mode 100644 index 0000000..a4b8e25 --- /dev/null +++ b/src/Darcs/Local/PatchInfo/Parser.hs @@ -0,0 +1,259 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- We use the ByteString based Attoparsec and not the Text based one because we +-- need to create a hash of the patch info. If we use the Text one, Attoparsec +-- decodes the text, hopefully as UTF-8, and then we need to encode again to +-- ByteString for the hashing. This is dangerous because if the encoding +-- doesn't result with the exact original text, we'll have the wrong hash. To +-- make sure it's exactly the right content, we use ByteString first and then +-- later decode to Text. +module Darcs.Local.PatchInfo.Parser + ( readPatchInfo + ) +where + +import Prelude hiding (takeWhile) + +import Control.Applicative (many) +import Control.Monad (replicateM, replicateM_) +import Crypto.Hash +import Crypto.Hash.Algorithms (SHA1 (SHA1)) +import Data.Attoparsec.ByteString +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import Data.Time.Calendar (fromGregorianValid) +import Data.Time.Clock (UTCTime (..), secondsToDiffTime) +import Data.Word (Word8) +import System.FilePath (()) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Storage.Hashed.Hash as H + +import Darcs.Local.PatchInfo.Types +import Data.Attoparsec.ByteString.Local +import Data.ByteString.Local (stripPrefix) +import Data.Text.UTF8.Local (decodeStrict) + +lf, space, star, dash, zero, nine, sqrOpen, sqrClose :: Word8 +lf = 10 +space = 32 +star = 42 +dash = 45 +zero = 48 +nine = 57 +sqrOpen = 91 +sqrClose = 93 + +digit :: Parser Word8 +digit = satisfy $ \ w -> zero <= w && w <= nine + +digitP :: Num a => Parser a +digitP = fmap (\ c -> fromIntegral $ c - zero) digit + +decimal2P :: Num a => Parser a +decimal2P = + (\ h l -> 10 * h + l) <$> + digitP <*> + digitP + +decimal4P :: Num a => Parser a +decimal4P = + (\ hh h l ll -> 10 * (10 * (10 * hh + h) + l) + ll) <$> + digitP <*> + digitP <*> + digitP <*> + digitP + +patchTimeP :: Parser UTCTime +patchTimeP = do + year <- decimal4P + month <- decimal2P + day <- decimal2P + + hour <- decimal2P + minute <- decimal2P + second <- decimal2P + + case fromGregorianValid year month day of + Nothing -> fail "Invalid patch date" + Just uday -> return UTCTime + { utctDay = uday + , utctDayTime = + secondsToDiffTime $ 3600 * hour + 60 * minute + second + } + +skipLine :: Parser () +skipLine = do + skipWhile (/= lf) + skip (== lf) + +skipRestOfLine :: Parser () +skipRestOfLine = skipLine + +skipPatchP :: Parser () +skipPatchP = do + -- title + skipLine + -- author, inverted, time + skipLine + -- ignore, description + skipMany $ do + skip (== space) + skipRestOfLine + -- end of info + string "] \n" + -- hash + skipWhile (/= lf) + +pristineP :: Parser (Maybe Int, H.Hash) +pristineP = do + string "pristine:" + (,) Nothing . H.decodeBase16 <$> takeWhile (/= lf) + +patchInfoRawP :: Parser PatchInfoRaw +patchInfoRawP = do + word8 sqrOpen + title <- takeWhile1 (/= lf) + word8 lf + + author <- takeWhile1 (/= star) + word8 star + inverted <- (/= star) <$> (satisfy $ \ c -> c == star || c == dash) + (timeRaw, time) <- match patchTimeP + word8 lf + + word8 space + junkp <- string "Ignore-this: " + junkc <- takeWhile1 (/= lf) + word8 lf + + lines <- many $ word8 space *> takeWhile (/= lf) <* word8 lf + string "] \nhash: " + + hash <- takeWhile1 (/= lf) + + return PatchInfoRaw + { pirAuthor = author + , pirHash = hash + , pirTitle = title + , pirDescription = lines + , pirJunkPrefix = junkp + , pirJunkContent = junkc + , pirTime = (timeRaw, time) + , pirInverted = inverted + } + +hashPatchInfo :: HashAlgorithm a => a -> PatchInfoRaw -> Digest a +hashPatchInfo _algo pir = + let add = flip hashUpdate + adds = flip hashUpdates + in hashFinalize $ + add (if pirInverted pir then "t" else "f" :: ByteString) $ + adds (pirDescription pir) $ + add (pirJunkContent pir) $ + add (pirJunkPrefix pir) $ + add (fst $ pirTime pir) $ + add (pirAuthor pir) $ + add (pirTitle pir) + hashInit + +refinePatchInfo :: PatchInfoRaw -> PatchInfo +refinePatchInfo pir = + let rtitle = pirTitle pir + (title, tag) = case stripPrefix "TAG " rtitle of + Nothing -> (rtitle, False) + Just rest -> (rest, True) + description = case pirDescription pir of + [] -> Nothing + l -> Just $ BC.unlines l + in PatchInfo + { piAuthor = decodeStrict $ pirAuthor pir + , piHash = pirHash pir + , piTitle = decodeStrict title + , piDescription = decodeStrict <$> description + , piTag = tag + , piTime = snd $ pirTime pir + } + +-- | Parse patch metadata and compute the metadata's hash, which can be used as +-- a patch identifier for lookup and matching. +patchInfoP :: Parser (PatchInfo, ByteString) +patchInfoP = do + pir <- patchInfoRawP + return (refinePatchInfo pir, convert $ hashPatchInfo SHA1 pir) + +-- NEXT current plan: +-- +-- (0) all parses are incremental!!! +-- (1) use CountP below to determine number of patches +-- (2) given pagination details determine offset and limit +-- (3) parse the patches we want +-- (4) reverse their order... +-- (5) generate a whamlet widget from that +-- (*) FOR NOW no pagination, just read the entire thing once... + +patchInfosCountP :: Parser Int +patchInfosCountP = do + skipWhile (/= lf) -- pristine hash + n <- length <$> (many $ word8 lf >> skipPatchP) + word8 lf + return n + +patchInfosAllP :: Parser PatchSeq +patchInfosAllP = do + (psize, phash) <- pristineP + ps <- many $ word8 lf >> patchInfoP + word8 lf + return PatchSeq + { psPristineHash = phash + , psPristineSize = psize + , psPatches = ps + } + +patchInfosOffsetP :: Int -> Parser PatchSeq +patchInfosOffsetP off = do + (psize, phash) <- pristineP + replicateM_ off $ word8 lf >> skipPatchP + ps <- many $ word8 lf >> patchInfoP + word8 lf + return PatchSeq + { psPristineHash = phash + , psPristineSize = psize + , psPatches = ps + } + +patchInfosLimitP :: Int -> Parser PatchSeq +patchInfosLimitP lim = do + (psize, phash) <- pristineP + ps <- replicateM lim $ word8 lf >> patchInfoP + word8 lf + return PatchSeq + { psPristineHash = phash + , psPristineSize = psize + , psPatches = ps + } + +darcsDir :: FilePath +darcsDir = "_darcs" + +inventoryFile :: FilePath +inventoryFile = "hashed_inventory" + +readPatchInfo :: FilePath -> IO (Either String PatchSeq) +readPatchInfo repoPath = do + let invPath = repoPath darcsDir inventoryFile + parseFileIncremental invPath $ patchInfosAllP <* endOfInput diff --git a/src/Darcs/Local/PatchInfo/Types.hs b/src/Darcs/Local/PatchInfo/Types.hs new file mode 100644 index 0000000..407730e --- /dev/null +++ b/src/Darcs/Local/PatchInfo/Types.hs @@ -0,0 +1,68 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Darcs.Local.PatchInfo.Types + ( PatchInfoRaw (..) + , PatchInfo (..) + , PatchSeq (..) + ) +where + +import Prelude + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Storage.Hashed.Hash (Hash) + +-- | Patch metadata in raw form. This is intended for accurate hashing of the +-- patch info. +data PatchInfoRaw = PatchInfoRaw + { pirAuthor :: ByteString + , pirHash :: ByteString + , pirTitle :: ByteString + , pirDescription :: [ByteString] + , pirJunkPrefix :: ByteString + , pirJunkContent :: ByteString + , pirTime :: (ByteString, UTCTime) + , pirInverted :: Bool + } + +-- | Patch metadata read from the inventory file. +data PatchInfo = PatchInfo + { -- | Author name and email + piAuthor :: Text + -- | Currently this is the patch hash in textual form. Possibly I'll + -- change to binary form when I find out the encoding scheme of the hash + -- string. + , piHash :: ByteString + -- | Single message line + , piTitle :: Text + -- | Optional description, may contain several lines + , piDescription :: Maybe Text + -- | Whether this is a tag + , piTag :: Bool + -- | When the patch was recorded + , piTime :: UTCTime + -- Whether the patch is inverted + --, piInverted :: Bool + } + +-- | The information from the hashed inventory file. +data PatchSeq = PatchSeq + { psPristineHash :: Hash + , psPristineSize :: Maybe Int + , psPatches :: [(PatchInfo, ByteString)] + } diff --git a/src/Darcs/Local.hs b/src/Darcs/Local/Repository.hs similarity index 59% rename from src/Darcs/Local.hs rename to src/Darcs/Local/Repository.hs index 10939e8..4e5ea27 100644 --- a/src/Darcs/Local.hs +++ b/src/Darcs/Local/Repository.hs @@ -13,10 +13,8 @@ - . -} -module Darcs.Local - ( -- * Initialize new repo - createRepo - -- * View repo source +module Darcs.Local.Repository + ( createRepo , readPristineRoot ) where @@ -27,7 +25,7 @@ import Storage.Hashed.Hash import System.Directory (createDirectory) import System.Exit (ExitCode (..)) import System.FilePath (()) -import System.IO (withFile, IOMode (ReadMode)) +import System.IO (withBinaryFile, IOMode (ReadMode)) import System.Process (createProcess, proc, waitForProcess) import qualified Data.ByteString as B @@ -71,54 +69,9 @@ createRepo parent name = do ExitSuccess -> return () ExitFailure n -> error $ "darcs init failed with exit code " ++ show n -{-data DirEntry = DirEntry - { dentType :: ItemType - , dentName :: Name - , dentSize :: Maybe Int - , dentHash :: Hash - } - -data DirEntryView = DirEntryView - { devName :: Name - , devSize :: Maybe Size - , devHash :: Hash - , devContent :: Either BL.ByteString [DirEntry] - } - -data PathView - = RootView [DirEntry] - | TreeView Text Hash [DirEntry] - | BlobView Text Hash BL.ByteString --} - readPristineRoot :: FilePath -> IO (Maybe Int, Hash) readPristineRoot darcsDir = do let inventoryFile = darcsDir "hashed_inventory" - line <- withFile inventoryFile ReadMode B.hGetLine + line <- withBinaryFile inventoryFile ReadMode B.hGetLine let hashBS = B.drop 9 line return (Nothing, decodeBase16 hashBS) - -{-toDEnt :: (ItemType, Name, Maybe Int, Hash) -> DirEntry -toDEnt (it, n, ms, h) = DirEntry it n ms h - -readSourceRootDir :: FilePath -> (Maybe Int, Hash) -> IO [DirEntry] -readSourceRootDir darcsDir (size, hash) = - let pristineDir = darcsDir "pristine.hashed" - in map toDEnt <$> readDarcsHashedDir pristineDir (size, hash) - -findDirEntry :: Name -> [DirEntry] -> Maybe DirEntry -findDirEntry name = find ((== name) . dentName) - -viewDirEntry :: FilePath -> DirEntry -> IO DirEntryView -viewDirEntry pristineDir (DirEntry itype name size hash) = do - content <- case itype of - TreeType -> - BlobType -> fmap decompress . readSegment . darcsLocation pristineDir - return (name, size, hash, content) - -textToName :: Text -> Name -textToName = Name . encodeUtf8 - -viewPath :: FilePath -> [Name] -> IO PathView -viewPath repoPath sourcePath = --TODO --} diff --git a/src/Data/Attoparsec/ByteString/Local.hs b/src/Data/Attoparsec/ByteString/Local.hs new file mode 100644 index 0000000..448e013 --- /dev/null +++ b/src/Data/Attoparsec/ByteString/Local.hs @@ -0,0 +1,38 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Data.Attoparsec.ByteString.Local + ( parseFileIncremental + ) +where + +import Prelude + +import Data.Attoparsec.ByteString +import System.IO + +import qualified Data.ByteString as B (hGet) +import qualified Data.ByteString.Lazy.Internal as BLI (defaultChunkSize) + +parseFileIncremental :: FilePath -> Parser a -> IO (Either String a) +parseFileIncremental file parser = + withBinaryFile file ReadMode $ \ h -> do + let getChunk = B.hGet h BLI.defaultChunkSize + go (Fail _remainder _contexts msg) = return $ Left msg + go (Partial cont) = getChunk >>= go . cont + go (Done _remainder value) = return $ Right value + firstChunk <- getChunk + let firstResult = parse parser firstChunk + go firstResult diff --git a/src/Data/ByteString/Local.hs b/src/Data/ByteString/Local.hs index 859504f..781e7dd 100644 --- a/src/Data/ByteString/Local.hs +++ b/src/Data/ByteString/Local.hs @@ -13,8 +13,11 @@ - . -} +{-# LANGUAGE CPP #-} + module Data.ByteString.Local ( fromDecimal + , stripPrefix ) where @@ -38,3 +41,11 @@ fromDecimal s = if (not . B.null) s && B.all (\ b -> 48 <= b && b <= 57) s then Just $ B.foldl' (\ n b -> 10 * n + fromIntegral b - 48) 0 s else Nothing + +#if !(MIN_VERSION_bytestring(0,10,8)) +stripPrefix :: ByteString -> ByteString -> Maybe ByteString +stripPrefix p b = + if p `B.isPrefixOf` b + then Just $ B.drop (B.length p) b + else Nothing +#endif diff --git a/src/Data/Time/Clock/Local.hs b/src/Data/Time/Clock/Local.hs new file mode 100644 index 0000000..0e9ac42 --- /dev/null +++ b/src/Data/Time/Clock/Local.hs @@ -0,0 +1,44 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +module Data.Time.Clock.Local + ( + ) +where + +import Prelude + +import Data.Time.Clock + +import Data.EventTime.Local + +instance IntervalToEventTime NominalDiffTime where + intervalToEventTime t + | t < 0 = Never + | t == 0 = Now + | t < 60 * 60 = Ago $ TimeAgo Second s + | t < 60 * 60 * 24 = Ago $ TimeAgo Minute $ s `div` 60 + | t < 60 * 60 * 24 * 365 = Ago $ TimeAgo Hour $ s `div` (60 * 60) + | otherwise = Ago $ TimeAgo Day $ s `div` (60 * 60 * 24) + where + s = floor t + +instance SpecToEventTime UTCTime where + specToEventTime t = do + now <- getCurrentTime + return $ intervalToEventTime $ now `diffUTCTime` t + specsToEventTimes ts = do + now <- getCurrentTime + return $ fmap (\ t -> intervalToEventTime $ now `diffUTCTime` t) ts diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index cd5df58..8dfe408 100644 --- a/src/Vervis/Darcs.hs +++ b/src/Vervis/Darcs.hs @@ -15,6 +15,7 @@ module Vervis.Darcs ( readSourceView + , readChangesView ) where @@ -23,6 +24,7 @@ import Prelude import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (strictDecode) +import Data.Time.Clock (getCurrentTime, diffUTCTime) import Data.Traversable (for) import Storage.Hashed.AnchoredPath import Storage.Hashed.Darcs @@ -30,9 +32,17 @@ import Storage.Hashed.Tree import System.FilePath (()) import qualified Data.ByteString.Lazy as BL (ByteString) +import qualified Data.ByteString.Base16 as B16 (encode) import qualified Data.Foldable as F (find) +import qualified Data.Text as T (takeWhile, stripEnd) -import Darcs.Local +import Darcs.Local.PatchInfo.Parser +import Darcs.Local.PatchInfo.Types +import Darcs.Local.Repository +import Data.EventTime.Local +import Data.Text.UTF8.Local (decodeStrict) +import Data.Time.Clock.Local () +import Vervis.Changes import Vervis.Foundation (Widget) import Vervis.Readme import Vervis.SourceTree @@ -101,3 +111,26 @@ readSourceView path dir = do let mitem = find expandedTree anch for mitem $ itemToSourceView (last dir) return $ renderSources dir <$> msv + +readChangesView + :: FilePath + -- ^ Repository path + -> IO (Maybe [LogEntry]) + -- ^ View of change log +readChangesView path = do + eps <- readPatchInfo path + case eps of + Left _err -> return Nothing + Right ps -> do + now <- getCurrentTime + let toLE pi h = LogEntry + { leAuthor = + T.stripEnd $ T.takeWhile (/= '<') $ piAuthor pi + , leHash = decodeStrict $ B16.encode h + , leMessage = piTitle pi + , leTime = + intervalToEventTime $ + FriendlyConvert $ + now `diffUTCTime` piTime pi + } + return $ Just $ map (uncurry toLE) $ reverse $ psPatches ps diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 930be70..bc716da 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -79,10 +79,10 @@ import Vervis.SourceTree import Vervis.Style import Vervis.Widget.Repo -import qualified Darcs.Local as D (createRepo) +import qualified Darcs.Local.Repository as D (createRepo) import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.Git.Local as G (createRepo) -import qualified Vervis.Darcs as D (readSourceView) +import qualified Vervis.Darcs as D (readSourceView, readChangesView) import qualified Vervis.Git as G (readSourceView, readChangesView) getReposR :: Text -> Handler Html @@ -184,7 +184,14 @@ getRepoSourceR shar repo refdir = do (ref:dir) -> getGitRepoSource repository shar repo ref dir getDarcsRepoHeadChanges :: Text -> Text -> Handler Html -getDarcsRepoHeadChanges shar repo = notFound +getDarcsRepoHeadChanges shar repo = do + path <- askRepoDir shar repo + mentries <- liftIO $ D.readChangesView path + case mentries of + Nothing -> notFound + Just entries -> + let changes = changesW entries + in defaultLayout $(widgetFile "repo/changes-darcs") getGitRepoHeadChanges :: Repo -> Text -> Text -> Handler Html getGitRepoHeadChanges repository shar repo = diff --git a/templates/repo/changes-darcs.hamlet b/templates/repo/changes-darcs.hamlet new file mode 100644 index 0000000..5890cb7 --- /dev/null +++ b/templates/repo/changes-darcs.hamlet @@ -0,0 +1,19 @@ +$# This file is part of Vervis. +$# +$# Written in 2016 by fr33domlover . +$# +$# ♡ 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 +$# . + +

Tag/patch selection + +

TODO + +^{changes} diff --git a/vervis.cabal b/vervis.cabal index fa03215..56219f7 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -34,7 +34,10 @@ flag library-only default: False library - exposed-modules: Darcs.Local + exposed-modules: Darcs.Local.PatchInfo.Parser + Darcs.Local.PatchInfo.Types + Darcs.Local.Repository + Data.Attoparsec.ByteString.Local Data.Binary.Local Data.ByteString.Char8.Local Data.ByteString.Local @@ -45,6 +48,7 @@ library Data.List.Local Data.Text.UTF8.Local Data.Text.Lazy.UTF8.Local + Data.Time.Clock.Local Network.SSH.Local Text.FilePath.Local Text.Jasmine.Local @@ -107,9 +111,12 @@ library TupleSections RecordWildCards build-depends: aeson - -- for parsing commands sent over SSH + -- for parsing commands sent over SSH and Darcs patch + -- metadata , attoparsec , base + -- for hex display of Darcs patch hashes + , base16-bytestring , base64-bytestring -- for Data.Binary.Local , binary @@ -123,6 +130,8 @@ library , classy-prelude-conduit , conduit , containers + -- for SHA1 hashing when parsing Darcs patch metadata + , cryptonite -- for Storage.Hashed because hashed-storage seems -- unmaintained and darcs has its own copy , darcs @@ -152,6 +161,8 @@ library , hourglass , http-conduit , http-types + -- for converting Darcs patch hash Digest to ByteString + , memory , monad-control , monad-logger , pandoc