{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Network.Google.Auth.Scope where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import Data.Coerce (coerce)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Type.Bool (type (||))
import Data.Type.Equality (type (==))
import Data.Typeable (Proxy (..))
import GHC.Exts (Constraint)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Network.Google.Internal.Auth (Credentials)
import Network.Google.Prelude (GoogleRequest (..),
OAuthScope (..))
import Network.HTTP.Types (urlEncode)
allow :: proxy s -> k s -> k s
allow _ = id
forbid :: k '[] -> k '[]
forbid = id
(!) :: proxy xs -> proxy ys -> Proxy (Nub (xs ++ ys))
(!) _ _ = Proxy
type family HasScope (s :: [Symbol]) a :: Constraint where
HasScope s a = (s `HasScope'` Scopes a) ~ 'True
type family HasScope' s a where
HasScope' s '[] = 'True
HasScope' (x ': xs) a = x ∈ a || HasScope' xs a
type family (∈) a b where
(∈) x '[] = 'False
(∈) x (y ': xs) = x == y || x ∈ xs
type family (++) xs ys where
(++) xs '[] = xs
(++) '[] ys = ys
(++) (x ': xs) ys = x ': (xs ++ ys)
type family Nub xs where
Nub '[] = '[]
Nub (x ': xs) = x ': Nub (Delete x xs)
type family Delete x xs where
Delete x '[] = '[]
Delete x (x ': ys) = Delete x ys
Delete x (y ': ys) = y ': Delete x ys
class AllowScopes a where
allowScopes :: proxy a -> [OAuthScope]
instance AllowScopes '[] where
allowScopes _ = []
instance (KnownSymbol x, AllowScopes xs) => AllowScopes (x ': xs) where
allowScopes _ = scope (Proxy :: Proxy x) : allowScopes (Proxy :: Proxy xs)
where
scope = OAuthScope . Text.pack . symbolVal
instance AllowScopes s => AllowScopes (Credentials s) where
allowScopes _ = allowScopes (Proxy :: Proxy s)
concatScopes :: [OAuthScope] -> Text
concatScopes = Text.intercalate " " . coerce
queryEncodeScopes :: [OAuthScope] -> ByteString
queryEncodeScopes =
BS8.intercalate "+"
. map (urlEncode True . Text.encodeUtf8)
. coerce