{-# LANGUAGE UndecidableInstances #-}

-- | A type-level barrier around values that must never be shown, logged,
-- or serialised.
--
-- Wrapping a value in 'Secret' makes the following a compile-time error
-- (via 'GHC.TypeError') with a custom message:
--
--   * 'ToJSON' / 'FromJSON'
--   * 'ToCBOR' / 'FromCBOR'
--   * 'Codec.Serialise.Serialise'
--
-- 'Show' is provided but renders as a redacted placeholder
-- (@\"\<Secret field of type \<typename\>\>\"@), so enclosing records can
-- still @deriving stock (Show)@ for free.
--
-- The only way to read the wrapped value is 'withSecret', a continuation-
-- style accessor: there is intentionally no @revealSecret :: Secret a -> a@.
-- That forces every consumption site to be a small lexical scope and keeps
-- raw values from outliving the use site.
module Data.Secret (
  Secret,
  mkSecret,
  withSecret,
  Forbid,
) where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Codec.Serialise (Serialise (..))
import Control.Exception (TypeError (..), throw)
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable, typeRep)
import GHC.TypeError (ErrorMessage (..))
import GHC.TypeError qualified as TE

-- | A value the type system refuses to show or serialise.
newtype Secret a = Secret a
  deriving stock (Secret a -> Secret a -> Bool
(Secret a -> Secret a -> Bool)
-> (Secret a -> Secret a -> Bool) -> Eq (Secret a)
forall a. Eq a => Secret a -> Secret a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Secret a -> Secret a -> Bool
== :: Secret a -> Secret a -> Bool
$c/= :: forall a. Eq a => Secret a -> Secret a -> Bool
/= :: Secret a -> Secret a -> Bool
Eq, Eq (Secret a)
Eq (Secret a) =>
(Secret a -> Secret a -> Ordering)
-> (Secret a -> Secret a -> Bool)
-> (Secret a -> Secret a -> Bool)
-> (Secret a -> Secret a -> Bool)
-> (Secret a -> Secret a -> Bool)
-> (Secret a -> Secret a -> Secret a)
-> (Secret a -> Secret a -> Secret a)
-> Ord (Secret a)
Secret a -> Secret a -> Bool
Secret a -> Secret a -> Ordering
Secret a -> Secret a -> Secret a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Secret a)
forall a. Ord a => Secret a -> Secret a -> Bool
forall a. Ord a => Secret a -> Secret a -> Ordering
forall a. Ord a => Secret a -> Secret a -> Secret a
$ccompare :: forall a. Ord a => Secret a -> Secret a -> Ordering
compare :: Secret a -> Secret a -> Ordering
$c< :: forall a. Ord a => Secret a -> Secret a -> Bool
< :: Secret a -> Secret a -> Bool
$c<= :: forall a. Ord a => Secret a -> Secret a -> Bool
<= :: Secret a -> Secret a -> Bool
$c> :: forall a. Ord a => Secret a -> Secret a -> Bool
> :: Secret a -> Secret a -> Bool
$c>= :: forall a. Ord a => Secret a -> Secret a -> Bool
>= :: Secret a -> Secret a -> Bool
$cmax :: forall a. Ord a => Secret a -> Secret a -> Secret a
max :: Secret a -> Secret a -> Secret a
$cmin :: forall a. Ord a => Secret a -> Secret a -> Secret a
min :: Secret a -> Secret a -> Secret a
Ord)

mkSecret :: a -> Secret a
mkSecret :: forall a. a -> Secret a
mkSecret = a -> Secret a
forall a. a -> Secret a
Secret

-- | The only escape hatch. Continuation-style so the raw value is never
-- bound at the call site outside the supplied function.
withSecret :: Secret a -> (a -> r) -> r
withSecret :: forall a r. Secret a -> (a -> r) -> r
withSecret (Secret a
a) a -> r
f = a -> r
f a
a

-- The GHC.TypeError mechanism: declaring the instance with a 'TypeError'
-- constraint makes the instance visible to the solver (so deriving clauses
-- on records containing a 'Secret' field still resolve to it) while
-- emitting the supplied message whenever GHC tries to select it.
type Forbid op =
  TE.TypeError
    ( 'Text "Refusing to "
        ':<>: 'Text op
        ':<>: 'Text " a value marked as secret."
        ':$$: 'Text "Secret values (e.g. signing keys) must not be"
        ':$$: 'Text "shown, logged, or serialised. Use `withSecret` from"
        ':$$: 'Text "Data.Secret to consume the inner value at its"
        ':$$: 'Text "point of use (e.g. signing). If you got here from a"
        ':$$: 'Text "derived `Show` / `ToJSON` on an enclosing record,"
        ':$$: 'Text "either drop that deriving clause or write a"
        ':$$: 'Text "hand-rolled instance that omits the secret field."
    )

-- | Renders as @\"\<Secret field of type \<typename\>\>\"@. The
-- 'Typeable' constraint lets the instance name the wrapped type without
-- ever touching the value. Enclosing records can keep using
-- 'deriving stock (Show)' and get a redacted rendering for free.
instance Typeable a => Show (Secret a) where
  show :: Secret a -> String
show Secret a
_ = String
"<Secret field of type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">"

-- The bodies below should be unreachable at runtime: the 'Forbid'
-- 'TypeError' constraint fires at normal compile time. They throw a
-- 'Control.Exception.TypeError' so that under '-fdefer-type-errors'
-- (where the compile error is converted to a runtime exception) the
-- exception type matches what 'shouldNotTypecheck' looks for.
instance Forbid "encode to JSON" => ToJSON (Secret a) where
  toJSON :: Secret a -> Value
toJSON Secret a
_ = TypeError -> Value
forall a e. Exception e => e -> a
throw (String -> TypeError
TypeError String
"Refusing to encode Secret to JSON")

instance Forbid "decode from JSON" => FromJSON (Secret a) where
  parseJSON :: Value -> Parser (Secret a)
parseJSON Value
_ = TypeError -> Parser (Secret a)
forall a e. Exception e => e -> a
throw (String -> TypeError
TypeError String
"Refusing to decode Secret from JSON")

instance (Typeable a, Forbid "CBOR-encode") => ToCBOR (Secret a) where
  toCBOR :: Secret a -> Encoding
toCBOR Secret a
_ = TypeError -> Encoding
forall a e. Exception e => e -> a
throw (String -> TypeError
TypeError String
"Refusing to CBOR-encode Secret")

instance (Typeable a, Forbid "CBOR-decode") => FromCBOR (Secret a) where
  fromCBOR :: forall s. Decoder s (Secret a)
fromCBOR = TypeError -> Decoder s (Secret a)
forall a e. Exception e => e -> a
throw (String -> TypeError
TypeError String
"Refusing to CBOR-decode Secret")

instance Forbid "Serialise-encode" => Serialise (Secret a) where
  encode :: Secret a -> Encoding
encode Secret a
_ = TypeError -> Encoding
forall a e. Exception e => e -> a
throw (String -> TypeError
TypeError String
"Refusing to Serialise-encode Secret")
  decode :: forall s. Decoder s (Secret a)
decode = TypeError -> Decoder s (Secret a)
forall a e. Exception e => e -> a
throw (String -> TypeError
TypeError String
"Refusing to Serialise-decode Secret")