-- | The root filetype
module Hackage.Security.TUF.Root (
    -- * Datatypes
    Root(..)
  , RootRoles(..)
  , RoleSpec(..)
  ) where

import Prelude
import Hackage.Security.JSON
import Hackage.Security.Key
import Hackage.Security.Key.Env (KeyEnv)
import Hackage.Security.TUF.Common
import Hackage.Security.TUF.Header
import Hackage.Security.TUF.Mirrors
import Hackage.Security.TUF.Signed
import Hackage.Security.TUF.Snapshot
import Hackage.Security.TUF.Targets
import Hackage.Security.TUF.Timestamp
import Hackage.Security.Util.Some

{-------------------------------------------------------------------------------
  Datatypes
-------------------------------------------------------------------------------}

-- | The root metadata
--
-- NOTE: We must have the invariant that ALL keys (apart from delegation keys)
-- must be listed in 'rootKeys'. (Delegation keys satisfy a similar invariant,
-- see Targets.)
data Root = Root {
    Root -> FileVersion
rootVersion :: FileVersion
  , Root -> FileExpires
rootExpires :: FileExpires
  , Root -> KeyEnv
rootKeys    :: KeyEnv
  , Root -> RootRoles
rootRoles   :: RootRoles
  }

data RootRoles = RootRoles {
    RootRoles -> RoleSpec Root
rootRolesRoot      :: RoleSpec Root
  , RootRoles -> RoleSpec Snapshot
rootRolesSnapshot  :: RoleSpec Snapshot
  , RootRoles -> RoleSpec Targets
rootRolesTargets   :: RoleSpec Targets
  , RootRoles -> RoleSpec Timestamp
rootRolesTimestamp :: RoleSpec Timestamp
  , RootRoles -> RoleSpec Mirrors
rootRolesMirrors   :: RoleSpec Mirrors
  }

-- | Role specification
--
-- The phantom type indicates what kind of type this role is meant to verify.
data RoleSpec a = RoleSpec {
    forall a. RoleSpec a -> [Some PublicKey]
roleSpecKeys      :: [Some PublicKey]
  , forall a. RoleSpec a -> KeyThreshold
roleSpecThreshold :: KeyThreshold
  }
  deriving (Int -> RoleSpec a -> ShowS
[RoleSpec a] -> ShowS
RoleSpec a -> String
(Int -> RoleSpec a -> ShowS)
-> (RoleSpec a -> String)
-> ([RoleSpec a] -> ShowS)
-> Show (RoleSpec a)
forall a. Int -> RoleSpec a -> ShowS
forall a. [RoleSpec a] -> ShowS
forall a. RoleSpec a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> RoleSpec a -> ShowS
showsPrec :: Int -> RoleSpec a -> ShowS
$cshow :: forall a. RoleSpec a -> String
show :: RoleSpec a -> String
$cshowList :: forall a. [RoleSpec a] -> ShowS
showList :: [RoleSpec a] -> ShowS
Show)

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

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

instance Monad m => ToJSON m RootRoles where
  toJSON :: RootRoles -> m JSValue
toJSON RootRoles{RoleSpec Mirrors
RoleSpec Timestamp
RoleSpec Targets
RoleSpec Snapshot
RoleSpec Root
rootRolesRoot :: RootRoles -> RoleSpec Root
rootRolesSnapshot :: RootRoles -> RoleSpec Snapshot
rootRolesTargets :: RootRoles -> RoleSpec Targets
rootRolesTimestamp :: RootRoles -> RoleSpec Timestamp
rootRolesMirrors :: RootRoles -> RoleSpec Mirrors
rootRolesRoot :: RoleSpec Root
rootRolesSnapshot :: RoleSpec Snapshot
rootRolesTargets :: RoleSpec Targets
rootRolesTimestamp :: RoleSpec Timestamp
rootRolesMirrors :: RoleSpec Mirrors
..} = [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
      (String
"root"      , RoleSpec Root -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RoleSpec Root
rootRolesRoot)
    , (String
"snapshot"  , RoleSpec Snapshot -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RoleSpec Snapshot
rootRolesSnapshot)
    , (String
"targets"   , RoleSpec Targets -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RoleSpec Targets
rootRolesTargets)
    , (String
"timestamp" , RoleSpec Timestamp -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RoleSpec Timestamp
rootRolesTimestamp)
    , (String
"mirrors"   , RoleSpec Mirrors -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RoleSpec Mirrors
rootRolesMirrors)
    ]

instance MonadKeys m => FromJSON m RootRoles where
  fromJSON :: JSValue -> m RootRoles
fromJSON JSValue
enc = do
    rootRolesRoot      <- JSValue -> String -> m (RoleSpec Root)
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"root"
    rootRolesSnapshot  <- fromJSField enc "snapshot"
    rootRolesTargets   <- fromJSField enc "targets"
    rootRolesTimestamp <- fromJSField enc "timestamp"
    rootRolesMirrors   <- fromJSField enc "mirrors"
    return RootRoles{..}

instance Monad m => ToJSON m Root where
  toJSON :: Root -> m JSValue
toJSON Root{KeyEnv
FileExpires
FileVersion
RootRoles
rootKeys :: Root -> KeyEnv
rootVersion :: Root -> FileVersion
rootExpires :: Root -> FileExpires
rootRoles :: Root -> RootRoles
rootVersion :: FileVersion
rootExpires :: FileExpires
rootKeys :: KeyEnv
rootRoles :: RootRoles
..} = [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
         (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
"Root")
       , (String
"version" , FileVersion -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileVersion
rootVersion)
       , (String
"expires" , FileExpires -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileExpires
rootExpires)
       , (String
"keys"    , KeyEnv -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON KeyEnv
rootKeys)
       , (String
"roles"   , RootRoles -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RootRoles
rootRoles)
       ]

instance Monad m => ToJSON m (RoleSpec a) where
  toJSON :: RoleSpec a -> m JSValue
toJSON RoleSpec{[Some PublicKey]
KeyThreshold
roleSpecKeys :: forall a. RoleSpec a -> [Some PublicKey]
roleSpecThreshold :: forall a. RoleSpec a -> KeyThreshold
roleSpecKeys :: [Some PublicKey]
roleSpecThreshold :: KeyThreshold
..} = [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
        (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]
roleSpecKeys)
      , (String
"threshold" , KeyThreshold -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON KeyThreshold
roleSpecThreshold)
      ]

-- | We give an instance for Signed Root rather than Root because the key
-- environment from the root data is necessary to resolve the explicit sharing
-- in the signatures.
instance MonadKeys m => FromJSON m (Signed Root) where
  fromJSON :: JSValue -> m (Signed Root)
fromJSON JSValue
envelope = do
    enc      <- JSValue -> String -> m JSValue
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signed"
    rootKeys <- fromJSField enc      "keys"
    withKeys rootKeys $ do
      verifyType enc "Root"
      rootVersion <- fromJSField enc "version"
      rootExpires <- fromJSField enc "expires"
      rootRoles   <- fromJSField enc "roles"
      let signed = Root{KeyEnv
FileExpires
FileVersion
RootRoles
rootKeys :: KeyEnv
rootVersion :: FileVersion
rootExpires :: FileExpires
rootRoles :: RootRoles
rootKeys :: KeyEnv
rootVersion :: FileVersion
rootExpires :: FileExpires
rootRoles :: RootRoles
..}

      signatures <- fromJSField envelope "signatures"
      validate "signatures" $ verifySignatures enc signatures
      return Signed{..}

instance MonadKeys m => FromJSON m (RoleSpec a) where
  fromJSON :: JSValue -> m (RoleSpec a)
fromJSON JSValue
enc = do
    roleSpecKeys      <- (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"
    roleSpecThreshold <- fromJSField enc "threshold"
    return RoleSpec{..}