forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Move DarcsRev and code we're sharing with it into a separate library

Browse source
This commit is contained in:
fr33domlover 2018-03-20 23:45:09 +00:00
parent ff5bb97383
commit abfb77479f
13 changed files with 8 additions and 1272 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
src/Darcs/Local/Hash/Codec.hs
View file

@ -1,49 +0,0 @@
{- 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.Hash.Codec
( encodePatchHash
, encodeInventoryHash
)
where
import Prelude
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import qualified Data.ByteString as B (length, replicate)
import qualified Data.ByteString.Base16 as B16 (encode)
import qualified Data.ByteString.Lex.Integral as BX (packDecimal)
import Darcs.Local.Hash.Types
encodeHash :: ByteString -> ByteString
encodeHash = B16.encode
encodeSize :: Int -> ByteString
encodeSize n =
case BX.packDecimal n of
Nothing -> error "negative size in sizehash"
Just b ->
if B.length b < 10
then B.replicate (10 - B.length b) 0x30 <> b
else b
encodePatchHash :: PatchHash -> ByteString
encodePatchHash (PatchHash h) = encodeHash h
encodeInventoryHash :: InventoryHash -> ByteString
encodeInventoryHash (InventoryHash s h) = encodeSize s <> "-" <> encodeHash h

50
src/Darcs/Local/Hash/Types.hs
View file

@ -1,50 +0,0 @@
{- 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.Hash.Types
( PatchHash (..)
, ContentHash (..)
, InventoryHash (..)
, PristineHash (..)
)
where
import Prelude
import Data.ByteString (ByteString)
-- | A SHA1 hash of the patch info (author, title, description including junk,
-- timestamp). The hash is in binary form, not hex, i.e. its size is always 20
-- bytes.
newtype PatchHash = PatchHash { unPatchHash :: ByteString }
-- | Content size and SHA256 hash of a patch's info and content. The hash is in
-- binary form, not hex, i.e. its size is always 32 bytes.
data ContentHash = ContentHash
{ chSize :: Int
, chHash :: ByteString
}
-- | Content size and SHA256 hash of an inventory (a patch set in a single
-- invetory file). The hash is in binary form, not hex, i.e. its size is always
-- 32 bytes.
data InventoryHash = InventoryHash
{ ihSize :: Int
, ihHash :: ByteString
}
-- | A SHA256 hash of the entire recorded state of the repo. The hash is in
-- binary form, not hex, i.e. its size is always 32 bytes.
newtype PristineHash = PristineHash { unPristineHash :: ByteString }

345
src/Darcs/Local/Inventory/Parser.hs
View file

@ -1,345 +0,0 @@
{- 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.Inventory.Parser
( latestInventoryPristineP
, latestInventorySizeP
, latestInventoryPrevSizeP
, latestInventoryPageP
, latestInventoryAllP
, earlyInventorySizeP
, earlyInventoryPrevSizeP
, earlyInventoryPageP
, earlyInventoryAllP
)
where
import Prelude hiding (take, takeWhile)
import Control.Applicative (many, optional, liftA2)
import Control.Arrow (second)
import Control.Monad (replicateM_)
import Crypto.Hash
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 Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lex.Integral as BX
import Control.Applicative.Local
import Darcs.Local.Hash.Types
import Darcs.Local.Inventory.Types
import Darcs.Local.Patch
import Darcs.Local.Patch.Types
import Data.Attoparsec.ByteString.Local
import Data.ByteString.Local (stripPrefix)
import Data.Text.UTF8.Local (decodeStrict)
lf :: Word8
lf = 10
space :: Word8
space = 32
star :: Word8
star = 42
dash :: Word8
dash = 45
zero :: Word8
zero = 48
nine :: Word8
nine = 57
sqrOpen :: Word8
sqrOpen = 91
--sqrClose :: Word8
--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
hours <- decimal2P
minutes <- decimal2P
seconds <- decimal2P
case fromGregorianValid year month day of
Nothing -> fail "Invalid patch date"
Just uday -> return UTCTime
{ utctDay = uday
, utctDayTime =
secondsToDiffTime $ 3600 * hours + 60 * minutes + seconds
}
line :: Parser ByteString
line = restOfLine
restOfLine :: Parser ByteString
restOfLine = takeWhile (/= lf)
eol :: Parser ()
eol = skip (== lf)
skipLine :: Parser ()
skipLine = skipWhile (/= lf)
skipRestOfLine :: Parser ()
skipRestOfLine = skipLine
skipPatchP :: Parser ()
skipPatchP =
-- title
skipLine *> eol *>
-- author, inverted, time
skipLine *> eol *>
-- ignore, description
(skipMany $ skip (== space) *> skipRestOfLine *> eol) *>
-- end of info
(string "] \n") *>
-- hash
skipLine
sha256P :: Parser ByteString
sha256P = do
bs <- take 64
case second B.null $ B16.decode bs of
(h, True) -> return h
_ -> fail "SHA256 decoding from hex failed"
sizeP :: Parser Int
sizeP = do
bs <- take 10
case second B.null <$> BX.readDecimal bs of
Just (n, True) -> return n
_ -> fail "sizeP failed"
sizeSha256P :: Parser (Int, ByteString)
sizeSha256P = liftA2 (,) sizeP (skip (== dash) *> sha256P)
pristineP :: Parser PristineHash
pristineP = string "pristine:" *> (PristineHash <$> sha256P)
prevInvP :: Parser InventoryHash
prevInvP =
string "Starting with inventory" *> eol *>
(uncurry InventoryHash <$> sizeSha256P)
patchInfoRawP :: Parser PatchInfoRaw
patchInfoRawP = do
word8 sqrOpen
title <- takeWhile1 (/= lf)
eol
author <- takeWhile1 (/= star)
word8 star
inverted <- (/= star) <$> (satisfy $ \ c -> c == star || c == dash)
(timeRaw, time) <- match patchTimeP
eol
word8 space
junkp <- string "Ignore-this: "
junkc <- takeWhile1 (/= lf)
eol
lines <- many $ word8 space *> takeWhile (/= lf) <* eol
string "] \nhash: "
hash <- sizeSha256P
return PatchInfoRaw
{ pirAuthor = author
, pirHash = hash
, pirTitle = title
, pirDescription = lines
, pirJunkPrefix = junkp
, pirJunkContent = junkc
, pirTime = (timeRaw, time)
, pirInverted = inverted
}
-- TODO
--
-- * Finish DarcsRev code, make it build
-- * Update darcs change view code to work correctly in the case of previous
-- inventories, test vervis against libravatar for that
-- | Parse patch metadata and compute the metadata's hash, which can be used as
-- a patch identifier for lookup and matching.
patchInfoP :: Parser (PatchInfo, PatchHash)
patchInfoP = do
pir <- patchInfoRawP
return (refinePatchInfo pir, PatchHash $ convert $ hashPatchInfo SHA1 pir)
tagInfoP :: Parser (TagInfo, PatchHash)
tagInfoP = do
(pi, ph) <- patchInfoP
case patchToTag pi of
Nothing -> fail "Expected a tag, got a patch that isn't a tag"
Just ti -> return (ti, ph)
-------------------------------------------------------------------------------
-- Latest inventory
-------------------------------------------------------------------------------
latestInventoryPristineP :: Parser PristineHash
latestInventoryPristineP = pristineP
latestInventorySizeP :: Parser Int
latestInventorySizeP =
-- pristine hash
skipLine *>
-- previous inventory
optional
( eol *> string "Starting" *> skipRestOfLine *>
eol *> skipLine
) *>
-- patch info
(length <$> many (eol *> skipPatchP)) <*
eol
latestInventoryPrevSizeP :: Parser (Maybe InventoryHash, Int)
latestInventoryPrevSizeP =
liftA2 (,)
( -- pristine hash
skipLine *>
-- previous inventory
optional (eol *> prevInvP)
)
( -- patch info
(length <$> many (eol *> skipPatchP)) <*
eol
)
latestInventoryPageP
:: Int -> Int -> Parser (Maybe InventoryHash, [(PatchInfo, PatchHash)])
latestInventoryPageP off lim =
let f mPrevTag pis =
case mPrevTag of
Nothing -> (Nothing, pis)
Just (ih, pi) -> (Just ih, pi : pis)
in liftA2 f
-- pristine
( skipLine *>
-- previous inventory and clean tag
optional (liftA2 (,) (eol *> prevInvP) (eol *> patchInfoP)) <*
-- skip offset
replicateM_ off (eol *> skipPatchP)
)
-- take limit
(atMost lim $ eol *> patchInfoP)
latestInventoryAllP :: Parser LatestInventory
latestInventoryAllP = LatestInventory
<$> pristineP
<*> optional (liftA2 (,) (eol *> prevInvP) (eol *> tagInfoP))
<*> many (eol *> patchInfoP)
<* eol
-------------------------------------------------------------------------------
-- Early inventory
-------------------------------------------------------------------------------
earlyInventorySizeP :: Parser Int
earlyInventorySizeP =
-- previous inventory
optional
( string "Starting" *> skipRestOfLine *>
eol *> skipLine
) *>
-- patch info
(length <$> many (eol *> skipPatchP)) <*
eol
earlyInventoryPrevSizeP :: Parser (Maybe InventoryHash, Int)
earlyInventoryPrevSizeP =
liftA2 (,)
-- previous inventory
(optional $ prevInvP <* eol)
-- patch info
(length <$> many (skipPatchP *> eol))
earlyInventoryPageP
:: Int -> Int -> Parser (Maybe InventoryHash, [(PatchInfo, PatchHash)])
earlyInventoryPageP off lim =
let f mPrevTag pis =
case mPrevTag of
Nothing -> (Nothing, pis)
Just (ih, pi) -> (Just ih, pi : pis)
in liftA2 f
-- previous inventory and clean tag
( optional (liftA2 (,) (prevInvP <* eol) (patchInfoP <* eol)) <*
-- skip offset
replicateM_ off (skipPatchP *> eol)
)
-- take limit
(atMost lim $ patchInfoP <* eol)
earlyInventoryAllP :: Parser (Either EarliestInventory MiddleInventory)
earlyInventoryAllP =
let f Nothing pis = Left $ EarliestInventory pis
f (Just (prev, ti)) pis = Right $ MiddleInventory prev ti pis
in liftA2 f
(optional $ liftA2 (,) (prevInvP <* eol) (tagInfoP <* eol))
(many (patchInfoP <* eol))
{-
patchInfosOffsetP :: Int -> Parser PatchSeq
patchInfosOffsetP off = PatchSeq
<$> pristineP
<*> optional (eol *> prevInvP)
<*> ( replicateM_ off (eol *> skipPatchP) *>
many (eol *> patchInfoP)
)
<* eol
patchInfosLimitP :: Int -> Parser PatchSeq
patchInfosLimitP lim = PatchSeq
<$> pristineP
<*> optional (eol *> prevInvP)
<*> atMost lim (eol *> patchInfoP)
-}

96
src/Darcs/Local/Inventory/Read.hs
View file

@ -1,96 +0,0 @@
{- 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.Inventory.Read
( readLatestInventory
, readCompressedInventory
)
where
import Prelude
import Codec.Compression.Zlib.Internal
import Control.Applicative (many, optional, liftA2)
import Control.Arrow (second)
import Control.Monad (replicateM_)
import Crypto.Hash
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 Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lex.Integral as BX
import Control.Applicative.Local
import Darcs.Local.Hash.Codec
import Darcs.Local.Hash.Types
import Darcs.Local.Inventory.Parser
import Darcs.Local.Inventory.Types
import Data.Attoparsec.ByteString.Local
import Data.ByteString.Local (stripPrefix)
import Data.Text.UTF8.Local (decodeStrict)
darcsDir :: FilePath
darcsDir = "_darcs"
inventoryDir :: FilePath
inventoryDir = "inventories"
inventoryFile :: FilePath
inventoryFile = "hashed_inventory"
readLatestInventory :: FilePath -> Parser a -> IO (Either String a)
readLatestInventory repo =
parseFileIncremental $ repo </> darcsDir </> inventoryFile
readCompressedInventory
:: FilePath -> InventoryHash -> Parser a -> IO (Either String a)
readCompressedInventory repo ih =
let invFile = BC.unpack $ encodeInventoryHash ih
invPath = repo </> darcsDir </> inventoryDir </> invFile
defParams = defaultDecompressParams
bufSize = min (decompressBufferSize defParams) (ihSize ih)
params = defParams { decompressBufferSize = bufSize }
in parseCompressedFileIncremental gzipFormat params invPath
{-
readLatestInventorySize :: FilePath -> IO (Either String Int)
readLatestInventoryAll :: FilePath -> IO (Either String LatestInventory)
readLatestInventoryPage
:: Int -> Int -> FilePath -> IO (Either String LatestInventory)
readInventorySize :: FilePath -> IO (Either String Int)
readInventorySize repoPath = do
let invPath = repoPath </> darcsDir </> inventoryFile
parseFileIncremental invPath $ patchInfosCountP <* endOfInput
readPatchInfoAll :: FilePath -> IO (Either String PatchSeq)
readPatchInfoAll repoPath = do
let invPath = repoPath </> darcsDir </> inventoryFile
parseFileIncremental invPath $ patchInfosAllP <* endOfInput
readPatchInfoPage :: Int -> Int -> FilePath -> IO (Either String PatchSeq)
readPatchInfoPage off lim repoPath = do
let invPath = repoPath </> darcsDir </> inventoryFile
parseFileIncremental invPath $ patchInfosOffsetLimitP off lim
-}

74
src/Darcs/Local/Inventory/Types.hs
View file

@ -1,74 +0,0 @@
{- 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.Inventory.Types
( LatestInventory (..)
, MiddleInventory (..)
, EarliestInventory (..)
)
where
-- TODO
--
-- Apparently, after a while, some of the patches are moved from
-- hashed_inventory into the inventories/ dir. So the patch set contains more
-- than one group. This means I need to extend my parser to cover this case.
-- Sources for info about this thing:
--
-- * Darcs source code
-- * Darcs wiki
-- * Local Darcs repos I have
--
-- From Darcs source code:
--
-- > The patches in a repository are stored in chunks broken up at \"clean\"
-- > tags. A tag is clean if the only patches before it in the current
-- > repository ordering are ones that the tag depends on (either directly
-- > or indirectly). Each chunk is stored in a separate inventory file on disk.
-- >
-- > A 'PatchSet' represents a repo's history as the list of patches since the
-- > last clean tag, and then a list of patch lists each delimited by clean tags.
-- >
-- > A 'Tagged' is a single chunk of a 'PatchSet'. It has a 'PatchInfo'
-- > representing a clean tag, the hash of the previous inventory (if it exists),
-- > and the list of patches since that previous inventory.
--
-- Let's start with finding out the format of the binary inventories and
-- parsing them.
import Prelude
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Darcs.Local.Hash.Types
import Darcs.Local.Patch.Types
data LatestInventory = LatestInventory
{ liPristineHash :: PristineHash
, liPrevTag :: Maybe (InventoryHash, (TagInfo, PatchHash))
, liPatches :: [(PatchInfo, PatchHash)]
}
data MiddleInventory = MiddleInventory
{ miPrevious :: InventoryHash
, miTag :: (TagInfo, PatchHash)
, miPatches :: [(PatchInfo, PatchHash)]
}
newtype EarliestInventory = EarliestInventory
{ eiPatches :: [(PatchInfo, PatchHash)]
}

107
src/Darcs/Local/Patch.hs
View file

@ -1,107 +0,0 @@
{- 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.Patch
( hashPatchInfo
, refinePatchInfo
, tagToPatch
, patchToTag
, patchToTag_
)
where
import Prelude hiding (take, takeWhile)
import Control.Applicative (many, optional, liftA2)
import Control.Arrow (second)
import Control.Monad (replicateM_)
import Crypto.Hash
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 Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lex.Integral as BX
import Control.Applicative.Local
import Darcs.Local.Hash.Types
import Darcs.Local.Inventory.Types
import Darcs.Local.Patch.Types
import Data.Attoparsec.ByteString.Local
import Data.ByteString.Local (stripPrefix)
import Data.Text.UTF8.Local (decodeStrict)
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 = uncurry ContentHash $ pirHash pir
, piTitle = decodeStrict title
, piDescription = decodeStrict <$> description
, piTag = tag
, piTime = snd $ pirTime pir
}
tagToPatch :: TagInfo -> PatchInfo
tagToPatch tag = PatchInfo
{ piAuthor = tiAuthor tag
, piHash = tiHash tag
, piTitle = tiTitle tag
, piDescription = tiDescription tag
, piTag = True
, piTime = tiTime tag
}
patchToTag :: PatchInfo -> Maybe TagInfo
patchToTag pi =
if piTag pi
then Just $ patchToTag_ pi
else Nothing
patchToTag_ :: PatchInfo -> TagInfo
patchToTag_ patch = TagInfo
{ tiAuthor = piAuthor patch
, tiHash = piHash patch
, tiTitle = piTitle patch
, tiDescription = piDescription patch
, tiTime = piTime patch
}

72
src/Darcs/Local/Patch/Types.hs
View file

@ -1,72 +0,0 @@
{- 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.Patch.Types
( PatchInfoRaw (..)
, PatchInfo (..)
, TagInfo (..)
)
where
import Prelude
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Darcs.Local.Hash.Types (ContentHash)
-- | Patch metadata in raw form. This is intended for accurate hashing of the
-- patch info.
data PatchInfoRaw = PatchInfoRaw
{ pirAuthor :: ByteString
, pirHash :: (Int, 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
-- | Patch content hash
, piHash :: ContentHash
-- | 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
}
-- | Tag metadata read from the inventory file.
data TagInfo = TagInfo
{ -- | Author name and email
tiAuthor :: Text
-- | Tag content hash
, tiHash :: ContentHash
-- | Single message line
, tiTitle :: Text
-- | Optional description, may contain several lines
, tiDescription :: Maybe Text
-- | When the tag was recorded
, tiTime :: UTCTime
}

54
src/Data/Revision/Local.hs
View file

@ -1,54 +0,0 @@
{- 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.Revision.Local
( Change (..)
, Revision (..)
, Version (..)
)
where
import Prelude
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
-- | A recorded patch or tag.
data Change = Change
{ -- | When it was recorded.
cgTime :: UTCTime
-- | Lowercase hex representation of its SHA1 info hash.
, cgHash :: Text
-- | Single-line title.
, cgTitle :: Text
}
-- | Given a non-empty repo, this refers to a point in its history.
data Revision
-- | The last change is a tag.
= RevTag Change
-- | The last change isn't a tag, but a tag exists earlier in the history.
-- Specifies details of the last tag, the number of patches after that tag,
-- and details of the last patch.
| RevTagPlus Change Int Change
-- | There are no recorded tags. Specifies the last patch.
| RevPatch Change
data Version = Version
{ verSharer :: Text
, verRepo :: Text
, verChanges :: Int
, verRevision :: Revision
}

409
src/Development/DarcsRev.hs
View file

@ -1,409 +0,0 @@
{- 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/>.
-}
{-# LANGUAGE CPP #-}
module Development.DarcsRev
( -- * Simple literals
-- ** Last patch
darcsLastPatchHash
, darcsLastPatchHash_
, darcsLastPatchTime
, darcsLastPatchTime_
, darcsLastPatchTitle
, darcsLastPatchTitle_
, darcsLastPatchIsTag
, darcsLastPatchIsTag_
-- ** Last tag
, darcsTagExists
, darcsLastTagHash
, darcsLastTagHash_
, darcsLastTagTime
, darcsLastTagTime_
, darcsLastTagName
, darcsLastTagName_
-- ** Other revision info
, darcsPatchesSinceLastTag
, darcsBranchSharer
, darcsBranchRepo
, darcsTotalPatches
, darcsTreeDirty
-- * Records
-- ** Last patch
, darcsLastPatch
, darcsLastPatch_
-- ** Last tag
, darcsLastTag
, darcsLastTag_
-- ** Revision
, darcsRevision
, darcsRevision_
)
where
import Prelude
import Data.Fixed
import Data.Foldable (find)
import Data.List (sortOn)
import Data.Maybe (listToMaybe)
import Data.Ord (Down (..))
import Data.Time
import Language.Haskell.TH
import qualified Data.ByteString.Char8 as BC (unpack)
import qualified Data.Text as T (unpack)
import Darcs.Local.Hash.Codec
import Darcs.Local.Hash.Types
import Darcs.Local.Patch
import Darcs.Local.Patch.Types
import Darcs.Local.Inventory.Parser
import Darcs.Local.Inventory.Read
import Darcs.Local.Inventory.Types
import Data.Revision.Local
-- TODO
--
-- * Number of patches since latest tag
-- * Branch name, basically the <user>/<repo> thing. This allows to identify
-- which "darcs branch" is being used
-- * Whether there are unrecorded changes to tracked files
-------------------------------------------------------------------------------
-- Utils
-------------------------------------------------------------------------------
repoPath :: FilePath
repoPath = "."
readLatestInv :: Q [(PatchInfo, PatchHash)]
readLatestInv = runIO $ do
einv <- readLatestInventory repoPath latestInventoryAllP
case einv of
Left err -> error $ "Failed to parse Darcs inventory file: " ++ err
Right inv -> return $
case snd <$> liPrevTag inv of
Nothing -> liPatches inv
Just (tag, h) -> (tagToPatch tag, h) : liPatches inv
readLastPatch :: Q (Maybe (PatchInfo, PatchHash))
readLastPatch = listToMaybe . sortOn (Down . piTime . fst) <$> readLatestInv
readLastPatch_ :: Q (PatchInfo, PatchHash)
readLastPatch_ = do
mp <- readLastPatch
case mp of
Nothing -> fail "Couldn't read last patch, repo seems empty"
Just p -> return p
readLastTag :: Q (Maybe (PatchInfo, PatchHash))
readLastTag =
listToMaybe . sortOn (Down . piTime . fst) . filter (piTag . fst) <$>
readLatestInv
readLastTag_ :: Q (PatchInfo, PatchHash)
readLastTag_ = do
mp <- readLastTag
case mp of
Nothing -> fail "Couldn't read last tag, repo seems to have no tags"
Just p -> return p
darcsHash :: Q PatchHash -> Q Exp
darcsHash readHash = readHash >>= stringE . BC.unpack . encodePatchHash
darcsTime :: Q PatchInfo -> Q Exp
darcsTime readPI = do
pi <- readPI
let UTCTime (ModifiedJulianDay day) diff' = piTime pi
#if MIN_VERSION_time(1,6,0)
diff = diffTimeToPicoseconds diff'
#else
diff =
let MkFixed pico = realToFrac diff' :: Pico
in pico
#endif
recConE 'UTCTime
[ fieldExp
'utctDay
(appE (conE 'ModifiedJulianDay) (litE $ integerL day))
, fieldExp
'utctDayTime
(appE (varE 'picosecondsToDiffTime) (litE $ integerL diff))
]
darcsTitle :: Q PatchInfo -> Q Exp
darcsTitle readPI = readPI >>= stringE . T.unpack . piTitle
darcsIsTag :: Q PatchInfo -> Q Exp
darcsIsTag readPI = do
pi <- readPI
conE $ if piTag pi then 'True else 'False
darcsPatch :: Q (PatchInfo, PatchHash) -> Q Exp
darcsPatch readPH = do
(pi, h) <- readPH
recConE 'Change
[ fieldExp 'cgTime (darcsTime $ return pi)
, fieldExp 'cgHash (darcsHash $ return h)
, fieldExp 'cgTitle (darcsTitle $ return pi)
]
darcsRev :: (PatchInfo, PatchHash) -> [(PatchInfo, PatchHash)] -> Q Exp
darcsRev piLast piRest =
case break (piTag . fst) (piLast : piRest) of
(_, []) -> appE (conE 'RevPatch) (darcsPatch $ return piLast)
([], (tag:_)) -> appE (conE 'RevTag) (darcsPatch $ return tag)
(after, (tag:_)) ->
appsE
[ conE 'RevTagPlus
, darcsPatch $ return tag
, litE $ integerL $ toInteger $ length after
, darcsPatch $ return piLast
]
fmapMaybeTH :: (Q a -> Q Exp) -> Q (Maybe a) -> Q Exp
fmapMaybeTH f a = do
mr <- a
case mr of
Nothing -> conE 'Nothing
Just r -> appE (conE 'Just) (f $ return r)
-------------------------------------------------------------------------------
-- Simple literals
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- -- Last patch
-------------------------------------------------------------------------------
-- | The ASCII lowercase hexadecimal representation of the hash of the last
-- recorded patch, as a string literal. This the SHA256 patch hash, i.e. a hash
-- of the patch info, not content. This is what @darcs log@ displays.
--
-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the
-- string literal.
darcsLastPatchHash :: Q Exp
darcsLastPatchHash = fmapMaybeTH darcsHash $ fmap snd <$> readLastPatch
-- | The ASCII lowercase hexadecimal representation of the hash of the last
-- recorded patch, as a string literal. This the SHA256 patch hash, i.e. a hash
-- of the patch info, not content. This is what @darcs log@ displays.
--
-- If the repository is empty, this will fail during compilation.
darcsLastPatchHash_ :: Q Exp
darcsLastPatchHash_ = darcsHash $ snd <$> readLastPatch_
-- | The time of the last recorded patch, as a 'UTCTime' value.
--
-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the
-- 'UTCTime' value.
darcsLastPatchTime :: Q Exp
darcsLastPatchTime = fmapMaybeTH darcsTime $ fmap fst <$> readLastPatch
-- | The time of the last recorded patch, as a 'UTCTime' value.
--
-- If the repository is empty, this will fail during compilation.
darcsLastPatchTime_ :: Q Exp
darcsLastPatchTime_ = darcsTime $ fst <$> readLastPatch_
-- | The title of the last recorded patch, as a string literal.
--
-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the
-- string literal.
darcsLastPatchTitle :: Q Exp
darcsLastPatchTitle = fmapMaybeTH darcsTitle $ fmap fst <$> readLastPatch
-- | The title of the last recorded patch, as a string literal.
--
-- If the repository is empty, this will fail during compilation.
darcsLastPatchTitle_ :: Q Exp
darcsLastPatchTitle_ = darcsTitle $ fst <$> readLastPatch_
-- | A 'Bool' saying whether the last recorded patch is actually a tag.
--
-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the
-- 'Bool' value.
darcsLastPatchIsTag :: Q Exp
darcsLastPatchIsTag = fmapMaybeTH darcsIsTag $ fmap fst <$> readLastPatch
-- | A 'Bool' saying whether the last recorded patch is actually a tag.
--
-- If the repository is empty, this will fail during compilation.
darcsLastPatchIsTag_ :: Q Exp
darcsLastPatchIsTag_ = darcsIsTag $ fst <$> readLastPatch_
-------------------------------------------------------------------------------
-- -- Last tag
-------------------------------------------------------------------------------
-- | Whether the repo history contains any tags, as a 'Bool' value.
darcsTagExists :: Q Exp
darcsTagExists = do
pis <- readLatestInv
conE $ if any (piTag . fst) pis
then 'True
else 'False
-- | The ASCII lowercase hexadecimal representation of the hash of the last
-- recorded tag (i.e. the last patch that is a tag).
--
-- If the repository has no tags, this generates 'Nothing', otherwise 'Just'
-- the string literal.
darcsLastTagHash :: Q Exp
darcsLastTagHash = fmapMaybeTH darcsHash $ fmap snd <$> readLastTag
-- | The ASCII lowercase hexadecimal representation of the hash of the last
-- recorded tag (i.e. the last patch that is a tag).
--
-- If the repository has no tags, this will fail during compilation.
darcsLastTagHash_ :: Q Exp
darcsLastTagHash_ = darcsHash $ snd <$> readLastTag_
-- | The time of the last recorded tag, as a 'UTCTime' value.
--
-- If the repository has no tags, this generates 'Nothing', otherwise 'Just'
-- the 'UTCTime' value.
darcsLastTagTime :: Q Exp
darcsLastTagTime = fmapMaybeTH darcsTime $ fmap fst <$> readLastTag
-- | The time of the last recorded tag, as a 'UTCTime' value.
--
-- If the repository has no tags, this will fail during compilation.
darcsLastTagTime_ :: Q Exp
darcsLastTagTime_ = darcsTime $ fst <$> readLastTag_
-- | The name of the last recorded tag, as a string literal. This is a result
-- of taking the title of the tag and dropping the @"TAG "@ prefix.
--
-- If the repository has no tags, this generates 'Nothing', otherwise 'Just'
-- the string literal.
darcsLastTagName :: Q Exp
darcsLastTagName = fmapMaybeTH darcsTitle $ fmap fst <$> readLastTag
-- | The name of the last recorded tag, as a string literal. This is a result
-- of taking the title of the tag and dropping the @"TAG "@ prefix.
--
-- If the repository has no tags, this will fail during compilation.
darcsLastTagName_ :: Q Exp
darcsLastTagName_ = darcsTitle $ fst <$> readLastTag_
-------------------------------------------------------------------------------
-- -- Other revision info
-------------------------------------------------------------------------------
-- | Number of patches recorded after the last tag, as a number literal. If
-- there's no tag found, the number is (-1).
darcsPatchesSinceLastTag :: Q Exp
darcsPatchesSinceLastTag = do
pisAll <- sortOn (Down . piTime . fst) <$> readLatestInv
case break (piTag . fst) pisAll of
(_, []) -> litE $ integerL (-1)
(pisAfter, (_tag : _pisBefore)) ->
litE $ integerL $ toInteger $ length pisAfter
-- | Not implemented yet
darcsBranchSharer :: Q Exp
darcsBranchSharer = undefined
-- | Not implemented yet
darcsBranchRepo :: Q Exp
darcsBranchRepo = undefined
-- | Total number of recorded patches.
darcsTotalPatches :: Q Exp
darcsTotalPatches = do
let go Nothing n = return n
go (Just ih) n = do
einv <- readCompressedInventory repoPath ih earlyInventoryPrevSizeP
case einv of
Left err -> error $ "Failed to parse inventory: " ++ err
Right (mih, m) -> go mih $ n + m
nPatches <- runIO $ do
einv <- readLatestInventory repoPath latestInventoryPrevSizeP
case einv of
Left err -> error $ "Failed to parse latest inventory: " ++ err
Right (mih, n) -> go mih n
litE $ integerL $ toInteger nPatches
-- | Not implemented yet
darcsTreeDirty :: Q Exp
darcsTreeDirty = undefined
-------------------------------------------------------------------------------
-- Records
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- -- Last patch
-------------------------------------------------------------------------------
-- | The time, hash and title of the last patch, as a 'Change' value.
--
-- If the repository is empty, this generates 'Nothing', otherwise 'Just' the
-- 'Change' value.
darcsLastPatch :: Q Exp
darcsLastPatch = fmapMaybeTH darcsPatch readLastPatch
-- | The time, hash and title of the last patch, as a 'Change' value.
--
-- If the repository is empty, this will fail during compilation.
darcsLastPatch_ :: Q Exp
darcsLastPatch_ = darcsPatch readLastPatch_
-------------------------------------------------------------------------------
-- -- Last tag
-------------------------------------------------------------------------------
-- | The time, hash and title of the last tag, as a 'Change' value.
--
-- If the repository has no tags, this generates 'Nothing', otherwise 'Just'
-- the 'Change' value.
darcsLastTag :: Q Exp
darcsLastTag = fmapMaybeTH darcsPatch readLastTag
-- | The time, hash and title of the last tag, as a 'Change' value.
--
-- If the repository has no tags, this will fail during compilation.
darcsLastTag_ :: Q Exp
darcsLastTag_ = darcsPatch readLastTag_
-------------------------------------------------------------------------------
-- -- Revision
-------------------------------------------------------------------------------
-- | Representation of the current revision as a 'Revision' value. Generates
-- 'Nothing' if the repo is empty, otherwise 'Just' the value.
--
-- * If there are no tags in the repo, it gives you the last patch details.
-- * If the last patch is a tag, it gives you its details.
-- * If there is a tag but it isn't the last patch, it gives you details of the
-- last lag, the last patch, and how many patches there are after the last
-- tag.
darcsRevision :: Q Exp
darcsRevision = do
pis <- sortOn (Down . piTime . fst) <$> readLatestInv
case pis of
[] -> conE 'Nothing
(l:r) -> appE (conE 'Just) $ darcsRev l r
-- | Representation of the current revision as a 'Revision' value. If the
-- repo is empty, fails during compilation.
darcsRevision_ :: Q Exp
darcsRevision_ = do
pis <- sortOn (Down . piTime . fst) <$> readLatestInv
case pis of
[] -> fail "Repo has no patches, can't determine revision"
(l:r) -> darcsRev l r

10
src/Vervis/Darcs.hs
View file

@ -35,6 +35,11 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (strictDecode)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import Data.Traversable (for)
import Development.Darcs.Internal.Hash.Codec
import Development.Darcs.Internal.Inventory.Parser
import Development.Darcs.Internal.Inventory.Read
import Development.Darcs.Internal.Inventory.Types
import Development.Darcs.Internal.Patch.Types
import System.FilePath ((</>))
import qualified Data.ByteString.Lazy as BL (ByteString)
@ -42,11 +47,6 @@ 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.Hash.Codec
import Darcs.Local.Inventory.Parser
import Darcs.Local.Inventory.Read
import Darcs.Local.Inventory.Types
import Darcs.Local.Patch.Types
import Darcs.Local.Repository
import Data.Either.Local (maybeRight)
import Data.EventTime.Local

3
src/Vervis/Widget.hs
View file

@ -26,14 +26,13 @@ import Prelude
import Data.Text (Text)
import Data.Time.Calendar (toGregorian)
import Data.Time.Clock (UTCTime (..))
import Development.Darcs.Rev
import Formatting (sformat, (%), int, left)
import Yesod.Core (YesodBreadcrumbs, breadcrumbs)
import Yesod.Core.Widget
import qualified Data.Text as T (take)
import Data.Revision.Local
import Development.DarcsRev (darcsTotalPatches, darcsRevision)
import Vervis.Avatar (getAvatarUrl)
import Vervis.Settings (widgetFile)
import Vervis.Style

1
stack.yaml
View file

@ -8,6 +8,7 @@ resolver: lts-6.5
# Local packages, usually specified by relative directory name
packages:
- '.'
- '../darcs-rev'
- '../ssh'
- '../hit-graph'
- '../hit-harder'

10
vervis.cabal
View file

@ -40,13 +40,6 @@ flag library-only
library
exposed-modules: Control.Applicative.Local
Darcs.Local.Hash.Codec
Darcs.Local.Hash.Types
Darcs.Local.Inventory.Parser
Darcs.Local.Inventory.Read
Darcs.Local.Inventory.Types
Darcs.Local.Patch
Darcs.Local.Patch.Types
Darcs.Local.Repository
Data.Attoparsec.ByteString.Local
Data.Binary.Local
@ -68,7 +61,6 @@ library
Data.List.Local
Data.Maybe.Local
Data.Paginate.Local
Data.Revision.Local
Data.Text.UTF8.Local
Data.Text.Lazy.UTF8.Local
Data.Time.Clock.Local
@ -88,7 +80,6 @@ library
Database.Persist.Local.Sql
Database.Persist.Local.Sql.Orphan.Common
Database.Persist.Local.Sql.Orphan.PersistQueryForest
Development.DarcsRev
Diagrams.IntransitiveDAG
Formatting.CaseInsensitive
Network.SSH.Local
@ -232,6 +223,7 @@ library
-- for Storage.Hashed because hashed-storage seems
-- unmaintained and darcs has its own copy
, darcs
, darcs-rev
, data-default
-- for Data.Paginate.Local
, data-default-class