Darcs change log view

src/Darcs/Local/PatchInfo/Parser.hs

@@ -0,0 +1,259 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 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/>.
+ -}
+
+-- 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

src/Darcs/Local/PatchInfo/Types.hs

@@ -0,0 +1,68 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 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 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)]
+    }

src/Darcs/Local/Repository.hs

@@ -13,10 +13,8 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
-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
--}

src/Data/Attoparsec/ByteString/Local.hs

@@ -0,0 +1,38 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 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 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

src/Data/ByteString/Local.hs

@@ -13,8 +13,11 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
+{-# 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

src/Data/Time/Clock/Local.hs

@@ -0,0 +1,44 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 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 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

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

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 =

templates/repo/changes-darcs.hamlet

@@ -0,0 +1,19 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016 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/>.
+
+<h2>Tag/patch selection
+
+<p>TODO
+
+^{changes}

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