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

import Prelude
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 = y }) (FileVersion -> Timestamp) -> f FileVersion -> f Timestamp
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 = y }) (FileExpires -> Timestamp) -> f FileExpires -> f Timestamp
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
timestampVersion :: Timestamp -> FileVersion
timestampExpires :: Timestamp -> FileExpires
timestampInfoSnapshot :: Timestamp -> FileInfo
timestampVersion :: FileVersion
timestampExpires :: FileExpires
timestampInfoSnapshot :: FileInfo
..} = do
      repoLayout <- m RepoLayout
forall r (m :: * -> *). MonadReader r m => m r
ask
      mkObject [
          ("_type"   , return $ JSString "Timestamp")
        , ("version" , toJSON timestampVersion)
        , ("expires" , toJSON timestampExpires)
        , ("meta"    , toJSON (timestampMeta 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
    JSValue -> String -> m ()
forall (m :: * -> *).
(ReportSchemaErrors m, MonadError DeserializationError m) =>
JSValue -> String -> m ()
verifyType JSValue
enc String
"Timestamp"
    repoLayout            <- m RepoLayout
forall r (m :: * -> *). MonadReader r m => m r
ask
    timestampVersion      <- fromJSField enc "version"
    timestampExpires      <- fromJSField enc "expires"
    timestampMeta         <- fromJSField enc "meta"
    let lookupMeta TargetPath
k = case TargetPath -> FileMap -> Maybe FileInfo
FileMap.lookup TargetPath
k FileMap
timestampMeta of
          Maybe FileInfo
Nothing -> String -> Maybe String -> m FileInfo
forall a. String -> Maybe String -> m a
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected (String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" entry in .meta object") Maybe String
forall a. Maybe a
Nothing
          Just FileInfo
v  -> FileInfo -> m FileInfo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileInfo
v
    timestampInfoSnapshot <- lookupMeta (pathSnapshot repoLayout)
    return Timestamp{..}

instance (MonadKeys m, MonadReader RepoLayout m) => FromJSON m (Signed Timestamp) where
  fromJSON :: JSValue -> m (Signed Timestamp)
fromJSON = JSValue -> m (Signed Timestamp)
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 (RepoPath -> TargetPath)
-> (RepoLayout -> RepoPath) -> RepoLayout -> TargetPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoLayout -> RepoPath
repoLayoutSnapshot