{-# 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.Sized 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 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
sing @v of
SViaEq Sing n
_ -> forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe (CompareRep v a)
c
Sing v
SVia v
SViaSize -> forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
c
SViaDigest Sing n
_ -> forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
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
sing @v of
SViaEq Sing n
_ -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Maybe (CompareRep v a)
c
Sing v
SVia v
SViaSize -> forall a. Monoid a => a
mempty
SViaDigest Sing n
_ -> 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
sing @v of
SViaEq Sing n
_ -> forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Maybe (CompareRep v a)
c
Sing v
SVia v
SViaSize -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
c
SViaDigest Sing n
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
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 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
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
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 (forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
Text.append Text
"digest:" forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"hex hash digest" 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 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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to parse hex hash digest"
Just Digest h ByteString
hash -> 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
forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
':'
forall a. Semigroup a => a -> a -> a
<> 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 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
":"
forall (h :: HashFunc) a. a -> Digest h a
Digest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
MCL.lexeme forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MC.hspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 = 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 | CompareRep ('ViaEq 'Exact) a
c1 forall a. Eq a => a -> a -> Bool
== CompareRep ('ViaEq 'Exact) a
c2 = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"values not equal: "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show CompareRep ('ViaEq 'Exact) a
c1forall a. Semigroup a => a -> a -> a
<>String
" /= "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show CompareRep ('ViaEq 'Exact) a
c2
instance Compare ('ViaDigest 'B3) BS.ByteString where
toCompareRep :: ByteString -> CompareRep ('ViaDigest 'B3) ByteString
toCompareRep = forall (h :: HashFunc) a. a -> Digest h a
Digest 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 | CompareRep ('ViaDigest 'B3) ByteString
c1 forall a. Eq a => a -> a -> Bool
== CompareRep ('ViaDigest 'B3) ByteString
c2 = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just String
"digests not equal"
instance Compare ('ViaEq 'PrefixOf) BS.ByteString where
toCompareRep :: ByteString -> CompareRep ('ViaEq 'PrefixOf) ByteString
toCompareRep = 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 | CompareRep ('ViaEq 'PrefixOf) ByteString
c2 ByteString -> ByteString -> Bool
`B.isPrefixOf` CompareRep ('ViaEq 'PrefixOf) ByteString
c1 = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"prefix compare check fail: "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show CompareRep ('ViaEq 'PrefixOf) ByteString
c1forall a. Semigroup a => a -> a -> a
<>String
" vs. "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show CompareRep ('ViaEq 'PrefixOf) ByteString
c2
hashB3 :: BS.ByteString -> BS.ByteString
hashB3 :: ByteString -> ByteString
hashB3 ByteString
bs = forall (n :: Nat) ba. SizedByteArray n ba -> ba
BA.unSizedByteArray forall a b. (a -> b) -> a -> b
$ forall (len :: Nat) digest bin.
(ByteArrayN len digest, ByteArrayAccess bin) =>
Maybe Key -> [bin] -> digest
B3.hash @B3.DEFAULT_DIGEST_LEN forall a. Maybe a
Nothing [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 = 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 = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HashFunc) a. a -> Digest h a
Digest forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
hashB3