{-# LANGUAGE UndecidableInstances #-}
module Hackage.Security.TUF.Timestamp (
    Timestamp(..)
  ) where

import MyPrelude
import Control.Monad.Except
import Control.Monad.Reader

import Hackage.Security.JSON
import Hackage.Security.TUF.FileInfo
import Hackage.Security.TUF.FileMap
import Hackage.Security.TUF.Header
import Hackage.Security.TUF.Layout.Repo
import Hackage.Security.TUF.Signed
import qualified Hackage.Security.TUF.FileMap as FileMap
import Hackage.Security.Util.Pretty (pretty)

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

data Timestamp = Timestamp {
    Timestamp -> FileVersion
timestampVersion      :: FileVersion
  , Timestamp -> FileExpires
timestampExpires      :: FileExpires
  , Timestamp -> FileInfo
timestampInfoSnapshot :: FileInfo
  }

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

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

instance MonadReader RepoLayout m => ToJSON m Timestamp where
  toJSON :: Timestamp -> m JSValue
toJSON Timestamp{FileExpires
FileVersion
FileInfo
timestampInfoSnapshot :: FileInfo
timestampExpires :: FileExpires
timestampVersion :: FileVersion
timestampInfoSnapshot :: Timestamp -> FileInfo
timestampExpires :: Timestamp -> FileExpires
timestampVersion :: Timestamp -> FileVersion
..} = do
      RepoLayout
repoLayout <- forall r (m :: * -> *). MonadReader r m => m r
ask
      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
"Timestamp")
        , (String
"version" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileVersion
timestampVersion)
        , (String
"expires" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileExpires
timestampExpires)
        , (String
"meta"    , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (RepoLayout -> FileMap
timestampMeta RepoLayout
repoLayout))
        ]
    where
      timestampMeta :: RepoLayout -> FileMap
timestampMeta RepoLayout
repoLayout = [(TargetPath, FileInfo)] -> FileMap
FileMap.fromList [
          (RepoLayout -> TargetPath
pathSnapshot RepoLayout
repoLayout, FileInfo
timestampInfoSnapshot)
        ]

instance ( MonadReader RepoLayout m
         , MonadError DeserializationError m
         , ReportSchemaErrors m
         ) => FromJSON m Timestamp where
  fromJSON :: JSValue -> m Timestamp
fromJSON JSValue
enc = do
    forall (m :: * -> *).
(ReportSchemaErrors m, MonadError DeserializationError m) =>
JSValue -> String -> m ()
verifyType JSValue
enc String
"Timestamp"
    RepoLayout
repoLayout            <- forall r (m :: * -> *). MonadReader r m => m r
ask
    FileVersion
timestampVersion      <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"version"
    FileExpires
timestampExpires      <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"expires"
    FileMap
timestampMeta         <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"meta"
    let lookupMeta :: TargetPath -> m FileInfo
lookupMeta TargetPath
k = case TargetPath -> FileMap -> Maybe FileInfo
FileMap.lookup TargetPath
k FileMap
timestampMeta of
          Maybe FileInfo
Nothing -> forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected (String
"\"" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty TargetPath
k forall a. [a] -> [a] -> [a]
++ String
"\" entry in .meta object") forall a. Maybe a
Nothing
          Just FileInfo
v  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FileInfo
v
    FileInfo
timestampInfoSnapshot <- TargetPath -> m FileInfo
lookupMeta (RepoLayout -> TargetPath
pathSnapshot RepoLayout
repoLayout)
    forall (m :: * -> *) a. Monad m => a -> m a
return Timestamp{FileExpires
FileVersion
FileInfo
timestampInfoSnapshot :: FileInfo
timestampExpires :: FileExpires
timestampVersion :: FileVersion
timestampInfoSnapshot :: FileInfo
timestampExpires :: FileExpires
timestampVersion :: FileVersion
..}

instance (MonadKeys m, MonadReader RepoLayout m) => FromJSON m (Signed Timestamp) where
  fromJSON :: JSValue -> m (Signed Timestamp)
fromJSON = forall (m :: * -> *) a.
(MonadKeys m, FromJSON m a) =>
JSValue -> m (Signed a)
signedFromJSON

{-------------------------------------------------------------------------------
  Paths used in the timestamp

  NOTE: Since the timestamp lives in the top-level directory of the repository,
  we can safely reinterpret "relative to the repo root" as "relative to the
  timestamp"; hence, this use of 'castRoot' is okay.
-------------------------------------------------------------------------------}

pathSnapshot :: RepoLayout -> TargetPath
pathSnapshot :: RepoLayout -> TargetPath
pathSnapshot = RepoPath -> TargetPath
TargetPathRepo forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoLayout -> RepoPath
repoLayoutSnapshot