{-# 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
repoLayout <- m RepoLayout
forall r (m :: * -> *). MonadReader r m => m r
ask
      [(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
"Timestamp")
        , (String
"version" , FileVersion -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileVersion
timestampVersion)
        , (String
"expires" , FileExpires -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileExpires
timestampExpires)
        , (String
"meta"    , FileMap -> m JSValue
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
    JSValue -> String -> m ()
forall (m :: * -> *).
(ReportSchemaErrors m, MonadError DeserializationError m) =>
JSValue -> String -> m ()
verifyType JSValue
enc String
"Timestamp"
    RepoLayout
repoLayout            <- m RepoLayout
forall r (m :: * -> *). MonadReader r m => m r
ask
    FileVersion
timestampVersion      <- JSValue -> String -> m FileVersion
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"version"
    FileExpires
timestampExpires      <- JSValue -> String -> m FileExpires
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"expires"
    FileMap
timestampMeta         <- JSValue -> String -> m FileMap
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 -> 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
    FileInfo
timestampInfoSnapshot <- TargetPath -> m FileInfo
lookupMeta (RepoLayout -> TargetPath
pathSnapshot RepoLayout
repoLayout)
    Timestamp -> m Timestamp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Timestamp{FileExpires
FileVersion
FileInfo
timestampVersion :: FileVersion
timestampExpires :: FileExpires
timestampInfoSnapshot :: FileInfo
timestampVersion :: FileVersion
timestampExpires :: FileExpires
timestampInfoSnapshot :: FileInfo
..}

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