    {-# LANGUAGE UndecidableInstances #-}
    module Hackage.Security.TUF.Mirrors (
        -- * TUF types
        Mirrors(..)
      , Mirror(..)
      , MirrorContent(..)
        -- ** Utility
      , MirrorDescription
      , describeMirror
      ) where

    import Prelude
    import Control.Monad.Except
    import Network.URI

    import Hackage.Security.JSON
    import Hackage.Security.TUF.Header
    import Hackage.Security.TUF.Signed

    {-------------------------------------------------------------------------------
      Datatypes
    -------------------------------------------------------------------------------}

    data Mirrors = Mirrors {
        Mirrors -> FileVersion
    mirrorsVersion :: FileVersion
      , Mirrors -> FileExpires
    mirrorsExpires :: FileExpires
      , Mirrors -> [Mirror]
    mirrorsMirrors :: [Mirror]
      }

    -- | Definition of a mirror
    --
    -- NOTE: Unlike the TUF specification, we require that all mirrors must have
    -- the same format. That is, we omit @metapath@ and @targetspath@.
    data Mirror = Mirror {
        Mirror -> URI
    mirrorUrlBase :: URI
      , Mirror -> MirrorContent
    mirrorContent :: MirrorContent
      }
      deriving Int -> Mirror -> ShowS
    [Mirror] -> ShowS
    Mirror -> String
    (Int -> Mirror -> ShowS)
    -> (Mirror -> String) -> ([Mirror] -> ShowS) -> Show Mirror
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Mirror -> ShowS
    showsPrec :: Int -> Mirror -> ShowS
    $cshow :: Mirror -> String
    show :: Mirror -> String
    $cshowList :: [Mirror] -> ShowS
    showList :: [Mirror] -> ShowS
    Show

    -- | Full versus partial mirrors
    --
    -- The TUF spec explicitly allows for partial mirrors, with the mirrors file
    -- specifying (through patterns) what is available from partial mirrors.
    --
    -- For now we only support full mirrors; if we wanted to add partial mirrors,
    -- we would add a second @MirrorPartial@ constructor here with arguments
    -- corresponding to TUF's @metacontent@ and @targetscontent@ fields.
    data MirrorContent =
        MirrorFull
      deriving Int -> MirrorContent -> ShowS
    [MirrorContent] -> ShowS
    MirrorContent -> String
    (Int -> MirrorContent -> ShowS)
    -> (MirrorContent -> String)
    -> ([MirrorContent] -> ShowS)
    -> Show MirrorContent
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> MirrorContent -> ShowS
    showsPrec :: Int -> MirrorContent -> ShowS
    $cshow :: MirrorContent -> String
    show :: MirrorContent -> String
    $cshowList :: [MirrorContent] -> ShowS
    showList :: [MirrorContent] -> ShowS
    Show

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

    {-------------------------------------------------------------------------------
      Utility
    -------------------------------------------------------------------------------}

    type MirrorDescription = String

    -- | Give a human-readable description of a particular mirror
    --
    -- (for use in error messages)
    describeMirror :: Mirror -> MirrorDescription
    describeMirror :: Mirror -> String
    describeMirror = URI -> String
    forall a. Show a => a -> String
    show (URI -> String) -> (Mirror -> URI) -> Mirror -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Mirror -> URI
    mirrorUrlBase

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

    instance Monad m => ToJSON m Mirror where
      toJSON :: Mirror -> m JSValue
    toJSON Mirror{URI
    MirrorContent
    mirrorUrlBase :: Mirror -> URI
    mirrorContent :: Mirror -> MirrorContent
    mirrorUrlBase :: URI
    mirrorContent :: MirrorContent
    ..} = [(String, m JSValue)] -> m JSValue
    forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
    mkObject ([(String, m JSValue)] -> m JSValue)
    -> [(String, m JSValue)] -> m JSValue
    forall a b. (a -> b) -> a -> b
    $ [[(String, m JSValue)]] -> [(String, m JSValue)]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [
          [ (String
    "urlbase", URI -> m JSValue
    forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
    toJSON URI
    mirrorUrlBase) ]
        , case MirrorContent
    mirrorContent of
            MirrorContent
    MirrorFull -> []
        ]

    instance Monad m => ToJSON m Mirrors where
      toJSON :: Mirrors -> m JSValue
    toJSON Mirrors{[Mirror]
    FileExpires
    FileVersion
    mirrorsVersion :: Mirrors -> FileVersion
    mirrorsExpires :: Mirrors -> FileExpires
    mirrorsMirrors :: Mirrors -> [Mirror]
    mirrorsVersion :: FileVersion
    mirrorsExpires :: FileExpires
    mirrorsMirrors :: [Mirror]
    ..} = [(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
    "Mirrorlist")
        , (String
    "version" , FileVersion -> m JSValue
    forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
    toJSON FileVersion
    mirrorsVersion)
        , (String
    "expires" , FileExpires -> m JSValue
    forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
    toJSON FileExpires
    mirrorsExpires)
        , (String
    "mirrors" , [Mirror] -> m JSValue
    forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
    toJSON [Mirror]
    mirrorsMirrors)
        ]

    instance ReportSchemaErrors m => FromJSON m Mirror where
      fromJSON :: JSValue -> m Mirror
    fromJSON JSValue
    enc = do
        mirrorUrlBase <- JSValue -> String -> m URI
    forall (m :: * -> *) a.
    (ReportSchemaErrors m, FromJSON m a) =>
    JSValue -> String -> m a
    fromJSField JSValue
    enc String
    "urlbase"
        let mirrorContent = MirrorContent
    MirrorFull
        return Mirror{..}

    instance ( MonadError DeserializationError m
             , ReportSchemaErrors m
             ) => FromJSON m Mirrors where
      fromJSON :: JSValue -> m Mirrors
    fromJSON JSValue
    enc = do
        JSValue -> String -> m ()
    forall (m :: * -> *).
    (ReportSchemaErrors m, MonadError DeserializationError m) =>
    JSValue -> String -> m ()
    verifyType JSValue
    enc String
    "Mirrorlist"
        mirrorsVersion <- JSValue -> String -> m FileVersion
    forall (m :: * -> *) a.
    (ReportSchemaErrors m, FromJSON m a) =>
    JSValue -> String -> m a
    fromJSField JSValue
    enc String
    "version"
        mirrorsExpires <- fromJSField enc "expires"
        mirrorsMirrors <- fromJSField enc "mirrors"
        return Mirrors{..}

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