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

import MyPrelude
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mirror] -> ShowS
$cshowList :: [Mirror] -> ShowS
show :: Mirror -> String
$cshow :: Mirror -> String
showsPrec :: Int -> Mirror -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MirrorContent] -> ShowS
$cshowList :: [MirrorContent] -> ShowS
show :: MirrorContent -> String
$cshow :: MirrorContent -> String
showsPrec :: Int -> MirrorContent -> ShowS
$cshowsPrec :: Int -> MirrorContent -> ShowS
Show

instance HasHeader Mirrors where
  fileVersion :: Lens' Mirrors FileVersion
fileVersion FileVersion -> f FileVersion
f Mirrors
x = (\FileVersion
y -> Mirrors
x { mirrorsVersion :: FileVersion
mirrorsVersion = FileVersion
y }) 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 :: FileExpires
mirrorsExpires = FileExpires
y }) 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 = forall a. Show a => a -> String
show 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
mirrorContent :: MirrorContent
mirrorUrlBase :: URI
mirrorContent :: Mirror -> MirrorContent
mirrorUrlBase :: Mirror -> URI
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
      [ (String
"urlbase", 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
mirrorsMirrors :: [Mirror]
mirrorsExpires :: FileExpires
mirrorsVersion :: FileVersion
mirrorsMirrors :: Mirrors -> [Mirror]
mirrorsExpires :: Mirrors -> FileExpires
mirrorsVersion :: Mirrors -> FileVersion
..} = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
      (String
"_type"   , forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString String
"Mirrorlist")
    , (String
"version" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileVersion
mirrorsVersion)
    , (String
"expires" , forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON FileExpires
mirrorsExpires)
    , (String
"mirrors" , 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
    URI
mirrorUrlBase <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"urlbase"
    let mirrorContent :: MirrorContent
mirrorContent = MirrorContent
MirrorFull
    forall (m :: * -> *) a. Monad m => a -> m a
return Mirror{URI
MirrorContent
mirrorContent :: MirrorContent
mirrorUrlBase :: URI
mirrorContent :: MirrorContent
mirrorUrlBase :: URI
..}

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

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