-- | 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 Prelude
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 (ByteString -> Signatures) -> ByteString -> Signatures
forall a b. (a -> b) -> a -> b
$ RepoLayout -> a -> ByteString
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 (ByteString -> Signatures) -> ByteString -> Signatures
forall a b. (a -> b) -> a -> b
$ a -> ByteString
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 ([Signature] -> Signatures) -> [Signature] -> Signatures
forall a b. (a -> b) -> a -> b
$ (Some Key -> Signature) -> [Some Key] -> [Signature]
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    = PrivateKey a -> ByteString -> ByteString
forall typ. PrivateKey typ -> ByteString -> ByteString
sign (Key a -> PrivateKey a
forall a. Key a -> PrivateKey a
privateKey Key a
key) ByteString
rendered
      , signatureKey :: Some PublicKey
signatureKey = PublicKey a -> Some PublicKey
forall (f :: * -> *) a. f a -> Some f
Some (PublicKey a -> Some PublicKey) -> PublicKey a -> Some PublicKey
forall a b. (a -> b) -> a -> b
$ Key a -> PublicKey a
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} =
  PublicKey a -> ByteString -> ByteString -> Bool
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
signed :: forall a. Signed a -> a
signatures :: forall a. Signed a -> Signatures
signed :: a
signatures :: Signatures
..} = [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
         (String
"signed"     , a -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON a
signed)
       , (String
"signatures" , Signatures -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON Signatures
signatures)
       ]

instance Monad m => ToJSON m Signatures where
  toJSON :: Signatures -> m JSValue
toJSON = [PreSignature] -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON ([PreSignature] -> m JSValue)
-> (Signatures -> [PreSignature]) -> Signatures -> m JSValue
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 = [PreSignature] -> m Signatures
forall (m :: * -> *). MonadKeys m => [PreSignature] -> m Signatures
fromPreSignatures ([PreSignature] -> m Signatures)
-> (JSValue -> m [PreSignature]) -> JSValue -> m Signatures
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< JSValue -> m [PreSignature]
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        <- JSValue -> String -> m JSValue
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signed"
    a
signed     <- JSValue -> m a
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    Signatures
signatures <- JSValue -> String -> m Signatures
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signatures"
    String -> Bool -> m ()
forall (m :: * -> *).
MonadError DeserializationError m =>
String -> Bool -> m ()
validate String
"signatures" (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ JSValue -> Signatures -> Bool
verifySignatures JSValue
enc Signatures
signatures
    Signed a -> m (Signed a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Signed{a
Signatures
signed :: a
signatures :: Signatures
signed :: a
signatures :: Signatures
..}

-- | 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) =
    (Signature -> Bool) -> [Signature] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString -> Signature -> Bool
verifySignature (ByteString -> Signature -> Bool)
-> ByteString -> Signature -> Bool
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
[UninterpretedSignatures a] -> ShowS
UninterpretedSignatures a -> String
(Int -> UninterpretedSignatures a -> ShowS)
-> (UninterpretedSignatures a -> String)
-> ([UninterpretedSignatures a] -> ShowS)
-> Show (UninterpretedSignatures a)
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
$cshowsPrec :: forall a. Show a => Int -> UninterpretedSignatures a -> ShowS
showsPrec :: Int -> UninterpretedSignatures a -> ShowS
$cshow :: forall a. Show a => UninterpretedSignatures a -> String
show :: UninterpretedSignatures a -> String
$cshowList :: forall a. Show a => [UninterpretedSignatures a] -> ShowS
showList :: [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
(Int -> PreSignature -> ShowS)
-> (PreSignature -> String)
-> ([PreSignature] -> ShowS)
-> Show PreSignature
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PreSignature -> ShowS
showsPrec :: Int -> PreSignature -> ShowS
$cshow :: PreSignature -> String
show :: PreSignature -> String
$cshowList :: [PreSignature] -> ShowS
showList :: [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
presignature :: PreSignature -> ByteString
presigMethod :: PreSignature -> Some KeyType
presigKeyId :: PreSignature -> KeyId
presignature :: ByteString
presigMethod :: Some KeyType
presigKeyId :: KeyId
..} = do
    Some PublicKey
key <- KeyId -> m (Some PublicKey)
forall (m :: * -> *). MonadKeys m => KeyId -> m (Some PublicKey)
lookupKey KeyId
presigKeyId
    String -> Bool -> m ()
forall (m :: * -> *).
MonadError DeserializationError m =>
String -> Bool -> m ()
validate String
"key type" (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Some PublicKey -> Some (TypeOf PublicKey) -> Bool
forall (f :: * -> *). Typed f => Some f -> Some (TypeOf f) -> Bool
typecheckSome Some PublicKey
key Some (TypeOf PublicKey)
Some KeyType
presigMethod
    Signature -> m Signature
forall a. a -> m a
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
signature :: Signature -> ByteString
signatureKey :: Signature -> Some PublicKey
signature :: ByteString
signatureKey :: Some PublicKey
..} = PreSignature {
      presignature :: ByteString
presignature = ByteString
signature
    , presigMethod :: Some KeyType
presigMethod = Some PublicKey -> Some KeyType
somePublicKeyType Some PublicKey
signatureKey
    , presigKeyId :: KeyId
presigKeyId  = Some PublicKey -> KeyId
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
      String -> Bool -> m ()
forall (m :: * -> *).
MonadError DeserializationError m =>
String -> Bool -> m ()
validate String
"all signatures made with different keys" (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$
        Set KeyId -> Int
forall a. Set a -> Int
Set.size ([KeyId] -> Set KeyId
forall a. Ord a => [a] -> Set a
Set.fromList ((PreSignature -> KeyId) -> [PreSignature] -> [KeyId]
forall a b. (a -> b) -> [a] -> [b]
map PreSignature -> KeyId
presigKeyId [PreSignature]
sigs)) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [PreSignature] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PreSignature]
sigs
      [Signature] -> Signatures
Signatures ([Signature] -> Signatures) -> m [Signature] -> m Signatures
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PreSignature -> m Signature) -> [PreSignature] -> m [Signature]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PreSignature -> m Signature
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) = (Signature -> PreSignature) -> [Signature] -> [PreSignature]
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    <- JSValue -> String -> m String
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"keyid"
    Some KeyType
method <- JSValue -> String -> m (Some KeyType)
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"method"
    Base64
sig    <- JSValue -> String -> m Base64
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"sig"
    PreSignature -> m PreSignature
forall a. a -> m a
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
presignature :: PreSignature -> ByteString
presigMethod :: PreSignature -> Some KeyType
presigKeyId :: PreSignature -> KeyId
presignature :: ByteString
presigMethod :: Some KeyType
presigKeyId :: KeyId
..} = [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
         (String
"keyid"  , JSValue -> m JSValue
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> m JSValue) -> JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString (String -> JSValue) -> (KeyId -> String) -> KeyId -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyId -> String
keyIdString (KeyId -> JSValue) -> KeyId -> JSValue
forall a b. (a -> b) -> a -> b
$ KeyId
presigKeyId)
       , (String
"method" , Some KeyType -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (Some KeyType -> m JSValue) -> Some KeyType -> m JSValue
forall a b. (a -> b) -> a -> b
$ Some KeyType
presigMethod)
       , (String
"sig"    , Base64 -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (Base64 -> m JSValue) -> Base64 -> m JSValue
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 <- JSValue -> String -> m JSValue
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signed"
    a
uninterpretedSigned     <- JSValue -> m a
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    [PreSignature]
uninterpretedSignatures <- JSValue -> String -> m [PreSignature]
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signatures"
    UninterpretedSignatures a -> m (UninterpretedSignatures a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return UninterpretedSignatures{a
[PreSignature]
uninterpretedSigned :: a
uninterpretedSignatures :: [PreSignature]
uninterpretedSigned :: a
uninterpretedSignatures :: [PreSignature]
..}

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