-- | The root filetype
module Hackage.Security.TUF.Root (
    -- * Datatypes
    Root(..)
  , RootRoles(..)
  , RoleSpec(..)
  ) 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.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
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
showList :: [RoleSpec a] -> ShowS
$cshowList :: forall a. [RoleSpec a] -> ShowS
show :: RoleSpec a -> String
$cshow :: forall a. RoleSpec a -> String
showsPrec :: Int -> RoleSpec a -> ShowS
$cshowsPrec :: forall a. Int -> RoleSpec a -> ShowS
Show)

instance HasHeader Root where
  fileVersion :: Lens' Root FileVersion
fileVersion FileVersion -> f FileVersion
f Root
x = (\FileVersion
y -> Root
x { rootVersion :: FileVersion
rootVersion = FileVersion
y }) 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 :: FileExpires
rootExpires = FileExpires
y }) 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
rootRolesMirrors :: RoleSpec Mirrors
rootRolesTimestamp :: RoleSpec Timestamp
rootRolesTargets :: RoleSpec Targets
rootRolesSnapshot :: RoleSpec Snapshot
rootRolesRoot :: RoleSpec Root
rootRolesMirrors :: RootRoles -> RoleSpec Mirrors
rootRolesTimestamp :: RootRoles -> RoleSpec Timestamp
rootRolesTargets :: RootRoles -> RoleSpec Targets
rootRolesSnapshot :: RootRoles -> RoleSpec Snapshot
rootRolesRoot :: RootRoles -> RoleSpec Root
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
      (String
"root"      , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RoleSpec Root
rootRolesRoot)
    , (String
"snapshot"  , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RoleSpec Snapshot
rootRolesSnapshot)
    , (String
"targets"   , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RoleSpec Targets
rootRolesTargets)
    , (String
"timestamp" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON RoleSpec Timestamp
rootRolesTimestamp)
    , (String
"mirrors"   , 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
    RoleSpec Root
rootRolesRoot      <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"root"
    RoleSpec Snapshot
rootRolesSnapshot  <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"snapshot"
    RoleSpec Targets
rootRolesTargets   <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"targets"
    RoleSpec Timestamp
rootRolesTimestamp <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"timestamp"
    RoleSpec Mirrors
rootRolesMirrors   <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"mirrors"
    forall (m :: * -> *) a. Monad m => a -> m a
return RootRoles{RoleSpec Mirrors
RoleSpec Timestamp
RoleSpec Targets
RoleSpec Snapshot
RoleSpec Root
rootRolesMirrors :: RoleSpec Mirrors
rootRolesTimestamp :: RoleSpec Timestamp
rootRolesTargets :: RoleSpec Targets
rootRolesSnapshot :: RoleSpec Snapshot
rootRolesRoot :: RoleSpec Root
rootRolesMirrors :: RoleSpec Mirrors
rootRolesTimestamp :: RoleSpec Timestamp
rootRolesTargets :: RoleSpec Targets
rootRolesSnapshot :: RoleSpec Snapshot
rootRolesRoot :: RoleSpec Root
..}

instance Monad m => ToJSON m Root where
  toJSON :: Root -> m JSValue
toJSON Root{KeyEnv
FileExpires
FileVersion
RootRoles
rootRoles :: RootRoles
rootKeys :: KeyEnv
rootExpires :: FileExpires
rootVersion :: FileVersion
rootRoles :: Root -> RootRoles
rootKeys :: Root -> KeyEnv
rootExpires :: Root -> FileExpires
rootVersion :: Root -> FileVersion
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
         (String
"_type"   , forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString String
"Root")
       , (String
"version" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileVersion
rootVersion)
       , (String
"expires" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileExpires
rootExpires)
       , (String
"keys"    , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON KeyEnv
rootKeys)
       , (String
"roles"   , 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
roleSpecThreshold :: KeyThreshold
roleSpecKeys :: [Some PublicKey]
roleSpecThreshold :: forall a. RoleSpec a -> KeyThreshold
roleSpecKeys :: forall a. RoleSpec a -> [Some PublicKey]
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
        (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]
roleSpecKeys)
      , (String
"threshold" , 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
    JSValue
enc      <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signed"
    KeyEnv
rootKeys <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc      String
"keys"
    forall (m :: * -> *) a. MonadKeys m => KeyEnv -> m a -> m a
withKeys KeyEnv
rootKeys forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *).
(ReportSchemaErrors m, MonadError DeserializationError m) =>
JSValue -> String -> m ()
verifyType JSValue
enc String
"Root"
      FileVersion
rootVersion <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"version"
      FileExpires
rootExpires <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"expires"
      RootRoles
rootRoles   <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"roles"
      let signed :: Root
signed = Root{KeyEnv
FileExpires
FileVersion
RootRoles
rootRoles :: RootRoles
rootExpires :: FileExpires
rootVersion :: FileVersion
rootKeys :: KeyEnv
rootRoles :: RootRoles
rootKeys :: KeyEnv
rootExpires :: FileExpires
rootVersion :: FileVersion
..}

      Signatures
signatures <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
envelope String
"signatures"
      forall (m :: * -> *).
MonadError DeserializationError m =>
String -> Bool -> m ()
validate String
"signatures" forall a b. (a -> b) -> a -> b
$ JSValue -> Signatures -> Bool
verifySignatures JSValue
enc Signatures
signatures
      forall (m :: * -> *) a. Monad m => a -> m a
return Signed{Signatures
Root
signatures :: Signatures
signed :: Root
signatures :: Signatures
signed :: Root
..}

instance MonadKeys m => FromJSON m (RoleSpec a) where
  fromJSON :: JSValue -> m (RoleSpec a)
fromJSON JSValue
enc = do
    [Some PublicKey]
roleSpecKeys      <- 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
roleSpecThreshold <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"threshold"
    forall (m :: * -> *) a. Monad m => a -> m a
return RoleSpec{[Some PublicKey]
KeyThreshold
roleSpecThreshold :: KeyThreshold
roleSpecKeys :: [Some PublicKey]
roleSpecThreshold :: KeyThreshold
roleSpecKeys :: [Some PublicKey]
..}