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 {
    Targets -> FileVersion
targetsVersion     :: FileVersion
  , Targets -> FileExpires
targetsExpires     :: FileExpires
  , Targets -> FileMap
targetsTargets     :: FileMap
  , Targets -> Maybe Delegations
targetsDelegations :: Maybe Delegations
  }
  deriving (Int -> Targets -> ShowS
[Targets] -> ShowS
Targets -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Targets] -> ShowS
$cshowList :: [Targets] -> ShowS
show :: Targets -> String
$cshow :: Targets -> String
showsPrec :: Int -> Targets -> ShowS
$cshowsPrec :: Int -> Targets -> ShowS
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 {
    Delegations -> KeyEnv
delegationsKeys  :: KeyEnv
  , Delegations -> [DelegationSpec]
delegationsRoles :: [DelegationSpec]
  }
  deriving (Int -> Delegations -> ShowS
[Delegations] -> ShowS
Delegations -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Delegations] -> ShowS
$cshowList :: [Delegations] -> ShowS
show :: Delegations -> String
$cshow :: Delegations -> String
showsPrec :: Int -> Delegations -> ShowS
$cshowsPrec :: Int -> Delegations -> ShowS
Show)

-- | Delegation specification
--
-- NOTE: This is a close analogue of 'RoleSpec'.
data DelegationSpec = DelegationSpec {
    DelegationSpec -> [Some PublicKey]
delegationSpecKeys      :: [Some PublicKey]
  , DelegationSpec -> KeyThreshold
delegationSpecThreshold :: KeyThreshold
  , DelegationSpec -> Delegation
delegation              :: Delegation
  }
  deriving (Int -> DelegationSpec -> ShowS
[DelegationSpec] -> ShowS
DelegationSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DelegationSpec] -> ShowS
$cshowList :: [DelegationSpec] -> ShowS
show :: DelegationSpec -> String
$cshow :: DelegationSpec -> String
showsPrec :: Int -> DelegationSpec -> ShowS
$cshowsPrec :: Int -> DelegationSpec -> ShowS
Show)

instance HasHeader Targets where
  fileVersion :: Lens' Targets FileVersion
fileVersion FileVersion -> f FileVersion
f Targets
x = (\FileVersion
y -> Targets
x { targetsVersion :: FileVersion
targetsVersion = FileVersion
y }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FileVersion -> f FileVersion
f (Targets -> FileVersion
targetsVersion Targets
x)
  fileExpires :: Lens' Targets FileExpires
fileExpires FileExpires -> f FileExpires
f Targets
x = (\FileExpires
y -> Targets
x { targetsExpires :: FileExpires
targetsExpires = FileExpires
y }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FileExpires -> f FileExpires
f (Targets -> FileExpires
targetsExpires Targets
x)

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

targetsLookup :: TargetPath -> Targets -> Maybe FileInfo
targetsLookup :: TargetPath -> Targets -> Maybe FileInfo
targetsLookup TargetPath
fp Targets{Maybe Delegations
FileExpires
FileVersion
FileMap
targetsDelegations :: Maybe Delegations
targetsTargets :: FileMap
targetsExpires :: FileExpires
targetsVersion :: FileVersion
targetsDelegations :: Targets -> Maybe Delegations
targetsTargets :: Targets -> FileMap
targetsExpires :: Targets -> FileExpires
targetsVersion :: Targets -> FileVersion
..} = TargetPath -> FileMap -> Maybe FileInfo
FileMap.lookup TargetPath
fp FileMap
targetsTargets

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

instance Monad m => ToJSON m DelegationSpec where
  toJSON :: DelegationSpec -> m JSValue
toJSON DelegationSpec{delegation :: DelegationSpec -> Delegation
delegation = Delegation Pattern a
fp Replacement a
name, [Some PublicKey]
KeyThreshold
delegationSpecThreshold :: KeyThreshold
delegationSpecKeys :: [Some PublicKey]
delegationSpecThreshold :: DelegationSpec -> KeyThreshold
delegationSpecKeys :: DelegationSpec -> [Some PublicKey]
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
        (String
"name"      , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON Replacement a
name)
      , (String
"keyids"    , forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JSValue] -> JSValue
JSArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Some PublicKey -> JSValue
writeKeyAsId forall a b. (a -> b) -> a -> b
$ [Some PublicKey]
delegationSpecKeys)
      , (String
"threshold" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON KeyThreshold
delegationSpecThreshold)
      , (String
"path"      , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON Pattern a
fp)
      ]

instance MonadKeys m => FromJSON m DelegationSpec where
  fromJSON :: JSValue -> m DelegationSpec
fromJSON JSValue
enc = do
    String
delegationName          <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"name"
    [Some PublicKey]
delegationSpecKeys      <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadKeys m => JSValue -> m (Some PublicKey)
readKeyAsId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"keyids"
    KeyThreshold
delegationSpecThreshold <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"threshold"
    String
delegationPath          <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"path"
    case String -> String -> Either String Delegation
parseDelegation String
delegationName String
delegationPath of
      Left  String
err        -> forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected (String
"valid name/path combination: " forall a. [a] -> [a] -> [a]
++ String
err) forall a. Maybe a
Nothing
      Right Delegation
delegation -> forall (m :: * -> *) a. Monad m => a -> m a
return DelegationSpec{[Some PublicKey]
Delegation
KeyThreshold
delegation :: Delegation
delegationSpecThreshold :: KeyThreshold
delegationSpecKeys :: [Some PublicKey]
delegation :: Delegation
delegationSpecThreshold :: KeyThreshold
delegationSpecKeys :: [Some PublicKey]
..}

-- 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 -> m JSValue
toJSON Delegations{[DelegationSpec]
KeyEnv
delegationsRoles :: [DelegationSpec]
delegationsKeys :: KeyEnv
delegationsRoles :: Delegations -> [DelegationSpec]
delegationsKeys :: Delegations -> KeyEnv
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
        (String
"keys"  , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON KeyEnv
delegationsKeys)
      , (String
"roles" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON [DelegationSpec]
delegationsRoles)
      ]

instance MonadKeys m => FromJSON m Delegations where
  fromJSON :: JSValue -> m Delegations
fromJSON JSValue
enc = do
    KeyEnv
delegationsKeys  <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"keys"
    [DelegationSpec]
delegationsRoles <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"roles"
    forall (m :: * -> *) a. Monad m => a -> m a
return Delegations{[DelegationSpec]
KeyEnv
delegationsRoles :: [DelegationSpec]
delegationsKeys :: KeyEnv
delegationsRoles :: [DelegationSpec]
delegationsKeys :: KeyEnv
..}

instance Monad m => ToJSON m Targets where
  toJSON :: Targets -> m JSValue
toJSON Targets{Maybe Delegations
FileExpires
FileVersion
FileMap
targetsDelegations :: Maybe Delegations
targetsTargets :: FileMap
targetsExpires :: FileExpires
targetsVersion :: FileVersion
targetsDelegations :: Targets -> Maybe Delegations
targetsTargets :: Targets -> FileMap
targetsExpires :: Targets -> FileExpires
targetsVersion :: Targets -> FileVersion
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [
      [ (String
"_type"       , forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString String
"Targets")
      , (String
"version"     , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileVersion
targetsVersion)
      , (String
"expires"     , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileExpires
targetsExpires)
      , (String
"targets"     , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileMap
targetsTargets)
      ]
    , [ (String
"delegations" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON Delegations
d) | Just Delegations
d <- [ Maybe Delegations
targetsDelegations ] ]
    ]

instance MonadKeys m => FromJSON m Targets where
  fromJSON :: JSValue -> m Targets
fromJSON JSValue
enc = do
    forall (m :: * -> *).
(ReportSchemaErrors m, MonadError DeserializationError m) =>
JSValue -> String -> m ()
verifyType JSValue
enc String
"Targets"
    FileVersion
targetsVersion     <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField    JSValue
enc String
"version"
    FileExpires
targetsExpires     <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField    JSValue
enc String
"expires"
    FileMap
targetsTargets     <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField    JSValue
enc String
"targets"
    Maybe Delegations
targetsDelegations <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m (Maybe a)
fromJSOptField JSValue
enc String
"delegations"
    forall (m :: * -> *) a. Monad m => a -> m a
return Targets{Maybe Delegations
FileExpires
FileVersion
FileMap
targetsDelegations :: Maybe Delegations
targetsTargets :: FileMap
targetsExpires :: FileExpires
targetsVersion :: FileVersion
targetsDelegations :: Maybe Delegations
targetsTargets :: FileMap
targetsExpires :: FileExpires
targetsVersion :: FileVersion
..}

-- 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 :: JSValue -> m (Signed Targets)
fromJSON = forall (m :: * -> *) a.
(MonadKeys m, FromJSON m a) =>
JSValue -> m (Signed a)
signedFromJSON