Scope.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : Gogol.Auth.Scope
-- Copyright   : (c) 2015 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
--
-- Helpers for specifying and using type-level OAuth scopes.
module Gogol.Auth.Scope
  ( -- * Scope constraints
    type AllowRequest,
    type SatisfyScope,

    -- ** Modifying type-level lists of scopes
    allow,
    forbid,
    (!),

    -- * Manipulating scope values
    KnownScopes (..),
    concatScopes,
    queryEncodeScopes,
  )
where

import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BS8
import Data.Coerce (coerce)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Type.Bool (type If, type (||))
import Data.Typeable (Proxy (..))
import GHC.Exts (Constraint)
import GHC.TypeLits
import Gogol.Internal.Auth (Credentials)
import Gogol.Types (GoogleRequest (..), OAuthScope (..))
import Network.HTTP.Types (urlEncode)

-- | 'Constraint' kind for proving the @scopes@ context contains one of the
-- scopes necessary for authenticating the request, @a@.
--
-- @
-- uploadAndDownloadFile
--   :: ( AllowRequest StorageObjectsInsert scopes
--      , AllowRequest StorageObjectsGet scopes
--      )
--   => Env scopes
--   -> Text
--   -> Object
--   -> MediaType
--   -> FilePath
--   -> FilePath
--   -> IO Object
-- uploadAndDownloadFile env bucket object media src dst = do
--   let put = newStorageObjectsInsert bucket (object { bucket = Just bucket })
--       get = newStorageObjectsGet bucket object
--
--   body <- GBody media <$> HTTP.streamFile src
--
--   runResourceT $ do
--     _object <- upload env meta body
--     stream <- download env meta
--
--     Conduit.connect stream (Conduit.Combinators.sinkFileCautious dst)
-- @
--
-- /See:/ 'SatisfyScope'.
type AllowRequest a scopes = (GoogleRequest a, KnownScopes scopes, SatisfyScope (Scopes a) scopes)

-- | 'Constraint' proving at least _one_ scope from @required@ exists in
-- the provided context, @scopes@.
--
-- That is, the set of possible scopes a request requires are on the left, and
-- the set of scopes credentials or an environment contain are on the right.
type family SatisfyScope (required :: [Symbol]) (scopes :: [Symbol]) :: Constraint where
  SatisfyScope '[] _ = () -- Special case; no scopes are required.
  SatisfyScope required scopes =
    If (Intersect scopes required) (() :: Constraint) (TypeError (MissingScopesError required scopes))

type MissingScopesError (required :: [k]) (scopes :: [k]) =
  'Text "One scope from the following list is required:"
    ':$$: 'Text "    " ':<>: 'ShowType required
    ':$$: 'Text "However, none of these scopes are present in the list of scopes you provided:"
    ':$$: 'Text "    " ':<>: 'ShowType scopes

-- Short-circuiting intersection - does at least one element exist in both lists?
type family Intersect (as :: [k]) (bs :: [k]) :: Bool where
  Intersect '[] _ = 'False
  Intersect _ '[] = 'False
  Intersect (a ': as) bs = Elem a bs || Intersect as bs

-- Type-level 'Data.List.elem'.
type family Elem (x :: k) (xs :: [k]) :: Bool where
  Elem _ '[] = 'False
  Elem x (x ': xs) = 'True
  Elem x (y ': xs) = Elem x xs

-- This exists to allow users to choose between using 'newEnv'
-- with a 'Proxy' constructed by '!', or explicitly
-- specifying scopes via a type annotation.
--
-- /See:/ '!', 'envScopes', and the scopes available for each service.
allow :: proxy s -> k s -> k s
allow _ = id

-- | Annotate credentials with no scope authorization.
forbid :: k '[] -> k '[]
forbid = id

-- | Append two sets of scopes.
--
-- /See:/ 'allow'.
(!) :: proxy xs -> proxy ys -> Proxy (Nub (xs ++ ys))
(!) _ _ = Proxy

-- | Append two lists.
type family (++) xs ys where
  (++) xs '[] = xs
  (++) '[] ys = ys
  (++) (x ': xs) ys = x ': (xs ++ ys)

-- | Remove duplicates from a list.
type family Nub xs where
  Nub '[] = '[]
  Nub (x ': xs) = x ': Nub (Delete x xs)

-- | Remove a specific element from a list.
type family Delete x xs where
  Delete x '[] = '[]
  Delete x (x ': ys) = Delete x ys
  Delete x (y ': ys) = y ': Delete x ys

class KnownScopes a where
  -- | Obtain a list of supported 'OAuthScope' values from a proxy.
  --
  -- This is used to pass scope _values_ to functions that require them,
  -- such as 'Gogol.Auth.ServiceAccount.serviceAccountToken'.
  scopeVals :: proxy a -> [OAuthScope]

instance KnownScopes '[] where
  scopeVals _ = []

instance (KnownSymbol x, KnownScopes xs) => KnownScopes (x ': xs) where
  scopeVals _ = scope (Proxy :: Proxy x) : scopeVals (Proxy :: Proxy xs)
    where
      scope = OAuthScope . Text.pack . symbolVal

instance (KnownScopes s) => KnownScopes (Credentials s) where
  scopeVals _ = scopeVals (Proxy :: Proxy s)

-- | Concatenate a list of scopes using spaces.
concatScopes :: [OAuthScope] -> Text
concatScopes = Text.intercalate " " . coerce

-- | Encode a list of scopes suitable for embedding in a query string.
queryEncodeScopes :: [OAuthScope] -> ByteString
queryEncodeScopes =
  BS8.intercalate "+"
    . map (urlEncode True . Text.encodeUtf8)
    . coerce