Parsers.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Tests.Parsers (tests) where

import qualified Data.Attoparsec.ByteString      as P
import           Data.Bifunctor (first, second)
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import           Data.Git.Formats
import           Data.Git.Hash
import           Data.Git.Internal.Object
import           Data.Git.Internal.Parsers
import           Data.Git.Types
import qualified Data.Map as Map
import           Data.Semigroup
import           TestUtil

-- | Test a parser by verifying a vector of known instances and a property test.
testParser :: (Eq a, Show a, Arbitrary a)
           => TestName
           -- ^ The name of this parser
           -> P.Parser a
           -- ^ The parser to test
           -> (a -> BB.Builder)
           -- ^ The serializer paired with the parser
           -> [(ByteString, a)]
           -- ^ Known test vectors to check the parser is correct on.
           -> TestTree
testParser nm dsr ser vs = testGroup nm
 [ testVectors "known vectors"
     (\bs t -> Right t == P.parseOnly dsr bs) vs
 , testVectors "known vectors indempotence"
     (\bs t -> bs == (BL.toStrict . BB.toLazyByteString . ser $ t)) vs
 , testProperty "inverseness" $ \(val::a) ->
     Right val == (P.parseOnly dsr . BL.toStrict . BB.toLazyByteString . ser $ val)
 ]

tests :: TestTree
tests = testGroup "parsers and builders"
  [ testParser "Sha1Hex" (toHex <$> parseSha1Hex) buildSha1Hex $
      [("0c9f57564c5a5afcb2616595e38edb008ea7bb9e"
       ,"0c9f57564c5a5afcb2616595e38edb008ea7bb9e")
      ]
  , testParser "Sha1" (parseSha1) buildSha1 $
      [("\f\159WVLZZ\252\178ae\149\227\142\219\NUL\142\167\187\158"
       ,fromHex "0c9f57564c5a5afcb2616595e38edb008ea7bb9e")
      ]
  , testParser "Mode" (AM <$> parseMode) (buildMode . unAM) $
      [ ("100644", AM BlobMode)
      , ("100755", AM ExecMode)
      , ("40000" , AM TreeMode)
      , ("160000", AM SubmMode)
      , ("120000", AM LinkMode)
      , ("1"     , AM $ BareMode 1)
      , ("141321", AM $ BareMode 0o141321)
      ]
  , testParser "word32" word32 BB.word32BE .
      map (first BS.pack) $
      [ ([0x00, 0x00, 0x00, 0x00], 0)
      , ([0x0A, 0x0B, 0x0C, 0x0D], 0x0A0B0C0D)
      ]
  , testParser "word64" word64 BB.word64BE .
      map (first BS.pack) $
      [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 0x0000000000000000)
      , ([0x0A, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F, 0x01, 0x02], 0x0A0B0C0D0E0F0102)
      , ([0x00, 0x00, 0x01, 0x00, 0x00, 0x04, 0x08, 0x80], 1099511892096)
      ]
  , testVectors "skipLine" (\d r -> Right r == (P.parseOnly (skipLine *> P.takeByteString) d)) $
      [ ("This is a line\x0a", "")
      , ("This is a line\x0awith more after it", "with more after it")
      , ("This is\x0aseveral\x0alines", "several\x0alines")
      ]
  , testParser "Date" (AD <$> parseDate) (\d -> buildDate (unAD d) <> "\n") $
      [ ("1545411926 -0500\n", AD (1545411926, ascii2bytestring "-0500"))
      ]
  , testProperty "SafeString" $ \ss -> Just ss == safeString (getSS ss)
  , testParser "Contact" (second AD <$> parseContactAndDate) (buildContactAndDate . second unAD) $
      [ ("davean <davean@xkcd.com> 1545411926 -0500\n"
        ,(makeContact (ascii2bytestring "davean") (ascii2bytestring "davean@xkcd.com")
         ,AD (1545411926, ascii2bytestring "-0500")))
      ]
  , testParser "Blob" parseBlob (buildLooseObject.BlobObj)
      [ -- e69de29bb2d1d6434b8b29ae775ad8c2e48c5391
        ("blob 0\NUL", Blob mempty)
        -- c2df6dc730608e9cdf7dda3088e10d20aea0a194
      , ("blob 15\NULThis is a blob.", Blob "This is a blob.")
      ]
  , testParser "TreeEntry" parseTreeEntry buildTreeEntry $
      [ -- TODO should have test vectors
      ]
  , testParser "Tree" parseTree (buildLooseObject.TreeObj)
      [ ("\x74\x72\x65\x65\x20\x33\x35\x00\x31\x30\x30\x36\x34\x34\x20\x49" <>
         "\x6E\x69\x74\x69\x61\x6C\x00\xE6\x9D\xE2\x9B\xB2\xD1\xD6\x43\x4B" <>
         "\x8B\x29\xAE\x77\x5A\xD8\xC2\xE4\x8C\x53\x91"
        , Tree $ Map.fromList [(Entry "Initial" BlobMode, fromHex "e69de29bb2d1d6434b8b29ae775ad8c2e48c5391")])
      ]
  , testParser "ObjectType" parseObjectType buildObjType
      [ ("blob", BlobType), ("tree", TreeType), ("commit", CommitType), ("tag", TagType)]
  , testParser "Tag" parseTag (buildLooseObject.TagObj)
      [ -- TODO should have test vectors
      ]
  , testParser "Commit" parseCommit (buildLooseObject.CommitObj)
      [ -- TODO should have test vectors
      ]
  , testParser "Tag" parseTag (buildLooseObject.TagObj)
      [ -- TODO should have test vectors
      ]
  , testParser "Object" parseObject buildLooseObject []
  ]