{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module StreamPatch.Patch.Compare where
import GHC.Generics ( Generic )
import Data.Data ( Typeable, Data )
import Numeric.Natural
import Data.ByteString qualified as BS
import Data.Text qualified as Text
import Data.Text ( Text )
import Data.Void
import Control.Monad ( void )
import GHC.Exts ( Proxy#, proxy# )
import GHC.TypeLits ( KnownSymbol, symbolVal' )
import Binrep.Extra.HexByteString
import Data.Aeson qualified as Aeson
import Data.Aeson ( ToJSON(..), FromJSON(..) )
import Text.Megaparsec
import Text.Megaparsec.Char qualified as MC
import Text.Megaparsec.Char.Lexer qualified as MCL
import BLAKE3 qualified as B3
import Data.ByteArray qualified as BA
import Data.ByteString qualified as B
import Data.Word ( Word8 )
import Data.Singletons.TH
import Prelude.Singletons hiding ( AbsSym0, Compare )
import Data.Singletons.Base.TH ( FromString, sFromString )
$(singletons [d|
data EqualityCheck
= Exact
| PrefixOf
deriving stock (Show, Eq)
|])
deriving stock instance Generic EqualityCheck
deriving stock instance Typeable EqualityCheck
deriving stock instance Data EqualityCheck
$(singletons [d|
data HashFunc
= B3
| SHA256
| MD5
deriving stock (Show, Eq)
|])
deriving stock instance Generic HashFunc
deriving stock instance Typeable HashFunc
deriving stock instance Data HashFunc
$(singletons [d|
data Via
= ViaEq EqualityCheck
| ViaSize
| ViaDigest HashFunc
deriving stock (Show, Eq)
|])
deriving stock instance Generic Via
deriving stock instance Typeable Via
deriving stock instance Data Via
data Meta (v :: Via) a = Meta
{ forall (v :: Via) a. Meta v a -> Maybe (CompareRep v a)
mCompare :: Maybe (CompareRep v a)
} deriving stock ((forall x. Meta v a -> Rep (Meta v a) x)
-> (forall x. Rep (Meta v a) x -> Meta v a) -> Generic (Meta v a)
forall x. Rep (Meta v a) x -> Meta v a
forall x. Meta v a -> Rep (Meta v a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: Via) a x. Rep (Meta v a) x -> Meta v a
forall (v :: Via) a x. Meta v a -> Rep (Meta v a) x
$cto :: forall (v :: Via) a x. Rep (Meta v a) x -> Meta v a
$cfrom :: forall (v :: Via) a x. Meta v a -> Rep (Meta v a) x
Generic)
deriving stock instance Eq (CompareRep v a) => Eq (Meta v a)
deriving stock instance Show (CompareRep v a) => Show (Meta v a)
deriving anyclass instance ToJSON (CompareRep v a) => ToJSON (Meta v a)
deriving anyclass instance FromJSON (CompareRep v a) => FromJSON (Meta v a)
instance SingI v => Functor (Meta v) where
fmap :: forall a b. (a -> b) -> Meta v a -> Meta v b
fmap a -> b
f (Meta Maybe (CompareRep v a)
c) = case forall {k} (a :: k). SingI a => Sing a
forall (a :: Via). SingI a => Sing a
sing @v of
SViaEq Sing n
_ -> Maybe (CompareRep v b) -> Meta v b
forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta (Maybe (CompareRep v b) -> Meta v b)
-> Maybe (CompareRep v b) -> Meta v b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe a
Maybe (CompareRep v a)
c
Sing v
SVia v
SViaSize -> Maybe (CompareRep v b) -> Meta v b
forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
Maybe (CompareRep v b)
c
SViaDigest Sing n
_ -> Maybe (CompareRep v b) -> Meta v b
forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
Maybe (CompareRep v b)
c
instance SingI v => Foldable (Meta v) where
foldMap :: forall m a. Monoid m => (a -> m) -> Meta v a -> m
foldMap a -> m
f (Meta Maybe (CompareRep v a)
c) = case forall {k} (a :: k). SingI a => Sing a
forall (a :: Via). SingI a => Sing a
sing @v of
SViaEq Sing n
_ -> (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Maybe a
Maybe (CompareRep v a)
c
Sing v
SVia v
SViaSize -> m
forall a. Monoid a => a
mempty
SViaDigest Sing n
_ -> m
forall a. Monoid a => a
mempty
instance SingI v => Traversable (Meta v) where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Meta v a -> f (Meta v b)
traverse a -> f b
f (Meta Maybe (CompareRep v a)
c) = case forall {k} (a :: k). SingI a => Sing a
forall (a :: Via). SingI a => Sing a
sing @v of
SViaEq Sing n
_ -> Maybe b -> Meta v b
forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta (Maybe b -> Meta v b) -> f (Maybe b) -> f (Meta v b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Maybe a -> f (Maybe b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Maybe a
Maybe (CompareRep v a)
c
Sing v
SVia v
SViaSize -> Meta v b -> f (Meta v b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Meta v b -> f (Meta v b)) -> Meta v b -> f (Meta v b)
forall a b. (a -> b) -> a -> b
$ Maybe (CompareRep v b) -> Meta v b
forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
Maybe (CompareRep v b)
c
SViaDigest Sing n
_ -> Meta v b -> f (Meta v b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Meta v b -> f (Meta v b)) -> Meta v b -> f (Meta v b)
forall a b. (a -> b) -> a -> b
$ Maybe (CompareRep v b) -> Meta v b
forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
Maybe (CompareRep v b)
c
type family CompareRep (v :: Via) a where
CompareRep ('ViaEq _) a = a
CompareRep 'ViaSize _ = Natural
CompareRep ('ViaDigest h) _ = Digest h B.ByteString
newtype Digest (h :: HashFunc) a = Digest { forall (h :: HashFunc) a. Digest h a -> a
getDigest :: a }
deriving stock ((forall x. Digest h a -> Rep (Digest h a) x)
-> (forall x. Rep (Digest h a) x -> Digest h a)
-> Generic (Digest h a)
forall x. Rep (Digest h a) x -> Digest h a
forall x. Digest h a -> Rep (Digest h a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (h :: HashFunc) a x. Rep (Digest h a) x -> Digest h a
forall (h :: HashFunc) a x. Digest h a -> Rep (Digest h a) x
$cto :: forall (h :: HashFunc) a x. Rep (Digest h a) x -> Digest h a
$cfrom :: forall (h :: HashFunc) a x. Digest h a -> Rep (Digest h a) x
Generic, Digest h a -> Digest h a -> Bool
(Digest h a -> Digest h a -> Bool)
-> (Digest h a -> Digest h a -> Bool) -> Eq (Digest h a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (h :: HashFunc) a. Eq a => Digest h a -> Digest h a -> Bool
/= :: Digest h a -> Digest h a -> Bool
$c/= :: forall (h :: HashFunc) a. Eq a => Digest h a -> Digest h a -> Bool
== :: Digest h a -> Digest h a -> Bool
$c== :: forall (h :: HashFunc) a. Eq a => Digest h a -> Digest h a -> Bool
Eq, Int -> Digest h a -> ShowS
[Digest h a] -> ShowS
Digest h a -> String
(Int -> Digest h a -> ShowS)
-> (Digest h a -> String)
-> ([Digest h a] -> ShowS)
-> Show (Digest h a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (h :: HashFunc) a. Show a => Int -> Digest h a -> ShowS
forall (h :: HashFunc) a. Show a => [Digest h a] -> ShowS
forall (h :: HashFunc) a. Show a => Digest h a -> String
showList :: [Digest h a] -> ShowS
$cshowList :: forall (h :: HashFunc) a. Show a => [Digest h a] -> ShowS
show :: Digest h a -> String
$cshow :: forall (h :: HashFunc) a. Show a => Digest h a -> String
showsPrec :: Int -> Digest h a -> ShowS
$cshowsPrec :: forall (h :: HashFunc) a. Show a => Int -> Digest h a -> ShowS
Show)
type Digest' h = Digest h B.ByteString
type family HashFuncLabel (h :: HashFunc) where
HashFuncLabel 'B3 = "b3"
HashFuncLabel 'SHA256 = "sha256"
HashFuncLabel 'MD5 = "md5"
hashFuncLabel :: forall h l. (l ~ HashFuncLabel h, KnownSymbol l) => Text
hashFuncLabel :: forall (h :: HashFunc) (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
Text
hashFuncLabel = String -> Text
Text.pack (Proxy# l -> String
forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' (Proxy# l
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# l))
instance (l ~ HashFuncLabel h, KnownSymbol l) => ToJSON (Digest h B.ByteString) where
toJSON :: Digest h ByteString -> Value
toJSON = Text -> Value
Aeson.String (Text -> Value)
-> (Digest h ByteString -> Text) -> Digest h ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
Text.append Text
"digest:" (Text -> Text)
-> (Digest h ByteString -> Text) -> Digest h ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [Word8]) -> Digest h ByteString -> Text
forall (h :: HashFunc) a (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
(a -> [Word8]) -> Digest h a -> Text
prettyDigest ByteString -> [Word8]
B.unpack
instance (l ~ HashFuncLabel h, KnownSymbol l) => FromJSON (Digest h B.ByteString) where
parseJSON :: Value -> Parser (Digest h ByteString)
parseJSON = String
-> (Text -> Parser (Digest h ByteString))
-> Value
-> Parser (Digest h ByteString)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"hex hash digest" ((Text -> Parser (Digest h ByteString))
-> Value -> Parser (Digest h ByteString))
-> (Text -> Parser (Digest h ByteString))
-> Value
-> Parser (Digest h ByteString)
forall a b. (a -> b) -> a -> b
$ \Text
t ->
case forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe @Void Parsec Void Text (Digest h ByteString)
forall (h :: HashFunc) (l :: Symbol) e s (m :: * -> *).
(l ~ HashFuncLabel h, KnownSymbol l, MonadParsec e s m,
Token s ~ Char, Tokens s ~ Text) =>
m (Digest h ByteString)
parseDigest Text
t of
Maybe (Digest h ByteString)
Nothing -> String -> Parser (Digest h ByteString)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to parse hex hash digest"
Just Digest h ByteString
hash -> Digest h ByteString -> Parser (Digest h ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Digest h ByteString
hash
prettyDigest
:: forall h a l. (l ~ HashFuncLabel h, KnownSymbol l)
=> (a -> [Word8]) -> Digest h a -> Text
prettyDigest :: forall (h :: HashFunc) a (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
(a -> [Word8]) -> Digest h a -> Text
prettyDigest a -> [Word8]
unpack (Digest a
d) =
forall (h :: HashFunc) (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
Text
hashFuncLabel @h
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
':'
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (a -> [Word8]) -> a -> Text
forall a. (a -> [Word8]) -> a -> Text
prettyHexByteStringCompact a -> [Word8]
unpack a
d
parseDigest
:: forall h l e s m
. (l ~ HashFuncLabel h, KnownSymbol l, MonadParsec e s m, Token s ~ Char, Tokens s ~ Text)
=> m (Digest h B.ByteString)
parseDigest :: forall (h :: HashFunc) (l :: Symbol) e s (m :: * -> *).
(l ~ HashFuncLabel h, KnownSymbol l, MonadParsec e s m,
Token s ~ Char, Tokens s ~ Text) =>
m (Digest h ByteString)
parseDigest = do
Tokens s -> m ()
symbol Tokens s
"digest"
Tokens s -> m ()
symbol Tokens s
":"
Tokens s -> m ()
symbol (Tokens s -> m ()) -> Tokens s -> m ()
forall a b. (a -> b) -> a -> b
$ forall (h :: HashFunc) (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
Text
hashFuncLabel @h
Tokens s -> m ()
symbol Tokens s
":"
ByteString -> Digest h ByteString
forall (h :: HashFunc) a. a -> Digest h a
Digest (ByteString -> Digest h ByteString)
-> m ByteString -> m (Digest h ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Word8] -> ByteString) -> m ByteString
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char) =>
([Word8] -> a) -> m a
parseHexByteString [Word8] -> ByteString
B.pack
where symbol :: Tokens s -> m ()
symbol = m (Tokens s) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Tokens s) -> m ())
-> (Tokens s -> m (Tokens s)) -> Tokens s -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m (Tokens s) -> m (Tokens s)
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
MCL.lexeme m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MC.hspace (m (Tokens s) -> m (Tokens s))
-> (Tokens s -> m (Tokens s)) -> Tokens s -> m (Tokens s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk
class Compare (v :: Via) a where
compare' :: CompareRep v a -> CompareRep v a -> Maybe String
toCompareRep :: a -> CompareRep v a
compareTo :: forall v a. Compare v a => CompareRep v a -> a -> Maybe String
compareTo :: forall (v :: Via) a.
Compare v a =>
CompareRep v a -> a -> Maybe String
compareTo CompareRep v a
cmp = forall (v :: Via) a.
Compare v a =>
CompareRep v a -> CompareRep v a -> Maybe String
compare' @v @a CompareRep v a
cmp (CompareRep v a -> Maybe String)
-> (a -> CompareRep v a) -> a -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: Via) a. Compare v a => a -> CompareRep v a
toCompareRep @v @a
instance (Eq a, Show a) => Compare ('ViaEq 'Exact) a where
toCompareRep :: a -> CompareRep ('ViaEq 'Exact) a
toCompareRep = a -> CompareRep ('ViaEq 'Exact) a
forall a. a -> a
id
compare' :: CompareRep ('ViaEq 'Exact) a
-> CompareRep ('ViaEq 'Exact) a -> Maybe String
compare' CompareRep ('ViaEq 'Exact) a
c1 CompareRep ('ViaEq 'Exact) a
c2 | a
CompareRep ('ViaEq 'Exact) a
c1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
CompareRep ('ViaEq 'Exact) a
c2 = Maybe String
forall a. Maybe a
Nothing
| Bool
otherwise = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"values not equal: "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>a -> String
forall a. Show a => a -> String
show a
CompareRep ('ViaEq 'Exact) a
c1String -> ShowS
forall a. Semigroup a => a -> a -> a
<>String
" /= "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>a -> String
forall a. Show a => a -> String
show a
CompareRep ('ViaEq 'Exact) a
c2
instance Compare ('ViaDigest 'B3) BS.ByteString where
toCompareRep :: ByteString -> CompareRep ('ViaDigest 'B3) ByteString
toCompareRep = ByteString -> Digest 'B3 ByteString
forall (h :: HashFunc) a. a -> Digest h a
Digest (ByteString -> Digest 'B3 ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> Digest 'B3 ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
hashB3
compare' :: CompareRep ('ViaDigest 'B3) ByteString
-> CompareRep ('ViaDigest 'B3) ByteString -> Maybe String
compare' CompareRep ('ViaDigest 'B3) ByteString
c1 CompareRep ('ViaDigest 'B3) ByteString
c2 | Digest 'B3 ByteString
CompareRep ('ViaDigest 'B3) ByteString
c1 Digest 'B3 ByteString -> Digest 'B3 ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Digest 'B3 ByteString
CompareRep ('ViaDigest 'B3) ByteString
c2 = Maybe String
forall a. Maybe a
Nothing
| Bool
otherwise = String -> Maybe String
forall a. a -> Maybe a
Just String
"digests not equal"
instance Compare ('ViaEq 'PrefixOf) BS.ByteString where
toCompareRep :: ByteString -> CompareRep ('ViaEq 'PrefixOf) ByteString
toCompareRep = ByteString -> CompareRep ('ViaEq 'PrefixOf) ByteString
forall a. a -> a
id
compare' :: CompareRep ('ViaEq 'PrefixOf) ByteString
-> CompareRep ('ViaEq 'PrefixOf) ByteString -> Maybe String
compare' CompareRep ('ViaEq 'PrefixOf) ByteString
c1 CompareRep ('ViaEq 'PrefixOf) ByteString
c2 | ByteString
CompareRep ('ViaEq 'PrefixOf) ByteString
c2 ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
CompareRep ('ViaEq 'PrefixOf) ByteString
c1 = Maybe String
forall a. Maybe a
Nothing
| Bool
otherwise = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"prefix compare check fail: "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>ByteString -> String
forall a. Show a => a -> String
show ByteString
CompareRep ('ViaEq 'PrefixOf) ByteString
c1String -> ShowS
forall a. Semigroup a => a -> a -> a
<>String
" vs. "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>ByteString -> String
forall a. Show a => a -> String
show ByteString
CompareRep ('ViaEq 'PrefixOf) ByteString
c2
hashB3 :: BS.ByteString -> BS.ByteString
hashB3 :: ByteString -> ByteString
hashB3 ByteString
bs = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Digest DEFAULT_DIGEST_LEN -> [Word8]
forall a. ByteArrayAccess a => a -> [Word8]
BA.unpack (Digest DEFAULT_DIGEST_LEN -> [Word8])
-> Digest DEFAULT_DIGEST_LEN -> [Word8]
forall a b. (a -> b) -> a -> b
$ forall (len :: Nat) bin.
(KnownNat len, ByteArrayAccess bin) =>
[bin] -> Digest len
B3.hash @B3.DEFAULT_DIGEST_LEN [ByteString
bs]
class SwapCompare a (vFrom :: Via) (vTo :: Via) where
swapCompare :: CompareRep vFrom a -> Either String (CompareRep vTo a)
instance SwapCompare a v v where
swapCompare :: CompareRep v a -> Either String (CompareRep v a)
swapCompare = CompareRep v a -> Either String (CompareRep v a)
forall a b. b -> Either a b
Right
instance SwapCompare BS.ByteString ('ViaEq 'Exact) ('ViaDigest 'B3) where
swapCompare :: CompareRep ('ViaEq 'Exact) ByteString
-> Either String (CompareRep ('ViaDigest 'B3) ByteString)
swapCompare = Digest 'B3 ByteString -> Either String (Digest 'B3 ByteString)
forall a b. b -> Either a b
Right (Digest 'B3 ByteString -> Either String (Digest 'B3 ByteString))
-> (ByteString -> Digest 'B3 ByteString)
-> ByteString
-> Either String (Digest 'B3 ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest 'B3 ByteString
forall (h :: HashFunc) a. a -> Digest h a
Digest (ByteString -> Digest 'B3 ByteString)
-> (ByteString -> ByteString)
-> ByteString
-> Digest 'B3 ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
hashB3