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

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

import Hackage.Security.JSON
import Hackage.Security.TUF.Header
import Hackage.Security.TUF.FileInfo
import Hackage.Security.TUF.FileMap
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 Snapshot = Snapshot {
    Snapshot -> FileVersion
snapshotVersion :: FileVersion
  , Snapshot -> FileExpires
snapshotExpires :: FileExpires

    -- | File info for the root metadata
    --
    -- We list this explicitly in the snapshot so that we can check if we need
    -- to update the root metadata without first having to download the entire
    -- index tarball.
  , Snapshot -> FileInfo
snapshotInfoRoot :: FileInfo

    -- | File info for the mirror metadata
  , Snapshot -> FileInfo
snapshotInfoMirrors :: FileInfo

    -- | Compressed index tarball
  , Snapshot -> FileInfo
snapshotInfoTarGz :: FileInfo

    -- | Uncompressed index tarball
    --
    -- Repositories are not required to provide this.
  , Snapshot -> Maybe FileInfo
snapshotInfoTar :: Maybe FileInfo
  }

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

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

instance MonadReader RepoLayout m => ToJSON m Snapshot where
  toJSON :: Snapshot -> m JSValue
toJSON Snapshot{Maybe FileInfo
FileExpires
FileVersion
FileInfo
snapshotVersion :: Snapshot -> FileVersion
snapshotExpires :: Snapshot -> FileExpires
snapshotInfoRoot :: Snapshot -> FileInfo
snapshotInfoMirrors :: Snapshot -> FileInfo
snapshotInfoTarGz :: Snapshot -> FileInfo
snapshotInfoTar :: Snapshot -> Maybe FileInfo
snapshotVersion :: FileVersion
snapshotExpires :: FileExpires
snapshotInfoRoot :: FileInfo
snapshotInfoMirrors :: FileInfo
snapshotInfoTarGz :: FileInfo
snapshotInfoTar :: Maybe 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
"Snapshot")
        , (String
"version" , FileVersion -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileVersion
snapshotVersion)
        , (String
"expires" , FileExpires -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileExpires
snapshotExpires)
        , (String
"meta"    , FileMap -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (RepoLayout -> FileMap
snapshotMeta RepoLayout
repoLayout))
        ]
    where
      snapshotMeta :: RepoLayout -> FileMap
snapshotMeta RepoLayout
repoLayout = [(TargetPath, FileInfo)] -> FileMap
FileMap.fromList ([(TargetPath, FileInfo)] -> FileMap)
-> [(TargetPath, FileInfo)] -> FileMap
forall a b. (a -> b) -> a -> b
$ [
          (RepoLayout -> TargetPath
pathRoot       RepoLayout
repoLayout , FileInfo
snapshotInfoRoot)
        , (RepoLayout -> TargetPath
pathMirrors    RepoLayout
repoLayout , FileInfo
snapshotInfoMirrors)
        , (RepoLayout -> TargetPath
pathIndexTarGz RepoLayout
repoLayout , FileInfo
snapshotInfoTarGz)
        ] [(TargetPath, FileInfo)]
-> [(TargetPath, FileInfo)] -> [(TargetPath, FileInfo)]
forall a. [a] -> [a] -> [a]
++
        [ (RepoLayout -> TargetPath
pathIndexTar   RepoLayout
repoLayout , FileInfo
infoTar) | Just FileInfo
infoTar <- [Maybe FileInfo
snapshotInfoTar] ]

instance ( MonadReader RepoLayout m
         , MonadError DeserializationError m
         , ReportSchemaErrors m
         ) => FromJSON m Snapshot where
  fromJSON :: JSValue -> m Snapshot
fromJSON JSValue
enc = do
    JSValue -> String -> m ()
forall (m :: * -> *).
(ReportSchemaErrors m, MonadError DeserializationError m) =>
JSValue -> String -> m ()
verifyType JSValue
enc String
"Snapshot"
    RepoLayout
repoLayout          <- m RepoLayout
forall r (m :: * -> *). MonadReader r m => m r
ask
    FileVersion
snapshotVersion     <- JSValue -> String -> m FileVersion
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"version"
    FileExpires
snapshotExpires     <- JSValue -> String -> m FileExpires
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"expires"
    FileMap
snapshotMeta        <- 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
snapshotMeta 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
snapshotInfoRoot    <- TargetPath -> m FileInfo
lookupMeta (RepoLayout -> TargetPath
pathRoot       RepoLayout
repoLayout)
    FileInfo
snapshotInfoMirrors <- TargetPath -> m FileInfo
lookupMeta (RepoLayout -> TargetPath
pathMirrors    RepoLayout
repoLayout)
    FileInfo
snapshotInfoTarGz   <- TargetPath -> m FileInfo
lookupMeta (RepoLayout -> TargetPath
pathIndexTarGz RepoLayout
repoLayout)
    let snapshotInfoTar :: Maybe FileInfo
snapshotInfoTar = TargetPath -> FileMap -> Maybe FileInfo
FileMap.lookup (RepoLayout -> TargetPath
pathIndexTar RepoLayout
repoLayout) FileMap
snapshotMeta
    Snapshot -> m Snapshot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Snapshot{Maybe FileInfo
FileExpires
FileVersion
FileInfo
snapshotVersion :: FileVersion
snapshotExpires :: FileExpires
snapshotInfoRoot :: FileInfo
snapshotInfoMirrors :: FileInfo
snapshotInfoTarGz :: FileInfo
snapshotInfoTar :: Maybe FileInfo
snapshotVersion :: FileVersion
snapshotExpires :: FileExpires
snapshotInfoRoot :: FileInfo
snapshotInfoMirrors :: FileInfo
snapshotInfoTarGz :: FileInfo
snapshotInfoTar :: Maybe FileInfo
..}

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

{-------------------------------------------------------------------------------
  Paths used in the snapshot

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

pathRoot, pathMirrors, pathIndexTarGz, pathIndexTar :: RepoLayout -> TargetPath
pathRoot :: RepoLayout -> TargetPath
pathRoot       = RepoPath -> TargetPath
TargetPathRepo (RepoPath -> TargetPath)
-> (RepoLayout -> RepoPath) -> RepoLayout -> TargetPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoLayout -> RepoPath
repoLayoutRoot
pathMirrors :: RepoLayout -> TargetPath
pathMirrors    = RepoPath -> TargetPath
TargetPathRepo (RepoPath -> TargetPath)
-> (RepoLayout -> RepoPath) -> RepoLayout -> TargetPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoLayout -> RepoPath
repoLayoutMirrors
pathIndexTarGz :: RepoLayout -> TargetPath
pathIndexTarGz = RepoPath -> TargetPath
TargetPathRepo (RepoPath -> TargetPath)
-> (RepoLayout -> RepoPath) -> RepoLayout -> TargetPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoLayout -> RepoPath
repoLayoutIndexTarGz
pathIndexTar :: RepoLayout -> TargetPath
pathIndexTar   = RepoPath -> TargetPath
TargetPathRepo (RepoPath -> TargetPath)
-> (RepoLayout -> RepoPath) -> RepoLayout -> TargetPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoLayout -> RepoPath
repoLayoutIndexTar