    {-# 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