{-# LANGUAGE CPP #-}
module Hackage.Security.Trusted.TCB (
    -- * Trusted values
    Trusted(DeclareTrusted)
  , trusted
  , trustStatic
  , trustVerified
  , trustApply
  , trustElems
    -- * Verification errors
  , VerificationError(..)
  , RootUpdated(..)
  , VerificationHistory
    -- * Role verification
  , SignaturesVerified -- opaque
  , signaturesVerified
  , verifyRole'
  , verifyFingerprints
#if __GLASGOW_HASKELL__ >= 710
    -- * Re-exports
  , StaticPtr
#else
    -- * Fake static pointers
  , StaticPtr
  , static
#endif
  ) where

import MyPrelude
import Control.Exception
import Control.Monad.Except
import Data.Typeable
import Data.Time
import Hackage.Security.TUF
import Hackage.Security.JSON
import Hackage.Security.Key
import Hackage.Security.Util.Pretty
import qualified Hackage.Security.Util.Lens as Lens

#if __GLASGOW_HASKELL__ >= 710
import GHC.StaticPtr
#else
-- Fake static pointers for ghc < 7.10. This means Trusted offers no
-- additional type safety, but that's okay: we can still verify the code
-- with ghc 7.10 and get the additional checks.
newtype StaticPtr a = StaticPtr { deRefStaticPtr :: a }

static :: a -> StaticPtr a
static = StaticPtr
#endif

-- | Trusted values
--
-- Trusted values originate in only two ways:
--
-- * Anything that is statically known is trusted ('trustStatic')
-- * If we have "dynamic" data we can trust it once we have verified the
--   the signatures (trustSigned).
--
-- NOTE: Trusted is NOT a functor. If it was we could define
--
-- > trustAnything :: a -> Trusted a
-- > trustAnything a = fmap (const a) (trustStatic (static ()))
--
-- Consequently, it is neither a monad nor a comonad. However, we _can_ apply
-- trusted functions to trusted arguments ('trustApply').
--
-- The 'DeclareTrusted' constructor is exported, but any use of it should be
-- verified.
newtype Trusted a = DeclareTrusted { Trusted a -> a
trusted :: a }
  deriving (Trusted a -> Trusted a -> Bool
(Trusted a -> Trusted a -> Bool)
-> (Trusted a -> Trusted a -> Bool) -> Eq (Trusted a)
forall a. Eq a => Trusted a -> Trusted a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Trusted a -> Trusted a -> Bool
$c/= :: forall a. Eq a => Trusted a -> Trusted a -> Bool
== :: Trusted a -> Trusted a -> Bool
$c== :: forall a. Eq a => Trusted a -> Trusted a -> Bool
Eq, Int -> Trusted a -> ShowS
[Trusted a] -> ShowS
Trusted a -> String
(Int -> Trusted a -> ShowS)
-> (Trusted a -> String)
-> ([Trusted a] -> ShowS)
-> Show (Trusted a)
forall a. Show a => Int -> Trusted a -> ShowS
forall a. Show a => [Trusted a] -> ShowS
forall a. Show a => Trusted a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Trusted a] -> ShowS
$cshowList :: forall a. Show a => [Trusted a] -> ShowS
show :: Trusted a -> String
$cshow :: forall a. Show a => Trusted a -> String
showsPrec :: Int -> Trusted a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Trusted a -> ShowS
Show)

trustStatic :: StaticPtr a -> Trusted a
trustStatic :: StaticPtr a -> Trusted a
trustStatic = a -> Trusted a
forall a. a -> Trusted a
DeclareTrusted (a -> Trusted a) -> (StaticPtr a -> a) -> StaticPtr a -> Trusted a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StaticPtr a -> a
forall a. StaticPtr a -> a
deRefStaticPtr

trustVerified :: SignaturesVerified a -> Trusted a
trustVerified :: SignaturesVerified a -> Trusted a
trustVerified = a -> Trusted a
forall a. a -> Trusted a
DeclareTrusted (a -> Trusted a)
-> (SignaturesVerified a -> a) -> SignaturesVerified a -> Trusted a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignaturesVerified a -> a
forall a. SignaturesVerified a -> a
signaturesVerified

-- | Equivalent of '<*>'
--
-- Trusted isn't quite applicative (no pure, not a functor), but it is
-- somehow Applicative-like: we have the equivalent of '<*>'
trustApply :: Trusted (a -> b) -> Trusted a -> Trusted b
trustApply :: Trusted (a -> b) -> Trusted a -> Trusted b
trustApply (DeclareTrusted a -> b
f) (DeclareTrusted a
x) = b -> Trusted b
forall a. a -> Trusted a
DeclareTrusted (a -> b
f a
x)

-- | Trust all elements of some trusted (traversable) container
--
-- If we have, say, a trusted list of values, we should be able to get a list
-- of trusted values out of it.
--
-- > trustElems :: Trusted [a] -> [Trusted a]
--
-- NOTE. It might appear that the more natural primitive to offer is a
-- 'sequenceA'-like operator such as
--
-- > trustSeq :: Applicative f => Trusted (f a) -> f (Trusted a)
--
-- However, this is unsound. To see this, consider that @((->) a)@ is
-- 'Applicative' (it's the reader monad); hence, we can instantiate 'trustSeq'
-- at
--
-- > trustSeq :: Trusted (a -> a) -> a -> Trusted a
--
-- and by passing @trustStatic (static id)@ make 'Trusted' a functor, which we
-- certainly don't want to do (see comments for 'Trusted').
--
-- So why is it okay when we insist on 'Traversable' rather than 'Applicative'?
-- To see this, it's instructive to consider how we might make a @((->) a)@ an
-- instance of 'Traversable'. If we define the domain of enumerable types as
--
-- > class Eq a => Enumerable a where
-- >   enumerate :: [a]
--
-- then we can make @((->) r)@ traversable by
--
-- > instance Enumerable r => Traversable ((->) r) where
-- >   sequenceA f = rebuild <$> sequenceA ((\r -> (r,) <$> f r) <$> enumerate)
-- >     where
-- >       rebuild :: [(r, a)] -> r -> a
-- >       rebuild fun arg = fromJust (lookup arg fun)
--
-- The idea is that if the domain of a function is enumerable, we can apply the
-- function to each possible input, collect the outputs, and construct a new
-- function by pairing the inputs with the outputs. I.e., if we had something of
-- type
--
-- > a -> IO b
--
-- and @a@ is enumerable, we just run the @IO@ action on each possible @a@ and
-- collect all @b@s to get a pure function @a -> b@. Of course, you probably
-- don't want to be doing that, but the point is that as far as the type system
-- is concerned you could.
--
-- In the context of 'Trusted', this means that we can derive
--
-- > enumPure :: Enumerable a => a -> Trusted a
--
-- but in a way this this makes sense anyway. If a domain is enumerable, it
-- would not be unreasonable to change @Enumerable@ to
--
-- > class Eq a => Enumerable a where
-- >   enumerate :: [StaticPtr a]
--
-- so we could define @enumPure@ as
--
-- > enumPure :: Enumerable a => a -> Trusted a
-- > enumPure x = trustStatic
-- >            $ fromJust (find ((== x) . deRefStaticPtr) enumerate)
--
-- In other words, we just enumerate the entire domain as trusted values
-- (because we defined them locally) and then return the one that matched the
-- untrusted value.
--
-- The conclusion from all of this is that the types of untrusted input  (like
-- the types of the TUF files we download from the server) should probably not
-- be considered enumerable.
trustElems :: Traversable f => Trusted (f a) -> f (Trusted a)
trustElems :: Trusted (f a) -> f (Trusted a)
trustElems (DeclareTrusted f a
fa) = a -> Trusted a
forall a. a -> Trusted a
DeclareTrusted (a -> Trusted a) -> f a -> f (Trusted a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` f a
fa

{-------------------------------------------------------------------------------
  Role verification
-------------------------------------------------------------------------------}

newtype SignaturesVerified a = SignaturesVerified { SignaturesVerified a -> a
signaturesVerified :: a }

-- | Errors thrown during role validation
data VerificationError =
     -- | Not enough signatures signed with the appropriate keys
     VerificationErrorSignatures TargetPath

     -- | The file is expired
   | VerificationErrorExpired TargetPath

     -- | The file version is less than the previous version
   | VerificationErrorVersion TargetPath

     -- | File information mismatch
   | VerificationErrorFileInfo TargetPath

     -- | We tried to lookup file information about a particular target file,
     -- but the information wasn't in the corresponding @targets.json@ file.
   | VerificationErrorUnknownTarget TargetPath

     -- | The metadata for the specified target is missing a SHA256
   | VerificationErrorMissingSHA256 TargetPath

     -- | Some verification errors materialize as deserialization errors
     --
     -- For example: if we try to deserialize a timestamp file but the timestamp
     -- key has been rolled over, deserialization of the file will fail with
     -- 'DeserializationErrorUnknownKey'.
   | VerificationErrorDeserialization TargetPath DeserializationError

     -- | The spec stipulates that if a verification error occurs during
     -- the check for updates, we must download new root information and
     -- start over. However, we limit how often we attempt this.
     --
     -- We record all verification errors that occurred before we gave up.
   | VerificationErrorLoop VerificationHistory
   deriving (Typeable)

-- | Root metadata updated (as part of the normal update process)
data RootUpdated = RootUpdated
  deriving (Typeable)

type VerificationHistory = [Either RootUpdated VerificationError]

#if MIN_VERSION_base(4,8,0)
deriving instance Show VerificationError
deriving instance Show RootUpdated
instance Exception VerificationError where displayException :: VerificationError -> String
displayException = VerificationError -> String
forall a. Pretty a => a -> String
pretty
instance Exception RootUpdated where displayException :: RootUpdated -> String
displayException = RootUpdated -> String
forall a. Pretty a => a -> String
pretty
#else
instance Exception VerificationError
instance Show VerificationError where show = pretty
instance Show RootUpdated where show = pretty
instance Exception RootUpdated
#endif

instance Pretty VerificationError where
  pretty :: VerificationError -> String
pretty (VerificationErrorSignatures TargetPath
file) =
      TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not have enough signatures signed with the appropriate keys"
  pretty (VerificationErrorExpired TargetPath
file) =
      TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is expired"
  pretty (VerificationErrorVersion TargetPath
file) =
      String
"Version of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is less than the previous version"
  pretty (VerificationErrorFileInfo TargetPath
file) =
      String
"Invalid hash for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
file
  pretty (VerificationErrorUnknownTarget TargetPath
file) =
      TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not found in corresponding target metadata"
  pretty (VerificationErrorMissingSHA256 TargetPath
file) =
      String
"Missing SHA256 hash for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
file
  pretty (VerificationErrorDeserialization TargetPath
file DeserializationError
err) =
      String
"Could not deserialize " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DeserializationError -> String
forall a. Pretty a => a -> String
pretty DeserializationError
err
  pretty (VerificationErrorLoop VerificationHistory
es) =
      String
"Verification loop. Errors in order:\n"
   String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((Either RootUpdated VerificationError -> String)
-> VerificationHistory -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS
-> (Either RootUpdated VerificationError -> String)
-> Either RootUpdated VerificationError
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RootUpdated -> String)
-> (VerificationError -> String)
-> Either RootUpdated VerificationError
-> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RootUpdated -> String
forall a. Pretty a => a -> String
pretty VerificationError -> String
forall a. Pretty a => a -> String
pretty) VerificationHistory
es)

instance Pretty RootUpdated where
  pretty :: RootUpdated -> String
pretty RootUpdated
RootUpdated = String
"Root information updated"

-- | Role verification
--
-- NOTE: We throw an error when the version number _decreases_, but allow it
-- to be the same. This is sufficient: the file number is there so that
-- attackers cannot replay old files. It cannot protect against freeze attacks
-- (that's what the expiry date is for), so "replaying" the same file is not
-- a problem. If an attacker changes the contents of the file but not the
-- version number we have an inconsistent situation, but this is not something
-- we need to worry about: in this case the attacker will need to resign the
-- file or otherwise the signature won't match, and if the attacker has
-- compromised the key then he might just as well increase the version number
-- and resign.
--
-- NOTE 2: We are not actually verifying the signatures _themselves_ here
-- (we did that when we parsed the JSON). We are merely verifying the provenance
-- of the keys.
verifyRole' :: forall a. HasHeader a
            => Trusted (RoleSpec a)     -- ^ For signature validation
            -> TargetPath               -- ^ File source (for error messages)
            -> Maybe FileVersion        -- ^ Previous version (if available)
            -> Maybe UTCTime            -- ^ Time now (if checking expiry)
            -> Signed a -> Either VerificationError (SignaturesVerified a)
verifyRole' :: Trusted (RoleSpec a)
-> TargetPath
-> Maybe FileVersion
-> Maybe UTCTime
-> Signed a
-> Either VerificationError (SignaturesVerified a)
verifyRole' (Trusted (RoleSpec a) -> RoleSpec a
forall a. Trusted a -> a
trusted -> RoleSpec{roleSpecThreshold :: forall a. RoleSpec a -> KeyThreshold
roleSpecThreshold = KeyThreshold Int54
threshold, [Some PublicKey]
roleSpecKeys :: forall a. RoleSpec a -> [Some PublicKey]
roleSpecKeys :: [Some PublicKey]
..})
            TargetPath
targetPath
            Maybe FileVersion
mPrev
            Maybe UTCTime
mNow
            Signed{signatures :: forall a. Signed a -> Signatures
signatures = Signatures [Signature]
sigs, a
signed :: forall a. Signed a -> a
signed :: a
..} =
    Except VerificationError (SignaturesVerified a)
-> Either VerificationError (SignaturesVerified a)
forall e a. Except e a -> Either e a
runExcept Except VerificationError (SignaturesVerified a)
go
  where
    go :: Except VerificationError (SignaturesVerified a)
    go :: Except VerificationError (SignaturesVerified a)
go = do
      -- Verify expiry date
      case Maybe UTCTime
mNow of
        Just UTCTime
now ->
          Bool
-> ExceptT VerificationError Identity ()
-> ExceptT VerificationError Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime -> FileExpires -> Bool
isExpired UTCTime
now (LensLike' (Const FileExpires) a FileExpires -> a -> FileExpires
forall a s. LensLike' (Const a) s a -> s -> a
Lens.get LensLike' (Const FileExpires) a FileExpires
forall a. HasHeader a => Lens' a FileExpires
fileExpires a
signed)) (ExceptT VerificationError Identity ()
 -> ExceptT VerificationError Identity ())
-> ExceptT VerificationError Identity ()
-> ExceptT VerificationError Identity ()
forall a b. (a -> b) -> a -> b
$
            VerificationError -> ExceptT VerificationError Identity ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerificationError -> ExceptT VerificationError Identity ())
-> VerificationError -> ExceptT VerificationError Identity ()
forall a b. (a -> b) -> a -> b
$ TargetPath -> VerificationError
VerificationErrorExpired TargetPath
targetPath
        Maybe UTCTime
_otherwise ->
          () -> ExceptT VerificationError Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- Verify timestamp
      case Maybe FileVersion
mPrev of
        Maybe FileVersion
Nothing   -> () -> ExceptT VerificationError Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just FileVersion
prev ->
          Bool
-> ExceptT VerificationError Identity ()
-> ExceptT VerificationError Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LensLike' (Const FileVersion) a FileVersion -> a -> FileVersion
forall a s. LensLike' (Const a) s a -> s -> a
Lens.get LensLike' (Const FileVersion) a FileVersion
forall a. HasHeader a => Lens' a FileVersion
fileVersion a
signed FileVersion -> FileVersion -> Bool
forall a. Ord a => a -> a -> Bool
< FileVersion
prev) (ExceptT VerificationError Identity ()
 -> ExceptT VerificationError Identity ())
-> ExceptT VerificationError Identity ()
-> ExceptT VerificationError Identity ()
forall a b. (a -> b) -> a -> b
$
            VerificationError -> ExceptT VerificationError Identity ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerificationError -> ExceptT VerificationError Identity ())
-> VerificationError -> ExceptT VerificationError Identity ()
forall a b. (a -> b) -> a -> b
$ TargetPath -> VerificationError
VerificationErrorVersion TargetPath
targetPath

      -- Verify signatures
      -- NOTE: We only need to verify the keys that were used; if the signature
      -- was invalid we would already have thrown an error constructing Signed.
      -- (Similarly, if two signatures were made by the same key, the FromJSON
      -- instance for Signatures would have thrown an error.)
      Bool
-> ExceptT VerificationError Identity ()
-> ExceptT VerificationError Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Signature] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Signature -> Bool) -> [Signature] -> [Signature]
forall a. (a -> Bool) -> [a] -> [a]
filter Signature -> Bool
isRoleSpecKey [Signature]
sigs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int54 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int54
threshold) (ExceptT VerificationError Identity ()
 -> ExceptT VerificationError Identity ())
-> ExceptT VerificationError Identity ()
-> ExceptT VerificationError Identity ()
forall a b. (a -> b) -> a -> b
$
        VerificationError -> ExceptT VerificationError Identity ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerificationError -> ExceptT VerificationError Identity ())
-> VerificationError -> ExceptT VerificationError Identity ()
forall a b. (a -> b) -> a -> b
$ TargetPath -> VerificationError
VerificationErrorSignatures TargetPath
targetPath

      -- Everything is A-OK!
      SignaturesVerified a
-> Except VerificationError (SignaturesVerified a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SignaturesVerified a
 -> Except VerificationError (SignaturesVerified a))
-> SignaturesVerified a
-> Except VerificationError (SignaturesVerified a)
forall a b. (a -> b) -> a -> b
$ a -> SignaturesVerified a
forall a. a -> SignaturesVerified a
SignaturesVerified a
signed

    isRoleSpecKey :: Signature -> Bool
    isRoleSpecKey :: Signature -> Bool
isRoleSpecKey Signature{ByteString
Some PublicKey
signatureKey :: Signature -> Some PublicKey
signature :: Signature -> ByteString
signatureKey :: Some PublicKey
signature :: ByteString
..} = Some PublicKey
signatureKey Some PublicKey -> [Some PublicKey] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Some PublicKey]
roleSpecKeys

-- | Variation on 'verifyRole' that uses key IDs rather than keys
--
-- This is used during the bootstrap process.
--
-- See <http://en.wikipedia.org/wiki/Public_key_fingerprint>.
verifyFingerprints :: [KeyId]
                   -> KeyThreshold
                   -> TargetPath      -- ^ For error messages
                   -> Signed Root
                   -> Either VerificationError (SignaturesVerified Root)
verifyFingerprints :: [KeyId]
-> KeyThreshold
-> TargetPath
-> Signed Root
-> Either VerificationError (SignaturesVerified Root)
verifyFingerprints [KeyId]
fingerprints
                   (KeyThreshold Int54
threshold)
                   TargetPath
targetPath
                   Signed{signatures :: forall a. Signed a -> Signatures
signatures = Signatures [Signature]
sigs, Root
signed :: Root
signed :: forall a. Signed a -> a
..} =
    if [Signature] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Signature -> Bool) -> [Signature] -> [Signature]
forall a. (a -> Bool) -> [a] -> [a]
filter Signature -> Bool
isTrustedKey [Signature]
sigs) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int54 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int54
threshold
      then SignaturesVerified Root
-> Either VerificationError (SignaturesVerified Root)
forall a b. b -> Either a b
Right (SignaturesVerified Root
 -> Either VerificationError (SignaturesVerified Root))
-> SignaturesVerified Root
-> Either VerificationError (SignaturesVerified Root)
forall a b. (a -> b) -> a -> b
$ Root -> SignaturesVerified Root
forall a. a -> SignaturesVerified a
SignaturesVerified Root
signed
      else VerificationError
-> Either VerificationError (SignaturesVerified Root)
forall a b. a -> Either a b
Left (VerificationError
 -> Either VerificationError (SignaturesVerified Root))
-> VerificationError
-> Either VerificationError (SignaturesVerified Root)
forall a b. (a -> b) -> a -> b
$ TargetPath -> VerificationError
VerificationErrorSignatures TargetPath
targetPath
  where
    isTrustedKey :: Signature -> Bool
    isTrustedKey :: Signature -> Bool
isTrustedKey Signature{ByteString
Some PublicKey
signatureKey :: Some PublicKey
signature :: ByteString
signatureKey :: Signature -> Some PublicKey
signature :: Signature -> ByteString
..} = Some PublicKey -> KeyId
forall (key :: * -> *). HasKeyId key => Some key -> KeyId
someKeyId Some PublicKey
signatureKey KeyId -> [KeyId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyId]
fingerprints