{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : Docs.Hash
-- Description : Hash Datatype and Utility
-- License     : AGPL-3
-- Maintainer  : stu235271@mail.uni-kiel.de
--               stu236925@mail.uni-kiel.de
--
-- This module contains the definition of a @Hash@ datatype and some related
-- utility funtions.
module Docs.Hash
    ( Hashable (..)
    , Hashed (..)
    , Hash (..)
    , hashed
    )
where

import Control.Lens ((.~), (?~))
import qualified Crypto.Hash.SHA1 as SHA1
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
import qualified Data.Aeson as Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Base64 (decode, encode)
import Data.ByteString.Char8 (pack)
import Data.Function ((&))
import qualified Data.HashMap.Strict.InsOrd as InsOrd
import Data.OpenApi
    ( NamedSchema (..)
    , OpenApiType (..)
    , ToParamSchema (..)
    , ToSchema (..)
    , declareSchemaRef
    , properties
    , required
    , type_
    )
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import GHC.Int
import Web.HttpApiData (FromHttpApiData (..))

-- | represents the hash of a value
newtype Hash = Hash
    { Hash -> ByteString
unHash :: ByteString
    }
    deriving (Int -> Hash -> ShowS
[Hash] -> ShowS
Hash -> String
(Int -> Hash -> ShowS)
-> (Hash -> String) -> ([Hash] -> ShowS) -> Show Hash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Hash -> ShowS
showsPrec :: Int -> Hash -> ShowS
$cshow :: Hash -> String
show :: Hash -> String
$cshowList :: [Hash] -> ShowS
showList :: [Hash] -> ShowS
Show, Hash -> Hash -> Bool
(Hash -> Hash -> Bool) -> (Hash -> Hash -> Bool) -> Eq Hash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Hash -> Hash -> Bool
== :: Hash -> Hash -> Bool
$c/= :: Hash -> Hash -> Bool
/= :: Hash -> Hash -> Bool
Eq)

instance ToJSON Hash where
    toJSON :: Hash -> Value
toJSON (Hash ByteString
bs) = Text -> Value
Aeson.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
encode ByteString
bs

instance FromJSON Hash where
    parseJSON :: Value -> Parser Hash
parseJSON = String -> (Text -> Parser Hash) -> Value -> Parser Hash
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"Hash" ((Text -> Parser Hash) -> Value -> Parser Hash)
-> (Text -> Parser Hash) -> Value -> Parser Hash
forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case ByteString -> Either String ByteString
decode (Text -> ByteString
TE.encodeUtf8 Text
t) of
            Right ByteString
bs -> Hash -> Parser Hash
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Hash
Hash ByteString
bs)
            Left String
err -> String -> Parser Hash
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Hash) -> String -> Parser Hash
forall a b. (a -> b) -> a -> b
$ String
"Invalid base16 encoding in Hash: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err

instance ToSchema Hash where
    declareNamedSchema :: Proxy Hash -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy Hash
_ = Proxy String -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
declareNamedSchema (Proxy String
forall {k} (t :: k). Proxy t
Proxy :: Proxy String)

instance ToParamSchema Hash where
    toParamSchema :: Proxy Hash -> Schema
toParamSchema Proxy Hash
_ =
        Schema
forall a. Monoid a => a
mempty
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString

instance FromHttpApiData Hash where
    parseUrlPiece :: Text -> Either Text Hash
parseUrlPiece Text
t = case ByteString -> Either String ByteString
decode (Text -> ByteString
TE.encodeUtf8 Text
t) of
        Right ByteString
bs -> Hash -> Either Text Hash
forall a b. b -> Either a b
Right (ByteString -> Hash
Hash ByteString
bs)
        Left String
_ -> Text -> Either Text Hash
forall a b. a -> Either a b
Left Text
"Invalid base16 encoding in Hash"

-- | a hashable value
class Hashable a where
    updateHash :: SHA1.Ctx -> a -> SHA1.Ctx

    hash :: a -> Hash
    hash = ByteString -> Hash
Hash (ByteString -> Hash) -> (a -> ByteString) -> a -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> ByteString
SHA1.finalize (Ctx -> ByteString) -> (a -> Ctx) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> a -> Ctx
forall a. Hashable a => Ctx -> a -> Ctx
updateHash Ctx
SHA1.init

instance Hashable ByteString where
    updateHash :: Ctx -> ByteString -> Ctx
updateHash = Ctx -> ByteString -> Ctx
SHA1.update
    hash :: ByteString -> Hash
hash = ByteString -> Hash
Hash (ByteString -> Hash)
-> (ByteString -> ByteString) -> ByteString -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA1.hash

instance Hashable Hash where
    updateHash :: Ctx -> Hash -> Ctx
updateHash Ctx
ctx (Hash ByteString
bs) = Ctx -> ByteString -> Ctx
forall a. Hashable a => Ctx -> a -> Ctx
updateHash Ctx
ctx ByteString
bs
    hash :: Hash -> Hash
hash (Hash ByteString
bs) = ByteString -> Hash
forall a. Hashable a => a -> Hash
hash ByteString
bs

instance Hashable Int where
    updateHash :: Ctx -> Int -> Ctx
updateHash = Ctx -> Int -> Ctx
forall a. Show a => Ctx -> a -> Ctx
updateHashShow

instance Hashable Int64 where
    updateHash :: Ctx -> Int64 -> Ctx
updateHash = Ctx -> Int64 -> Ctx
forall a. Show a => Ctx -> a -> Ctx
updateHashShow

instance (Hashable a) => Hashable [a] where
    updateHash :: Ctx -> [a] -> Ctx
updateHash = (a -> Ctx -> Ctx) -> Ctx -> [a] -> Ctx
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a -> Ctx -> Ctx) -> Ctx -> [a] -> Ctx)
-> (a -> Ctx -> Ctx) -> Ctx -> [a] -> Ctx
forall a b. (a -> b) -> a -> b
$ (Ctx -> a -> Ctx) -> a -> Ctx -> Ctx
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ctx -> a -> Ctx
forall a. Hashable a => Ctx -> a -> Ctx
updateHash

instance (Hashable a) => Hashable (Maybe a) where
    updateHash :: Ctx -> Maybe a -> Ctx
updateHash Ctx
ctx (Just a
a) = Ctx -> a -> Ctx
forall a. Hashable a => Ctx -> a -> Ctx
updateHash Ctx
ctx a
a
    updateHash Ctx
ctx Maybe a
_ = Ctx
ctx

instance Hashable Text where
    updateHash :: Ctx -> Text -> Ctx
updateHash Ctx
ctx Text
text = Ctx -> ByteString -> Ctx
forall a. Hashable a => Ctx -> a -> Ctx
updateHash Ctx
ctx (ByteString -> Ctx) -> ByteString -> Ctx
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
text

-- | represents a value together with its hash
data Hashed a = Hashed Hash a deriving (Int -> Hashed a -> ShowS
[Hashed a] -> ShowS
Hashed a -> String
(Int -> Hashed a -> ShowS)
-> (Hashed a -> String) -> ([Hashed a] -> ShowS) -> Show (Hashed a)
forall a. Show a => Int -> Hashed a -> ShowS
forall a. Show a => [Hashed a] -> ShowS
forall a. Show a => Hashed a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Hashed a -> ShowS
showsPrec :: Int -> Hashed a -> ShowS
$cshow :: forall a. Show a => Hashed a -> String
show :: Hashed a -> String
$cshowList :: forall a. Show a => [Hashed a] -> ShowS
showList :: [Hashed a] -> ShowS
Show)

instance (Hashable a, ToJSON a) => ToJSON (Hashed a) where
    toJSON :: Hashed a -> Value
toJSON (Hashed Hash
h a
content) =
        [Pair] -> Value
Aeson.object [Key
"hash" Key -> Hash -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Hash
h, Key
"content" Key -> a -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= a
content]

instance (Hashable a, FromJSON a) => FromJSON (Hashed a) where
    parseJSON :: Value -> Parser (Hashed a)
parseJSON = String
-> (Object -> Parser (Hashed a)) -> Value -> Parser (Hashed a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Hashed" ((Object -> Parser (Hashed a)) -> Value -> Parser (Hashed a))
-> (Object -> Parser (Hashed a)) -> Value -> Parser (Hashed a)
forall a b. (a -> b) -> a -> b
$ \Object
v ->
        Hash -> a -> Hashed a
forall a. Hash -> a -> Hashed a
Hashed
            (Hash -> a -> Hashed a) -> Parser Hash -> Parser (a -> Hashed a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Hash
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hash"
            Parser (a -> Hashed a) -> Parser a -> Parser (Hashed a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"content"

instance (ToSchema a) => ToSchema (Hashed a) where
    declareNamedSchema :: Proxy (Hashed a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Hashed a)
_ = do
        Referenced Schema
hashSchema <- Proxy Hash -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy Hash
forall {k} (t :: k). Proxy t
Proxy :: Proxy Hash)
        Referenced Schema
contentSchema <- Proxy a -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
        NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$
            Maybe Text -> Schema -> NamedSchema
NamedSchema (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Hashed") (Schema -> NamedSchema) -> Schema -> NamedSchema
forall a b. (a -> b) -> a -> b
$
                Schema
forall a. Monoid a => a
mempty
                    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_
                        ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
                    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties
                        ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Text, Referenced Schema)]
-> InsOrdHashMap Text (Referenced Schema)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrd.fromList
                            [ (Text
"hash", Referenced Schema
hashSchema)
                            , (Text
"content", Referenced Schema
contentSchema)
                            ]
                    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Schema -> Identity Schema
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
required
                        (([Text] -> Identity [Text]) -> Schema -> Identity Schema)
-> [Text] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text
"hash", Text
"content"]

-- | returns the input together with its hash
hashed :: (Hashable a) => a -> Hashed a
hashed :: forall a. Hashable a => a -> Hashed a
hashed a
x = Hash -> a -> Hashed a
forall a. Hash -> a -> Hashed a
Hashed (a -> Hash
forall a. Hashable a => a -> Hash
hash a
x) a
x

-- | update a hash by applying the value to 'show'
updateHashShow :: (Show a) => SHA1.Ctx -> a -> SHA1.Ctx
updateHashShow :: forall a. Show a => Ctx -> a -> Ctx
updateHashShow Ctx
ctx = Ctx -> ByteString -> Ctx
SHA1.update Ctx
ctx (ByteString -> Ctx) -> (a -> ByteString) -> a -> Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack (String -> ByteString) -> (a -> String) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show