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
(Int -> Targets -> ShowS)
-> (Targets -> String) -> ([Targets] -> ShowS) -> Show Targets
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Targets -> ShowS
showsPrec :: Int -> Targets -> ShowS
$cshow :: Targets -> String
show :: Targets -> String
$cshowList :: [Targets] -> ShowS
showList :: [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
(Int -> Delegations -> ShowS)
-> (Delegations -> String)
-> ([Delegations] -> ShowS)
-> Show Delegations
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Delegations -> ShowS
showsPrec :: Int -> Delegations -> ShowS
$cshow :: Delegations -> String
show :: Delegations -> String
$cshowList :: [Delegations] -> ShowS
showList :: [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
(Int -> DelegationSpec -> ShowS)
-> (DelegationSpec -> String)
-> ([DelegationSpec] -> ShowS)
-> Show DelegationSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DelegationSpec -> ShowS
showsPrec :: Int -> DelegationSpec -> ShowS
$cshow :: DelegationSpec -> String
show :: DelegationSpec -> String
$cshowList :: [DelegationSpec] -> ShowS
showList :: [DelegationSpec] -> ShowS
Show)

instance HasHeader Targets where
  fileVersion :: Lens' Targets FileVersion
fileVersion FileVersion -> f FileVersion
f Targets
x = (\FileVersion
y -> Targets
x { targetsVersion = y }) (FileVersion -> Targets) -> f FileVersion -> f Targets
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 = y }) (FileExpires -> Targets) -> f FileExpires -> f Targets
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
targetsVersion :: Targets -> FileVersion
targetsExpires :: Targets -> FileExpires
targetsTargets :: Targets -> FileMap
targetsDelegations :: Targets -> Maybe Delegations
targetsVersion :: FileVersion
targetsExpires :: FileExpires
targetsTargets :: FileMap
targetsDelegations :: Maybe Delegations
..} = 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
delegationSpecKeys :: DelegationSpec -> [Some PublicKey]
delegationSpecThreshold :: DelegationSpec -> KeyThreshold
delegationSpecKeys :: [Some PublicKey]
delegationSpecThreshold :: KeyThreshold
..} = [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
        (String
"name"      , Replacement a -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON Replacement a
name)
      , (String
"keyids"    , JSValue -> m JSValue
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> m JSValue)
-> ([Some PublicKey] -> JSValue) -> [Some PublicKey] -> m JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JSValue] -> JSValue
JSArray ([JSValue] -> JSValue)
-> ([Some PublicKey] -> [JSValue]) -> [Some PublicKey] -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Some PublicKey -> JSValue) -> [Some PublicKey] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map Some PublicKey -> JSValue
writeKeyAsId ([Some PublicKey] -> m JSValue) -> [Some PublicKey] -> m JSValue
forall a b. (a -> b) -> a -> b
$ [Some PublicKey]
delegationSpecKeys)
      , (String
"threshold" , KeyThreshold -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON KeyThreshold
delegationSpecThreshold)
      , (String
"path"      , Pattern a -> m JSValue
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          <- JSValue -> String -> m String
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"name"
    [Some PublicKey]
delegationSpecKeys      <- (JSValue -> m (Some PublicKey)) -> [JSValue] -> m [Some PublicKey]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM JSValue -> m (Some PublicKey)
forall (m :: * -> *). MonadKeys m => JSValue -> m (Some PublicKey)
readKeyAsId ([JSValue] -> m [Some PublicKey])
-> m [JSValue] -> m [Some PublicKey]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSValue -> String -> m [JSValue]
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"keyids"
    KeyThreshold
delegationSpecThreshold <- JSValue -> String -> m KeyThreshold
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"threshold"
    String
delegationPath          <- JSValue -> String -> m String
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        -> String -> Maybe String -> m DelegationSpec
forall a. String -> Maybe String -> m a
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected (String
"valid name/path combination: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err) Maybe String
forall a. Maybe a
Nothing
      Right Delegation
delegation -> DelegationSpec -> m DelegationSpec
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return DelegationSpec{[Some PublicKey]
Delegation
KeyThreshold
delegationSpecKeys :: [Some PublicKey]
delegationSpecThreshold :: KeyThreshold
delegation :: Delegation
delegationSpecKeys :: [Some PublicKey]
delegationSpecThreshold :: KeyThreshold
delegation :: Delegation
..}

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

instance Monad m => ToJSON m Targets where
  toJSON :: Targets -> m JSValue
toJSON Targets{Maybe Delegations
FileExpires
FileVersion
FileMap
targetsVersion :: Targets -> FileVersion
targetsExpires :: Targets -> FileExpires
targetsTargets :: Targets -> FileMap
targetsDelegations :: Targets -> Maybe Delegations
targetsVersion :: FileVersion
targetsExpires :: FileExpires
targetsTargets :: FileMap
targetsDelegations :: Maybe Delegations
..} = [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject ([(String, m JSValue)] -> m JSValue)
-> [(String, m JSValue)] -> m JSValue
forall a b. (a -> b) -> a -> b
$ [[(String, m JSValue)]] -> [(String, m JSValue)]
forall a. Monoid a => [a] -> a
mconcat [
      [ (String
"_type"       , JSValue -> m JSValue
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> m JSValue) -> JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString String
"Targets")
      , (String
"version"     , FileVersion -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileVersion
targetsVersion)
      , (String
"expires"     , FileExpires -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileExpires
targetsExpires)
      , (String
"targets"     , FileMap -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileMap
targetsTargets)
      ]
    , [ (String
"delegations" , Delegations -> m JSValue
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
    JSValue -> String -> m ()
forall (m :: * -> *).
(ReportSchemaErrors m, MonadError DeserializationError m) =>
JSValue -> String -> m ()
verifyType JSValue
enc String
"Targets"
    FileVersion
targetsVersion     <- JSValue -> String -> m FileVersion
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField    JSValue
enc String
"version"
    FileExpires
targetsExpires     <- JSValue -> String -> m FileExpires
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField    JSValue
enc String
"expires"
    FileMap
targetsTargets     <- JSValue -> String -> m FileMap
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField    JSValue
enc String
"targets"
    Maybe Delegations
targetsDelegations <- JSValue -> String -> m (Maybe Delegations)
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m (Maybe a)
fromJSOptField JSValue
enc String
"delegations"
    Targets -> m Targets
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Targets{Maybe Delegations
FileExpires
FileVersion
FileMap
targetsVersion :: FileVersion
targetsExpires :: FileExpires
targetsTargets :: FileMap
targetsDelegations :: Maybe Delegations
targetsVersion :: FileVersion
targetsExpires :: FileExpires
targetsTargets :: FileMap
targetsDelegations :: Maybe Delegations
..}

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