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

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
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
(Int -> Delegations -> ShowS)
-> (Delegations -> String)
-> ([Delegations] -> ShowS)
-> Show Delegations
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
(Int -> DelegationSpec -> ShowS)
-> (DelegationSpec -> String)
-> ([DelegationSpec] -> ShowS)
-> Show DelegationSpec
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 :: LensLike f Targets Targets FileVersion FileVersion
fileVersion FileVersion -> f FileVersion
f Targets
x = (\FileVersion
y -> Targets
x { targetsVersion :: FileVersion
targetsVersion = FileVersion
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 :: LensLike f Targets Targets FileExpires FileExpires
fileExpires FileExpires -> f FileExpires
f Targets
x = (\FileExpires
y -> Targets
x { targetsExpires :: FileExpires
targetsExpires = FileExpires
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
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]
..} = [(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 (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)
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 (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 (m :: * -> *) a. Monad m => a -> m a
return DelegationSpec :: [Some PublicKey] -> KeyThreshold -> Delegation -> DelegationSpec
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
..} = [(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 (m :: * -> *) a. Monad m => a -> m a
return Delegations :: KeyEnv -> [DelegationSpec] -> Delegations
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
..} = [(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 (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 (m :: * -> *) a. Monad m => a -> m a
return Targets :: FileVersion
-> FileExpires -> FileMap -> Maybe Delegations -> Targets
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 = JSValue -> m (Signed Targets)
forall (m :: * -> *) a.
(MonadKeys m, FromJSON m a) =>
JSValue -> m (Signed a)
signedFromJSON