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

import Prelude
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 <- m RepoLayout
forall r (m :: * -> *). MonadReader r m => m r
ask
      mkObject [
          ("_type"   , return $ JSString "Snapshot")
        , ("version" , toJSON snapshotVersion)
        , ("expires" , toJSON snapshotExpires)
        , ("meta"    , toJSON (snapshotMeta 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          <- m RepoLayout
forall r (m :: * -> *). MonadReader r m => m r
ask
    snapshotVersion     <- fromJSField enc "version"
    snapshotExpires     <- fromJSField enc "expires"
    snapshotMeta        <- fromJSField enc "meta"
    let 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
    snapshotInfoRoot    <- lookupMeta (pathRoot       repoLayout)
    snapshotInfoMirrors <- lookupMeta (pathMirrors    repoLayout)
    snapshotInfoTarGz   <- lookupMeta (pathIndexTarGz repoLayout)
    let snapshotInfoTar = TargetPath -> FileMap -> Maybe FileInfo
FileMap.lookup (RepoLayout -> TargetPath
pathIndexTar RepoLayout
repoLayout) FileMap
snapshotMeta
    return Snapshot{..}

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