{-# 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 (when, unless)
import Control.Monad.Except (Except, runExcept, throwError)
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 { forall a. Trusted a -> a
trusted :: a }
  deriving (Trusted a -> Trusted a -> Bool
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
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 :: forall a. StaticPtr a -> Trusted a
trustStatic = forall a. a -> Trusted a
DeclareTrusted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. StaticPtr a -> a
deRefStaticPtr

trustVerified :: SignaturesVerified a -> Trusted a
trustVerified :: forall a. SignaturesVerified a -> Trusted a
trustVerified = forall a. a -> Trusted a
DeclareTrusted forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a b. Trusted (a -> b) -> Trusted a -> Trusted b
trustApply (DeclareTrusted a -> b
f) (DeclareTrusted a
x) = 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 :: forall (f :: * -> *) a.
Traversable f =>
Trusted (f a) -> f (Trusted a)
trustElems (DeclareTrusted f a
fa) = forall a. a -> Trusted a
DeclareTrusted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` f a
fa

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

newtype SignaturesVerified a = SignaturesVerified { forall a. 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 = forall a. Pretty a => a -> String
pretty
instance Exception RootUpdated where displayException :: RootUpdated -> String
displayException = 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) =
      forall a. Pretty a => a -> String
pretty TargetPath
file forall a. [a] -> [a] -> [a]
++ String
" does not have enough signatures signed with the appropriate keys"
  pretty (VerificationErrorExpired TargetPath
file) =
      forall a. Pretty a => a -> String
pretty TargetPath
file forall a. [a] -> [a] -> [a]
++ String
" is expired"
  pretty (VerificationErrorVersion TargetPath
file) =
      String
"Version of " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty TargetPath
file forall a. [a] -> [a] -> [a]
++ String
" is less than the previous version"
  pretty (VerificationErrorFileInfo TargetPath
file) =
      String
"Invalid hash for " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty TargetPath
file
  pretty (VerificationErrorUnknownTarget TargetPath
file) =
      forall a. Pretty a => a -> String
pretty TargetPath
file forall a. [a] -> [a] -> [a]
++ String
" not found in corresponding target metadata"
  pretty (VerificationErrorMissingSHA256 TargetPath
file) =
      String
"Missing SHA256 hash for " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty TargetPath
file
  pretty (VerificationErrorDeserialization TargetPath
file DeserializationError
err) =
      String
"Could not deserialize " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty TargetPath
file forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty DeserializationError
err
  pretty (VerificationErrorLoop VerificationHistory
es) =
      String
"Verification loop. Errors in order:\n"
   forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map ((String
"  " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Pretty a => a -> String
pretty 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' :: forall a.
HasHeader a =>
Trusted (RoleSpec a)
-> TargetPath
-> Maybe FileVersion
-> Maybe UTCTime
-> Signed a
-> Either VerificationError (SignaturesVerified a)
verifyRole' (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
..} =
    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 ->
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime -> FileExpires -> Bool
isExpired UTCTime
now (forall a s. LensLike' (Const a) s a -> s -> a
Lens.get forall a. HasHeader a => Lens' a FileExpires
fileExpires a
signed)) forall a b. (a -> b) -> a -> b
$
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ TargetPath -> VerificationError
VerificationErrorExpired TargetPath
targetPath
        Maybe UTCTime
_otherwise ->
          forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- Verify timestamp
      case Maybe FileVersion
mPrev of
        Maybe FileVersion
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just FileVersion
prev ->
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a s. LensLike' (Const a) s a -> s -> a
Lens.get forall a. HasHeader a => Lens' a FileVersion
fileVersion a
signed forall a. Ord a => a -> a -> Bool
< FileVersion
prev) forall a b. (a -> b) -> a -> b
$
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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.)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter Signature -> Bool
isRoleSpecKey [Signature]
sigs) forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Int54
threshold) forall a b. (a -> b) -> a -> b
$
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ TargetPath -> VerificationError
VerificationErrorSignatures TargetPath
targetPath

      -- Everything is A-OK!
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 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 forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter Signature -> Bool
isTrustedKey [Signature]
sigs) forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral Int54
threshold
      then forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> SignaturesVerified a
SignaturesVerified Root
signed
      else forall a b. a -> Either a b
Left 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
..} = forall (key :: * -> *). HasKeyId key => Some key -> KeyId
someKeyId Some PublicKey
signatureKey forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyId]
fingerprints