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

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

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

import           Data.ByteString         ( ByteString )
import qualified Data.CaseInsensitive    as CI
import           Data.Maybe              ( mapMaybe )
import           Data.Sequence           ( Seq )
import qualified Data.Sequence           as S
import qualified Data.Text               as T
import qualified Data.Text.Encoding      as T

import           GHC.Generics            ( Generic )

import           Network.DO.Spaces.Types
import           Network.DO.Spaces.Utils
import qualified Network.HTTP.Types      as H

import           Text.Read               ( readMaybe )
import qualified Text.XML.Cursor         as X
import           Text.XML.Cursor         ( ($/), (&/), (&|) )

-- | Get the 'CORSRule's associated with a 'Bucket'
newtype GetBucketCORS = GetBucketCORS { GetBucketCORS -> Bucket
bucket :: Bucket }
    deriving stock ( Int -> GetBucketCORS -> ShowS
[GetBucketCORS] -> ShowS
GetBucketCORS -> String
(Int -> GetBucketCORS -> ShowS)
-> (GetBucketCORS -> String)
-> ([GetBucketCORS] -> ShowS)
-> Show GetBucketCORS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetBucketCORS] -> ShowS
$cshowList :: [GetBucketCORS] -> ShowS
show :: GetBucketCORS -> String
$cshow :: GetBucketCORS -> String
showsPrec :: Int -> GetBucketCORS -> ShowS
$cshowsPrec :: Int -> GetBucketCORS -> ShowS
Show, (forall x. GetBucketCORS -> Rep GetBucketCORS x)
-> (forall x. Rep GetBucketCORS x -> GetBucketCORS)
-> Generic GetBucketCORS
forall x. Rep GetBucketCORS x -> GetBucketCORS
forall x. GetBucketCORS -> Rep GetBucketCORS x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetBucketCORS x -> GetBucketCORS
$cfrom :: forall x. GetBucketCORS -> Rep GetBucketCORS x
Generic )
    deriving newtype ( GetBucketCORS -> GetBucketCORS -> Bool
(GetBucketCORS -> GetBucketCORS -> Bool)
-> (GetBucketCORS -> GetBucketCORS -> Bool) -> Eq GetBucketCORS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetBucketCORS -> GetBucketCORS -> Bool
$c/= :: GetBucketCORS -> GetBucketCORS -> Bool
== :: GetBucketCORS -> GetBucketCORS -> Bool
$c== :: GetBucketCORS -> GetBucketCORS -> Bool
Eq )

newtype GetBucketCORSResponse =
    GetBucketCORSResponse { GetBucketCORSResponse -> Seq CORSRule
rules :: Seq CORSRule }
    deriving stock ( Int -> GetBucketCORSResponse -> ShowS
[GetBucketCORSResponse] -> ShowS
GetBucketCORSResponse -> String
(Int -> GetBucketCORSResponse -> ShowS)
-> (GetBucketCORSResponse -> String)
-> ([GetBucketCORSResponse] -> ShowS)
-> Show GetBucketCORSResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetBucketCORSResponse] -> ShowS
$cshowList :: [GetBucketCORSResponse] -> ShowS
show :: GetBucketCORSResponse -> String
$cshow :: GetBucketCORSResponse -> String
showsPrec :: Int -> GetBucketCORSResponse -> ShowS
$cshowsPrec :: Int -> GetBucketCORSResponse -> ShowS
Show, (forall x. GetBucketCORSResponse -> Rep GetBucketCORSResponse x)
-> (forall x. Rep GetBucketCORSResponse x -> GetBucketCORSResponse)
-> Generic GetBucketCORSResponse
forall x. Rep GetBucketCORSResponse x -> GetBucketCORSResponse
forall x. GetBucketCORSResponse -> Rep GetBucketCORSResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GetBucketCORSResponse x -> GetBucketCORSResponse
$cfrom :: forall x. GetBucketCORSResponse -> Rep GetBucketCORSResponse x
Generic )
    deriving newtype ( GetBucketCORSResponse -> GetBucketCORSResponse -> Bool
(GetBucketCORSResponse -> GetBucketCORSResponse -> Bool)
-> (GetBucketCORSResponse -> GetBucketCORSResponse -> Bool)
-> Eq GetBucketCORSResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GetBucketCORSResponse -> GetBucketCORSResponse -> Bool
$c/= :: GetBucketCORSResponse -> GetBucketCORSResponse -> Bool
== :: GetBucketCORSResponse -> GetBucketCORSResponse -> Bool
$c== :: GetBucketCORSResponse -> GetBucketCORSResponse -> Bool
Eq )

instance MonadSpaces m => Action m GetBucketCORS where
    type ConsumedResponse GetBucketCORS = GetBucketCORSResponse

    buildRequest :: GetBucketCORS -> m SpacesRequestBuilder
buildRequest GetBucketCORS { Bucket
bucket :: Bucket
$sel:bucket:GetBucketCORS :: GetBucketCORS -> 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         = Maybe Method
forall a. Maybe a
Nothing
             , $sel:body:SpacesRequestBuilder :: Maybe RequestBody
body           = Maybe RequestBody
forall a. Maybe a
Nothing
             , $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
                                 )
                               ]
             , Spaces
$sel:spaces:SpacesRequestBuilder :: Spaces
spaces :: Spaces
..
             }

    consumeResponse :: RawResponse m -> m (ConsumedResponse GetBucketCORS)
consumeResponse RawResponse m
raw = do
        Cursor
cursor <- RawResponse m -> m Cursor
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
RawResponse m -> m Cursor
xmlDocCursor RawResponse m
raw
        Seq CORSRule -> GetBucketCORSResponse
GetBucketCORSResponse (Seq CORSRule -> GetBucketCORSResponse)
-> ([CORSRule] -> Seq CORSRule)
-> [CORSRule]
-> GetBucketCORSResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CORSRule] -> Seq CORSRule
forall a. [a] -> Seq a
S.fromList
            ([CORSRule] -> GetBucketCORSResponse)
-> m [CORSRule] -> m GetBucketCORSResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m CORSRule] -> m [CORSRule]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Cursor
cursor Cursor -> (Cursor -> [m CORSRule]) -> [m CORSRule]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"CORSRule" Axis -> (Cursor -> m CORSRule) -> Cursor -> [m CORSRule]
forall node a b.
(Cursor node -> [a]) -> (a -> b) -> Cursor node -> [b]
&| Cursor -> m CORSRule
forall (m :: * -> *). MonadThrow m => Cursor -> m CORSRule
ruleP)
      where
        ruleP :: Cursor -> m CORSRule
ruleP Cursor
c = do
            Text
allowedOrigin <- ClientException -> [Text] -> m Text
forall e (f :: * -> *) a.
(Exception e, MonadThrow f) =>
e -> [a] -> f a
X.force (Text -> ClientException
xmlElemError Text
"AllowedOrigin")
                ([Text] -> m Text) -> [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ Cursor
c Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"AllowedOrigin" Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
X.content

            Text -> [Method] -> [HeaderName] -> m CORSRule
forall (m :: * -> *).
MonadThrow m =>
Text -> [Method] -> [HeaderName] -> m CORSRule
mkCORSRule Text
allowedOrigin
                       ((Text -> Maybe Method) -> [Text] -> [Method]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe Method
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Method)
-> (Text -> String) -> Text -> Maybe Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
allowedMethods)
                       (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName)
-> (Text -> ByteString) -> Text -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> HeaderName) -> [Text] -> [HeaderName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
allowedHeaders)
          where
            allowedHeaders :: [Text]
allowedHeaders = Cursor
c Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"AllowedHeader" Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
X.content

            allowedMethods :: [Text]
allowedMethods = Cursor
c Cursor -> (Cursor -> [Text]) -> [Text]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Text -> Axis
X.laxElement Text
"AllowedMethod" Axis -> (Cursor -> [Text]) -> Cursor -> [Text]
forall node a.
Axis node -> (Cursor node -> [a]) -> Cursor node -> [a]
&/ Cursor -> [Text]
X.content