Targets.hs

module Hackage.Security.TUF.Targets (
    -- * TUF types
    Targets(..)
  , Delegations(..)
  , DelegationSpec(..)
  , Delegation(..)
    -- ** Util
  , targetsLookup
  ) where

import MyPrelude
import Hackage.Security.JSON
import Hackage.Security.Key
import Hackage.Security.Key.Env (KeyEnv)
import Hackage.Security.TUF.Common
import Hackage.Security.TUF.FileInfo
import Hackage.Security.TUF.FileMap (FileMap, TargetPath)
import Hackage.Security.TUF.Header
import Hackage.Security.TUF.Patterns
import Hackage.Security.TUF.Signed
import Hackage.Security.Util.Some
import qualified Hackage.Security.TUF.FileMap as FileMap

{-------------------------------------------------------------------------------
  TUF types
-------------------------------------------------------------------------------}

-- | Target metadata
--
-- Most target files do not need expiry dates because they are not subject to
-- change (and hence attacks like freeze attacks are not a concern).
data Targets = Targets {
    targetsVersion     :: FileVersion
  , targetsExpires     :: FileExpires
  , targetsTargets     :: FileMap
  , targetsDelegations :: Maybe Delegations
  }
  deriving (Show)

-- | Delegations
--
-- Much like the Root datatype, this must have an invariant that ALL used keys
-- (apart from the global keys, which are in the root key environment) must
-- be listed in 'delegationsKeys'.
data Delegations = Delegations {
    delegationsKeys  :: KeyEnv
  , delegationsRoles :: [DelegationSpec]
  }
  deriving (Show)

-- | Delegation specification
--
-- NOTE: This is a close analogue of 'RoleSpec'.
data DelegationSpec = DelegationSpec {
    delegationSpecKeys      :: [Some PublicKey]
  , delegationSpecThreshold :: KeyThreshold
  , delegation              :: Delegation
  }
  deriving (Show)

instance HasHeader Targets where
  fileVersion f x = (\y -> x { targetsVersion = y }) <$> f (targetsVersion x)
  fileExpires f x = (\y -> x { targetsExpires = y }) <$> f (targetsExpires x)

{-------------------------------------------------------------------------------
  Utility
-------------------------------------------------------------------------------}

targetsLookup :: TargetPath -> Targets -> Maybe FileInfo
targetsLookup fp Targets{..} = FileMap.lookup fp targetsTargets

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

instance Monad m => ToJSON m DelegationSpec where
  toJSON DelegationSpec{delegation = Delegation fp name, ..} = mkObject [
        ("name"      , toJSON name)
      , ("keyids"    , return . JSArray . map writeKeyAsId $ delegationSpecKeys)
      , ("threshold" , toJSON delegationSpecThreshold)
      , ("path"      , toJSON fp)
      ]

instance MonadKeys m => FromJSON m DelegationSpec where
  fromJSON enc = do
    delegationName          <- fromJSField enc "name"
    delegationSpecKeys      <- mapM readKeyAsId =<< fromJSField enc "keyids"
    delegationSpecThreshold <- fromJSField enc "threshold"
    delegationPath          <- fromJSField enc "path"
    case parseDelegation delegationName delegationPath of
      Left  err        -> expected ("valid name/path combination: " ++ err) Nothing
      Right delegation -> return DelegationSpec{..}

-- NOTE: Unlike the Root object, the keys that are used to sign the delegations
-- are NOT listed inside the delegations, so the same "bootstrapping" problems
-- do not arise here.
instance Monad m => ToJSON m Delegations where
  toJSON Delegations{..} = mkObject [
        ("keys"  , toJSON delegationsKeys)
      , ("roles" , toJSON delegationsRoles)
      ]

instance MonadKeys m => FromJSON m Delegations where
  fromJSON enc = do
    delegationsKeys  <- fromJSField enc "keys"
    delegationsRoles <- fromJSField enc "roles"
    return Delegations{..}

instance Monad m => ToJSON m Targets where
  toJSON Targets{..} = mkObject $ mconcat [
      [ ("_type"       , return $ JSString "Targets")
      , ("version"     , toJSON targetsVersion)
      , ("expires"     , toJSON targetsExpires)
      , ("targets"     , toJSON targetsTargets)
      ]
    , [ ("delegations" , toJSON d) | Just d <- [ targetsDelegations ] ]
    ]

instance MonadKeys m => FromJSON m Targets where
  fromJSON enc = do
    verifyType enc "Targets"
    targetsVersion     <- fromJSField    enc "version"
    targetsExpires     <- fromJSField    enc "expires"
    targetsTargets     <- fromJSField    enc "targets"
    targetsDelegations <- fromJSOptField enc "delegations"
    return Targets{..}

-- TODO: This is okay right now because targets do not introduce additional
-- keys, but will no longer be okay once we have author keys.
instance MonadKeys m => FromJSON m (Signed Targets) where
  fromJSON = signedFromJSON