module Network.Goggles.Auth.TokenExchange (
scopesDefault
, GCP
, requestTokenGCP
, getObject
, getObjectMetadata
, putObject
, listObjects
) where
import Data.Monoid ((<>))
import Network.HTTP.Req
import Control.Monad.Catch
import Control.Monad.Reader
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as T
import qualified Data.Text.Encoding as T (encodeUtf8, decodeUtf8)
import qualified Crypto.Random.Types as CR
import Network.Goggles.Cloud
import Network.Goggles.Types
import Network.Goggles.Auth.OAuth2
import Network.Goggles.Auth.JWT
import Network.Utils.HTTP (putLbs, getLbs, urlEncode)
data GCP
instance HasCredentials GCP where
type Credentials GCP = GCPServiceAccount
type Options GCP = [T.Text]
type TokenContent GCP = T.Text
tokenFetch = requestTokenGCP
instance Show (Token GCP) where
show (Token tok time) = unwords ["GCP Token :", T.unpack tok, "; expires at :", show time]
instance MonadHttp (Cloud GCP) where
handleHttpException = throwM
scopesDefault :: [T.Text]
scopesDefault = ["https://www.googleapis.com/auth/cloud-platform"]
uriBase :: Url 'Https
uriBase = https "www.googleapis.com"
getObject :: T.Text -> T.Text -> Cloud GCP LbsResponse
getObject b p = do
tok <- accessToken
let
opts = oAuth2Bearer (T.encodeUtf8 tok) <>
altMedia
uri = uriBase /: "storage" /: "v1" /: "b" /: b /: "o" /: p
getLbs uri opts
getObjectMetadata :: T.Text -> T.Text -> Cloud GCP LbsResponse
getObjectMetadata b p = do
tok <- accessToken
let
opts = oAuth2Bearer (T.encodeUtf8 tok)
uri = uriBase /: "storage" /: "v1" /: "b" /: b /: "o" /: p
getLbs uri opts
listObjects :: T.Text -> Cloud GCP LbsResponse
listObjects b = do
tok <- accessToken
let
opts = oAuth2Bearer (T.encodeUtf8 tok)
uri = uriBase /: "storage" /: "v1" /: "b" /: b /: "o"
getLbs uri opts
putObject :: T.Text -> T.Text -> LB.ByteString -> Cloud GCP LbsResponse
putObject b objName body = do
tok <- accessToken
let
opts = oAuth2Bearer (T.encodeUtf8 tok) <>
ulMedia <>
("name" =: objName)
uri = uriBase /: "upload" /: "storage" /: "v1" /: "b" /: b /: "o"
putLbs uri opts body
altMedia, ulMedia :: Option 'Https
altMedia = "alt" =: ("media" :: T.Text)
ulMedia = "uploadType" =: ("media" :: T.Text)
requestTokenGCP :: Cloud GCP (Token GCP)
requestTokenGCP = do
saOk <- asks credentials
scopes <- asks options
let opts = GCPTokenOptions scopes
t0 <- requestGcpOAuth2Token saOk opts
tutc <- mkOAuth2TokenUTC (2 :: Int) t0
return (Token (oauTokenString tutc) (oauTokenExpiry tutc))
requestGcpOAuth2Token :: (MonadThrow m, CR.MonadRandom m, MonadHttp m) =>
GCPServiceAccount -> GCPTokenOptions -> m OAuth2Token
requestGcpOAuth2Token serviceAcct opts = do
jwt <- T.decodeUtf8 <$> encodeBearerJWT serviceAcct opts
requestOAuth2Token
(uriBase /: "oauth2" /: "v4" /: "token")
[("grant_type", T.pack $ urlEncode "urn:ietf:params:oauth:grant-type:jwt-bearer"),
("assertion", jwt)]
(header "Content-Type" "application/x-www-form-urlencoded; charset=utf-8")