{-# 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 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 }
  deriving (Eq, Show)

trustStatic :: StaticPtr a -> Trusted a
trustStatic = DeclareTrusted . deRefStaticPtr

trustVerified :: SignaturesVerified a -> Trusted a
trustVerified = DeclareTrusted . 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 (DeclareTrusted f) (DeclareTrusted x) = DeclareTrusted (f 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 (DeclareTrusted fa) = DeclareTrusted `fmap` fa

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

newtype SignaturesVerified a = SignaturesVerified { 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 = pretty
instance Exception RootUpdated where displayException = 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 (VerificationErrorSignatures file) =
      pretty file ++ " does not have enough signatures signed with the appropriate keys"
  pretty (VerificationErrorExpired file) =
      pretty file ++ " is expired"
  pretty (VerificationErrorVersion file) =
      "Version of " ++ pretty file ++ " is less than the previous version"
  pretty (VerificationErrorFileInfo file) =
      "Invalid hash for " ++ pretty file
  pretty (VerificationErrorUnknownTarget file) =
      pretty file ++ " not found in corresponding target metadata"
  pretty (VerificationErrorMissingSHA256 file) =
      "Missing SHA256 hash for " ++ pretty file
  pretty (VerificationErrorDeserialization file err) =
      "Could not deserialize " ++ pretty file ++ ": " ++ pretty err
  pretty (VerificationErrorLoop es) =
      "Verification loop. Errors in order:\n"
   ++ unlines (map (("  " ++) . either pretty pretty) es)

instance Pretty RootUpdated where
  pretty RootUpdated = "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{roleSpecThreshold = KeyThreshold threshold, ..})
            targetPath
            mPrev
            mNow
            Signed{signatures = Signatures sigs, ..} =
    runExcept go
  where
    go :: Except VerificationError (SignaturesVerified a)
    go = do
      -- Verify expiry date
      case mNow of
        Just now ->
          when (isExpired now (Lens.get fileExpires signed)) $
            throwError $ VerificationErrorExpired targetPath
        _otherwise ->
          return ()

      -- Verify timestamp
      case mPrev of
        Nothing   -> return ()
        Just prev ->
          when (Lens.get fileVersion signed < prev) $
            throwError $ VerificationErrorVersion 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.)
      unless (length (filter isRoleSpecKey sigs) >= fromIntegral threshold) $
        throwError $ VerificationErrorSignatures targetPath

      -- Everything is A-OK!
      return $ SignaturesVerified signed

    isRoleSpecKey :: Signature -> Bool
    isRoleSpecKey Signature{..} = signatureKey `elem` 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 fingerprints
                   (KeyThreshold threshold)
                   targetPath
                   Signed{signatures = Signatures sigs, ..} =
    if length (filter isTrustedKey sigs) >= fromIntegral threshold
      then Right $ SignaturesVerified signed
      else Left $ VerificationErrorSignatures targetPath
  where
    isTrustedKey :: Signature -> Bool
    isTrustedKey Signature{..} = someKeyId signatureKey `elem` fingerprints