{-# LANGUAGE DeriveGeneric #-}

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : Network.DO.Spaces.Actions.SetBucketCORS
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
module Network.DO.Spaces.Actions.SetBucketCORS
    ( SetBucketCORSResponse
    , SetBucketCORS(..)
    ) where

import           Control.Monad.Reader    ( MonadReader(ask) )

import           Data.ByteString         ( ByteString )
import qualified Data.CaseInsensitive    as CI
import qualified Data.Text.Encoding      as T

import           GHC.Generics            ( Generic )

import           Network.DO.Spaces.Types
import           Network.DO.Spaces.Utils
import           Network.HTTP.Conduit    ( RequestBody(RequestBodyLBS) )
import qualified Network.HTTP.Types      as H

import qualified Text.XML                as X

-- | Set a 'Bucket'\'s 'CORSRule's
data SetBucketCORS = SetBucketCORS { SetBucketCORS -> Bucket
bucket :: Bucket, SetBucketCORS -> [CORSRule]
rules :: [CORSRule] }
    deriving stock ( Int -> SetBucketCORS -> ShowS
[SetBucketCORS] -> ShowS
SetBucketCORS -> String
(Int -> SetBucketCORS -> ShowS)
-> (SetBucketCORS -> String)
-> ([SetBucketCORS] -> ShowS)
-> Show SetBucketCORS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SetBucketCORS] -> ShowS
$cshowList :: [SetBucketCORS] -> ShowS
show :: SetBucketCORS -> String
$cshow :: SetBucketCORS -> String
showsPrec :: Int -> SetBucketCORS -> ShowS
$cshowsPrec :: Int -> SetBucketCORS -> ShowS
Show, SetBucketCORS -> SetBucketCORS -> Bool
(SetBucketCORS -> SetBucketCORS -> Bool)
-> (SetBucketCORS -> SetBucketCORS -> Bool) -> Eq SetBucketCORS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SetBucketCORS -> SetBucketCORS -> Bool
$c/= :: SetBucketCORS -> SetBucketCORS -> Bool
== :: SetBucketCORS -> SetBucketCORS -> Bool
$c== :: SetBucketCORS -> SetBucketCORS -> Bool
Eq, (forall x. SetBucketCORS -> Rep SetBucketCORS x)
-> (forall x. Rep SetBucketCORS x -> SetBucketCORS)
-> Generic SetBucketCORS
forall x. Rep SetBucketCORS x -> SetBucketCORS
forall x. SetBucketCORS -> Rep SetBucketCORS x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SetBucketCORS x -> SetBucketCORS
$cfrom :: forall x. SetBucketCORS -> Rep SetBucketCORS x
Generic )

type SetBucketCORSResponse = ()

instance MonadSpaces m => Action m SetBucketCORS where
    type ConsumedResponse SetBucketCORS = SetBucketCORSResponse

    buildRequest :: SetBucketCORS -> m SpacesRequestBuilder
buildRequest SetBucketCORS { [CORSRule]
Bucket
rules :: [CORSRule]
bucket :: Bucket
$sel:rules:SetBucketCORS :: SetBucketCORS -> [CORSRule]
$sel:bucket:SetBucketCORS :: SetBucketCORS -> Bucket
.. } = do
        Spaces
spaces <- m Spaces
forall r (m :: * -> *). MonadReader r m => m r
ask
        SpacesRequestBuilder -> m SpacesRequestBuilder
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpacesRequestBuilder :: Spaces
-> Maybe RequestBody
-> Maybe Method
-> [Header]
-> Maybe Bucket
-> Maybe Object
-> Maybe Query
-> Maybe Query
-> Maybe Region
-> SpacesRequestBuilder
SpacesRequestBuilder
             { $sel:bucket:SpacesRequestBuilder :: Maybe Bucket
bucket         = Bucket -> Maybe Bucket
forall a. a -> Maybe a
Just Bucket
bucket
             , $sel:method:SpacesRequestBuilder :: Maybe Method
method         = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
PUT
             , $sel:object:SpacesRequestBuilder :: Maybe Object
object         = Maybe Object
forall a. Maybe a
Nothing
             , $sel:overrideRegion:SpacesRequestBuilder :: Maybe Region
overrideRegion = Maybe Region
forall a. Maybe a
Nothing
             , $sel:queryString:SpacesRequestBuilder :: Maybe Query
queryString    = Maybe Query
forall a. Maybe a
Nothing
             , $sel:headers:SpacesRequestBuilder :: [Header]
headers        = [Header]
forall a. Monoid a => a
mempty
             , $sel:subresources:SpacesRequestBuilder :: Maybe Query
subresources   = Query -> Maybe Query
forall a. a -> Maybe a
Just
                   (Query -> Maybe Query) -> Query -> Maybe Query
forall a b. (a -> b) -> a -> b
$ Query -> Query
forall a. QueryLike a => a -> Query
H.toQuery [ ( ByteString
"cors" :: ByteString
                                 , Maybe ByteString
forall a. Maybe a
Nothing :: Maybe ByteString
                                 )
                               ]
             , Maybe RequestBody
Spaces
$sel:body:SpacesRequestBuilder :: Maybe RequestBody
$sel:spaces:SpacesRequestBuilder :: Spaces
body :: Maybe RequestBody
spaces :: Spaces
..
             }
      where
        body :: Maybe RequestBody
body = RequestBody -> Maybe RequestBody
forall a. a -> Maybe a
Just (RequestBody -> Maybe RequestBody)
-> (Document -> RequestBody) -> Document -> Maybe RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody)
-> (Document -> ByteString) -> Document -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderSettings -> Document -> ByteString
X.renderLBS RenderSettings
forall a. Default a => a
X.def
            (Document -> Maybe RequestBody) -> Document -> Maybe RequestBody
forall a b. (a -> b) -> a -> b
$ Prologue -> Element -> [Miscellaneous] -> Document
X.Document Prologue
prologue Element
root [Miscellaneous]
forall a. Monoid a => a
mempty

        prologue :: Prologue
prologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
X.Prologue [Miscellaneous]
forall a. Monoid a => a
mempty Maybe Doctype
forall a. Maybe a
Nothing [Miscellaneous]
forall a. Monoid a => a
mempty

        root :: Element
root = Name -> Map Name Text -> [Node] -> Element
X.Element Name
"CORSConfiguration" Map Name Text
forall a. Monoid a => a
mempty (CORSRule -> Node
ruleNode (CORSRule -> Node) -> [CORSRule] -> [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CORSRule]
rules)

        ruleNode :: CORSRule -> Node
ruleNode CORSRule { [HeaderName]
[Method]
Text
$sel:allowedHeaders:CORSRule :: CORSRule -> [HeaderName]
$sel:allowedMethods:CORSRule :: CORSRule -> [Method]
$sel:allowedOrigin:CORSRule :: CORSRule -> Text
allowedHeaders :: [HeaderName]
allowedMethods :: [Method]
allowedOrigin :: Text
.. } = Element -> Node
X.NodeElement (Element -> Node) -> ([Node] -> Element) -> [Node] -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Map Name Text -> [Node] -> Element
X.Element Name
"CORSRule" Map Name Text
forall a. Monoid a => a
mempty
            ([Node] -> Node) -> [Node] -> Node
forall a b. (a -> b) -> a -> b
$ [[Node]] -> [Node]
forall a. Monoid a => [a] -> a
mconcat [ [ Name -> Text -> Node
mkNode Name
"AllowedOrigin" Text
allowedOrigin ]
                      , Name -> Text -> Node
mkNode Name
"AllowedHeader" (Text -> Node) -> (HeaderName -> Text) -> HeaderName -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (HeaderName -> ByteString) -> HeaderName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString
forall s. CI s -> s
CI.original
                        (HeaderName -> Node) -> [HeaderName] -> [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HeaderName]
allowedHeaders
                      , Name -> Text -> Node
mkNode Name
"AllowedMethod" (Text -> Node) -> (Method -> Text) -> Method -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Method -> Text
forall a. Show a => a -> Text
tshow (Method -> Node) -> [Method] -> [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Method]
allowedMethods
                      ]

    consumeResponse :: RawResponse m -> m (ConsumedResponse SetBucketCORS)
consumeResponse RawResponse m
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()