{-# 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
(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
    URI
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
mirrorContent = MirrorContent
MirrorFull
    Mirror -> m Mirror
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Mirror{URI
MirrorContent
mirrorUrlBase :: URI
mirrorContent :: MirrorContent
mirrorUrlBase :: URI
mirrorContent :: MirrorContent
..}

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"
    FileVersion
mirrorsVersion <- JSValue -> String -> m FileVersion
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"version"
    FileExpires
mirrorsExpires <- JSValue -> String -> m FileExpires
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"expires"
    [Mirror]
mirrorsMirrors <- JSValue -> String -> m [Mirror]
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
enc String
"mirrors"
    Mirrors -> m Mirrors
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Mirrors{[Mirror]
FileExpires
FileVersion
mirrorsVersion :: FileVersion
mirrorsExpires :: FileExpires
mirrorsMirrors :: [Mirror]
mirrorsVersion :: FileVersion
mirrorsExpires :: FileExpires
mirrorsMirrors :: [Mirror]
..}

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