mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-03-20 04:46:22 +09:00
345 lines
9.6 KiB
Haskell
345 lines
9.6 KiB
Haskell
{- 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)
|
|
-}
|