-- | Wrapper around an arbitrary datatype that adds signatures
--
-- Note that in the spec there is explicit sharing of keys through key IDs;
-- we translate this to implicit sharing in our Haskell datatypes, with the
-- translation done in the JSON serialization/deserialization.
module Hackage.Security.TUF.Signed (
    -- * TUF types
    Signed(..)
  , Signatures(..)
  , Signature(..)
    -- * Construction and verification
  , unsigned
  , withSignatures
  , withSignatures'
  , signRendered
  , verifySignature
    -- * JSON aids
  , signedFromJSON
  , verifySignatures
    -- * Avoid interpreting signatures
  , UninterpretedSignatures(..)
  , PreSignature(..)
    -- ** Utility
  , fromPreSignature
  , fromPreSignatures
  , toPreSignature
  , toPreSignatures
  ) where

import MyPrelude
import Control.Monad
import Data.Functor.Identity
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy as BS.L
import qualified Data.Set             as Set

import Hackage.Security.JSON
import Hackage.Security.Key
import Hackage.Security.TUF.Layout.Repo
import Hackage.Security.Util.Some
import Text.JSON.Canonical
import qualified Hackage.Security.Util.Base64 as B64

{-------------------------------------------------------------------------------
  Signed objects
-------------------------------------------------------------------------------}

data Signed a = Signed {
    forall a. Signed a -> a
signed     :: a
  , forall a. Signed a -> Signatures
signatures :: Signatures
  }

-- | A list of signatures
--
-- Invariant: each signature must be made with a different key.
-- We enforce this invariant for incoming untrusted data ('fromPreSignatures')
-- but not for lists of signatures that we create in code.
newtype Signatures = Signatures [Signature]

data Signature = Signature {
    Signature -> ByteString
signature    :: BS.ByteString
  , Signature -> Some PublicKey
signatureKey :: Some PublicKey
  }

-- | Create a new document without any signatures
unsigned :: a -> Signed a
unsigned :: forall a. a -> Signed a
unsigned a
a = Signed { signed :: a
signed = a
a, signatures :: Signatures
signatures = [Signature] -> Signatures
Signatures [] }

-- | Sign a document
withSignatures :: ToJSON WriteJSON a => RepoLayout -> [Some Key] -> a -> Signed a
withSignatures :: forall a.
ToJSON WriteJSON a =>
RepoLayout -> [Some Key] -> a -> Signed a
withSignatures RepoLayout
repoLayout [Some Key]
keys a
doc = Signed {
      signed :: a
signed     = a
doc
    , signatures :: Signatures
signatures = [Some Key] -> ByteString -> Signatures
signRendered [Some Key]
keys forall a b. (a -> b) -> a -> b
$ forall a. ToJSON WriteJSON a => RepoLayout -> a -> ByteString
renderJSON RepoLayout
repoLayout a
doc
    }

-- | Variation on 'withSignatures' that doesn't need the repo layout
withSignatures' :: ToJSON Identity a => [Some Key] -> a -> Signed a
withSignatures' :: forall a. ToJSON Identity a => [Some Key] -> a -> Signed a
withSignatures' [Some Key]
keys a
doc = Signed {
      signed :: a
signed     = a
doc
    , signatures :: Signatures
signatures = [Some Key] -> ByteString -> Signatures
signRendered [Some Key]
keys forall a b. (a -> b) -> a -> b
$ forall a. ToJSON Identity a => a -> ByteString
renderJSON_NoLayout a
doc
    }

-- | Construct signatures for already rendered value
signRendered :: [Some Key] -> BS.L.ByteString -> Signatures
signRendered :: [Some Key] -> ByteString -> Signatures
signRendered [Some Key]
keys ByteString
rendered = [Signature] -> Signatures
Signatures forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Some Key -> Signature
go [Some Key]
keys
  where
    go :: Some Key -> Signature
    go :: Some Key -> Signature
go (Some Key a
key) = Signature {
        signature :: ByteString
signature    = forall typ. PrivateKey typ -> ByteString -> ByteString
sign (forall a. Key a -> PrivateKey a
privateKey Key a
key) ByteString
rendered
      , signatureKey :: Some PublicKey
signatureKey = forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ forall a. Key a -> PublicKey a
publicKey Key a
key
      }

verifySignature :: BS.L.ByteString -> Signature -> Bool
verifySignature :: ByteString -> Signature -> Bool
verifySignature ByteString
inp Signature{signature :: Signature -> ByteString
signature = ByteString
sig, signatureKey :: Signature -> Some PublicKey
signatureKey = Some PublicKey a
pub} =
  forall typ. PublicKey typ -> ByteString -> ByteString -> Bool
verify PublicKey a
pub ByteString
inp ByteString
sig

instance (Monad m, ToJSON m a) => ToJSON m (Signed a) where
  toJSON :: Signed a -> m JSValue
toJSON Signed{a
Signatures
signatures :: Signatures
signed :: a
signatures :: forall a. Signed a -> Signatures
signed :: forall a. Signed a -> a
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
         (String
"signed"     , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON a
signed)
       , (String
"signatures" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON Signatures
signatures)
       ]

instance Monad m => ToJSON m Signatures where
  toJSON :: Signatures -> m JSValue
toJSON = forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signatures -> [PreSignature]
toPreSignatures

instance MonadKeys m => FromJSON m Signatures where
  fromJSON :: JSValue -> m Signatures
fromJSON = forall (m :: * -> *). MonadKeys m => [PreSignature] -> m Signatures
fromPreSignatures forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON

{-------------------------------------------------------------------------------
  JSON aids
-------------------------------------------------------------------------------}

-- | General FromJSON instance for signed datatypes
--
-- We don't give a general FromJSON instance for Signed because for some
-- datatypes we need to do something special (datatypes where we need to
-- read key environments); for instance, see the "Signed Root" instance.
signedFromJSON :: (MonadKeys m, FromJSON m a) => JSValue -> m (Signed a)
signedFromJSON :: forall (m :: * -> *) a.
(MonadKeys m, FromJSON m a) =>
JSValue -> m (Signed a)
signedFromJSON JSValue
envelope = do
    JSValue
enc        <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signed"
    a
signed     <- forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    Signatures
signatures <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signatures"
    forall (m :: * -> *).
MonadError DeserializationError m =>
String -> Bool -> m ()
validate String
"signatures" forall a b. (a -> b) -> a -> b
$ JSValue -> Signatures -> Bool
verifySignatures JSValue
enc Signatures
signatures
    forall (m :: * -> *) a. Monad m => a -> m a
return Signed{a
Signatures
signatures :: Signatures
signed :: a
signatures :: Signatures
signed :: a
..}

-- | Signature verification
--
-- NOTES:
-- 1. By definition, the signature must be verified against the canonical
--    JSON format. This means we _must_ parse and then pretty print (as
--    we do here) because the document as stored may or may not be in
--    canonical format.
-- 2. However, it is important that we NOT translate from the JSValue
--    to whatever internal datatype we are using and then back to JSValue,
--    because that may not roundtrip: we must allow for additional fields
--    in the JSValue that we ignore (and would therefore lose when we
--    attempt to roundtrip).
-- 3. We verify that all signatures are valid, but we cannot verify (here)
--    that these signatures are signed with the right key, or that we
--    have a sufficient number of signatures. This will be the
--    responsibility of the calling code.
verifySignatures :: JSValue -> Signatures -> Bool
verifySignatures :: JSValue -> Signatures -> Bool
verifySignatures JSValue
parsed (Signatures [Signature]
sigs) =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString -> Signature -> Bool
verifySignature forall a b. (a -> b) -> a -> b
$ JSValue -> ByteString
renderCanonicalJSON JSValue
parsed) [Signature]
sigs

{-------------------------------------------------------------------------------
  Uninterpreted signatures
-------------------------------------------------------------------------------}

-- | File with uninterpreted signatures
--
-- Sometimes we want to be able to read a file without interpreting the
-- signatures (that is, resolving the key IDs) or doing any kind of checks on
-- them. One advantage of this is that this allows us to read many file types
-- without any key environment at all, which is sometimes useful.
data UninterpretedSignatures a = UninterpretedSignatures {
    forall a. UninterpretedSignatures a -> a
uninterpretedSigned     :: a
  , forall a. UninterpretedSignatures a -> [PreSignature]
uninterpretedSignatures :: [PreSignature]
  }
  deriving (Int -> UninterpretedSignatures a -> ShowS
forall a. Show a => Int -> UninterpretedSignatures a -> ShowS
forall a. Show a => [UninterpretedSignatures a] -> ShowS
forall a. Show a => UninterpretedSignatures a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UninterpretedSignatures a] -> ShowS
$cshowList :: forall a. Show a => [UninterpretedSignatures a] -> ShowS
show :: UninterpretedSignatures a -> String
$cshow :: forall a. Show a => UninterpretedSignatures a -> String
showsPrec :: Int -> UninterpretedSignatures a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> UninterpretedSignatures a -> ShowS
Show)

-- | A signature with a key ID (rather than an actual key)
--
-- This corresponds precisely to the TUF representation of a signature.
data PreSignature = PreSignature {
    PreSignature -> ByteString
presignature :: BS.ByteString
  , PreSignature -> Some KeyType
presigMethod :: Some KeyType
  , PreSignature -> KeyId
presigKeyId  :: KeyId
  }
  deriving (Int -> PreSignature -> ShowS
[PreSignature] -> ShowS
PreSignature -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PreSignature] -> ShowS
$cshowList :: [PreSignature] -> ShowS
show :: PreSignature -> String
$cshow :: PreSignature -> String
showsPrec :: Int -> PreSignature -> ShowS
$cshowsPrec :: Int -> PreSignature -> ShowS
Show)

-- | Convert a pre-signature to a signature
--
-- Verifies that the key type matches the advertised method.
fromPreSignature :: MonadKeys m => PreSignature -> m Signature
fromPreSignature :: forall (m :: * -> *). MonadKeys m => PreSignature -> m Signature
fromPreSignature PreSignature{ByteString
Some KeyType
KeyId
presigKeyId :: KeyId
presigMethod :: Some KeyType
presignature :: ByteString
presigKeyId :: PreSignature -> KeyId
presigMethod :: PreSignature -> Some KeyType
presignature :: PreSignature -> ByteString
..} = do
    Some PublicKey
key <- forall (m :: * -> *). MonadKeys m => KeyId -> m (Some PublicKey)
lookupKey KeyId
presigKeyId
    forall (m :: * -> *).
MonadError DeserializationError m =>
String -> Bool -> m ()
validate String
"key type" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Typed f => Some f -> Some (TypeOf f) -> Bool
typecheckSome Some PublicKey
key Some KeyType
presigMethod
    forall (m :: * -> *) a. Monad m => a -> m a
return Signature {
        signature :: ByteString
signature    = ByteString
presignature
      , signatureKey :: Some PublicKey
signatureKey = Some PublicKey
key
      }

-- | Convert signature to pre-signature
toPreSignature :: Signature -> PreSignature
toPreSignature :: Signature -> PreSignature
toPreSignature Signature{ByteString
Some PublicKey
signatureKey :: Some PublicKey
signature :: ByteString
signatureKey :: Signature -> Some PublicKey
signature :: Signature -> ByteString
..} = PreSignature {
      presignature :: ByteString
presignature = ByteString
signature
    , presigMethod :: Some KeyType
presigMethod = Some PublicKey -> Some KeyType
somePublicKeyType Some PublicKey
signatureKey
    , presigKeyId :: KeyId
presigKeyId  = forall (key :: * -> *). HasKeyId key => Some key -> KeyId
someKeyId         Some PublicKey
signatureKey
    }

-- | Convert a list of 'PreSignature's to a list of 'Signature's
--
-- This verifies the invariant that all signatures are made with different keys.
-- We do this on the presignatures rather than the signatures so that we can do
-- the check on key IDs, rather than keys (the latter don't have an Ord
-- instance).
fromPreSignatures :: MonadKeys m => [PreSignature] -> m Signatures
fromPreSignatures :: forall (m :: * -> *). MonadKeys m => [PreSignature] -> m Signatures
fromPreSignatures [PreSignature]
sigs = do
      forall (m :: * -> *).
MonadError DeserializationError m =>
String -> Bool -> m ()
validate String
"all signatures made with different keys" forall a b. (a -> b) -> a -> b
$
        forall a. Set a -> Int
Set.size (forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map PreSignature -> KeyId
presigKeyId [PreSignature]
sigs)) forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [PreSignature]
sigs
      [Signature] -> Signatures
Signatures forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadKeys m => PreSignature -> m Signature
fromPreSignature [PreSignature]
sigs

-- | Convert list of pre-signatures to a list of signatures
toPreSignatures :: Signatures -> [PreSignature]
toPreSignatures :: Signatures -> [PreSignature]
toPreSignatures (Signatures [Signature]
sigs) = forall a b. (a -> b) -> [a] -> [b]
map Signature -> PreSignature
toPreSignature [Signature]
sigs

instance ReportSchemaErrors m => FromJSON m PreSignature where
  fromJSON :: JSValue -> m PreSignature
fromJSON JSValue
enc = do
    String
kId    <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"keyid"
    Some KeyType
method <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"method"
    Base64
sig    <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"sig"
    forall (m :: * -> *) a. Monad m => a -> m a
return PreSignature {
        presignature :: ByteString
presignature = Base64 -> ByteString
B64.toByteString Base64
sig
      , presigMethod :: Some KeyType
presigMethod = Some KeyType
method
      , presigKeyId :: KeyId
presigKeyId  = String -> KeyId
KeyId String
kId
      }

instance Monad m => ToJSON m PreSignature where
  toJSON :: PreSignature -> m JSValue
toJSON PreSignature{ByteString
Some KeyType
KeyId
presigKeyId :: KeyId
presigMethod :: Some KeyType
presignature :: ByteString
presigKeyId :: PreSignature -> KeyId
presigMethod :: PreSignature -> Some KeyType
presignature :: PreSignature -> ByteString
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
         (String
"keyid"  , forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyId -> String
keyIdString forall a b. (a -> b) -> a -> b
$ KeyId
presigKeyId)
       , (String
"method" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ Some KeyType
presigMethod)
       , (String
"sig"    , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ ByteString -> Base64
B64.fromByteString ByteString
presignature)
       ]

instance ( ReportSchemaErrors m
         , FromJSON m a
         ) => FromJSON m (UninterpretedSignatures a) where
  fromJSON :: JSValue -> m (UninterpretedSignatures a)
fromJSON JSValue
envelope = do
    JSValue
enc <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signed"
    a
uninterpretedSigned     <- forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    [PreSignature]
uninterpretedSignatures <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signatures"
    forall (m :: * -> *) a. Monad m => a -> m a
return UninterpretedSignatures{a
[PreSignature]
uninterpretedSignatures :: [PreSignature]
uninterpretedSigned :: a
uninterpretedSignatures :: [PreSignature]
uninterpretedSigned :: a
..}

instance (Monad m, ToJSON m a) => ToJSON m (UninterpretedSignatures a) where
  toJSON :: UninterpretedSignatures a -> m JSValue
toJSON UninterpretedSignatures{a
[PreSignature]
uninterpretedSignatures :: [PreSignature]
uninterpretedSigned :: a
uninterpretedSignatures :: forall a. UninterpretedSignatures a -> [PreSignature]
uninterpretedSigned :: forall a. UninterpretedSignatures a -> a
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
         (String
"signed"     , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON a
uninterpretedSigned)
       , (String
"signatures" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON [PreSignature]
uninterpretedSignatures)
       ]