vervis/src/Darcs/Local/Inventory/Parser.hs

{- 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)
-}