diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Marco Zocca (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Marco Zocca nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,17 @@ +# goggles + + + +[![Build Status](https://travis-ci.org/ocramz/goggles.png)](https://travis-ci.org/ocramz/goggles) + +Interface to Google Cloud APIs + + + +### Inspiration + +Networking and authentication : + +* [`google-cloud`](hackage.haskell.org/package/google-cloud) +* [`gogol`](hackage.haskell.org/package/gogol) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/goggles.cabal b/goggles.cabal new file mode 100644 --- /dev/null +++ b/goggles.cabal @@ -0,0 +1,83 @@ +name: goggles +version: 0.1.0.0 +synopsis: Interface to Google Cloud APIs +description: Interface to Google Cloud APIs +homepage: https://github.com/ocramz/goggles +license: BSD3 +license-file: LICENSE +author: Marco Zocca +maintainer: zocca.marco gmail +copyright: 2017 Marco Zocca +category: Network +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 +tested-with: GHC == 8.2 + +library + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + exposed-modules: Network.Goggles + other-modules: Data.Keys + Network.Goggles.Cloud + Network.Utils.HTTP + Network.Goggles.Types + Network.Goggles.Auth.JWT + Network.Goggles.Auth.OAuth2 + Network.Goggles.Auth.TokenExchange + Network.Goggles.Control.Exceptions + build-depends: base >= 4.7 && < 5 + , binary + , scientific + , attoparsec + , aeson + , req >= 0.3 + , http-client + , http-client-tls + , http-types + , cryptonite + , memory + , pem + , x509 + , x509-store + , unix-time + , mtl + , transformers + , text + , bytestring + , base64-bytestring + , time + , stm + -- , envy + , containers + , exceptions + , filepath + -- * DEBUG + , hspec + , QuickCheck + + + +-- executable goggles +-- default-language: Haskell2010 +-- ghc-options: -threaded -rtsopts -with-rtsopts=-N +-- hs-source-dirs: app +-- main-is: Test.hs +-- build-depends: base +-- , goggles + +test-suite spec + default-language: Haskell2010 + ghc-options: -Wall + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , goggles + , hspec + , QuickCheck + +source-repository head + type: git + location: https://github.com/ocramz/goggles diff --git a/src/Data/Keys.hs b/src/Data/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Data/Keys.hs @@ -0,0 +1,36 @@ +{-# language OverloadedStrings #-} +module Data.Keys (parseRSAPrivateKey) where + +import Data.Monoid ((<>)) + +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +-- import qualified Data.Text.IO as T + +import Control.Monad.Catch +-- import Control.Monad.IO.Class + +import Data.X509 +import Data.X509.Memory (readKeyFileFromMemory) +import Crypto.PubKey.RSA.Types + +import Network.Goggles.Control.Exceptions + + +-- | Parse a chunk of text into an RSA private key. For Google Cloud Platform , this is the private key associated with the user's "service account" (for server-to-server API use) +-- +-- > https://console.cloud.google.com/apis/credentials +-- +-- Note: do /not/ supply the RSA header and footer or any newlines (they will be inserted by this function). +parseRSAPrivateKey :: MonadThrow m => T.Text -> m PrivateKey +parseRSAPrivateKey k = + case parseRSAPrivateKey_helper k of [] -> throwM $ NoParsePK "Cannot parse RSA key" + (PrivKeyRSA ok:_) -> return ok + _ -> throwM $ NoRSAKey "Found key is not a RSA private key" + + +parseRSAPrivateKey_helper :: T.Text -> [PrivKey] +parseRSAPrivateKey_helper = readKeyFileFromMemory . withPEMheaders encodeUtf8 where + withPEMheaders encf k = b1 <> encf k <> b2 where + b1 = encf $ T.pack "-----BEGIN RSA PRIVATE KEY-----\n" + b2 = encf $ T.pack "\n-----END RSA PRIVATE KEY-----\n" diff --git a/src/Network/Goggles.hs b/src/Network/Goggles.hs new file mode 100644 --- /dev/null +++ b/src/Network/Goggles.hs @@ -0,0 +1,44 @@ +module Network.Goggles ( + -- * Google Cloud Storage + getObject + , listObjects + , putObject + -- ** GCP Authentication scopes + , scopesDefault + -- ** Running Cloud programs + , evalCloudIO + , liftCloudIO + , createHandle + -- * Types + , GCP + , GCPServiceAccount(..) + , Cloud(..) + -- ** Authentication + , HasCredentials(..) + , Token(..) + -- , accessToken + -- , refreshToken + , Handle(..) + -- * Private key + , parseRSAPrivateKey + -- * Exceptions + , KeyException(..) + , JWTError(..) + , TokenExchangeException(..) + , CloudException(..) + ) where + + +import Network.Goggles.Control.Exceptions +import Network.Goggles.Cloud +import Network.Goggles.Types +import Network.Goggles.Auth.TokenExchange +import Data.Keys +-- import System.Environment (lookupEnv) + + + + + + + diff --git a/src/Network/Goggles/Auth/JWT.hs b/src/Network/Goggles/Auth/JWT.hs new file mode 100644 --- /dev/null +++ b/src/Network/Goggles/Auth/JWT.hs @@ -0,0 +1,72 @@ +{-# language OverloadedStrings, FlexibleContexts, RecordWildCards #-} +module Network.Goggles.Auth.JWT where + +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Text as T + + +import qualified Data.Aeson as J +import Data.Aeson ((.=)) +import qualified Data.Aeson.Types as J (Pair) + +import Data.Monoid ((<>)) + +import Data.UnixTime (getUnixTime, utSeconds, UnixTime(..)) +import Foreign.C.Types + +import Control.Monad.Except +import Control.Monad.Trans (liftIO) +import Control.Monad.Catch + +import qualified Crypto.Hash.Algorithms as CR +import qualified Crypto.PubKey.RSA.PKCS15 as CR (signSafer) +import qualified Crypto.Random.Types as CR + + +import Data.ByteArray +import Data.ByteArray.Encoding + +import Network.Goggles.Types +import Network.Goggles.Control.Exceptions + + + +-- | Returns a bytestring with the signed JWT-encoded token request. +-- adapted from https://github.com/brendanhay/gogol/blob/master/gogol/src/Network/Google/Auth/ServiceAccount.hs +encodeBearerJWT :: (MonadThrow m, CR.MonadRandom m, MonadIO m) => + GCPServiceAccount + -> GCPTokenOptions + -> m B8.ByteString +encodeBearerJWT s opts = do + i <- input <$> liftIO getUnixTime + r <- CR.signSafer (Just CR.SHA256) (_servicePrivateKey s) i + either failure (pure . concat' i) r + where + concat' i x = i <> "." <> signature (base64 x) + failure e = throwM $ CryptoSignError (show e) + signature bs = case B8.unsnoc bs of + Nothing -> mempty + Just (bs', x) + | x == '=' -> bs' + | otherwise -> bs + input t = header <> "." <> payload + where + header = base64Encode + [ "alg" .= ("RS256" :: T.Text) + , "typ" .= ("JWT" :: T.Text) ] + payload = base64Encode $ + [ "aud" .= T.pack "https://www.googleapis.com/oauth2/v4/token" + , "scope" .= (T.intercalate " " $ _tokenOptionsScopes opts) + , "iat" .= toT (utSeconds t) + , "exp" .= toT (CTime 3600 + utSeconds t) + , "iss" .= _serviceEmail s + ] <> maybe [] (\sub -> ["sub" .= sub]) (_serviceAccountUser s) + toT = T.pack . show + + +base64Encode :: [J.Pair] -> B8.ByteString +base64Encode = base64 . LB.toStrict . J.encode . J.object + +base64 :: ByteArray a => a -> B8.ByteString +base64 = convertToBase Base64URLUnpadded diff --git a/src/Network/Goggles/Auth/OAuth2.hs b/src/Network/Goggles/Auth/OAuth2.hs new file mode 100644 --- /dev/null +++ b/src/Network/Goggles/Auth/OAuth2.hs @@ -0,0 +1,85 @@ +{-# language OverloadedStrings, DeriveGeneric #-} +module Network.Goggles.Auth.OAuth2 + ( + requestOAuth2Token + , OAuth2Token(..) + , OAuth2TokenUTC(..) + , mkOAuth2TokenUTC + ) + where + + +import Network.HTTP.Req +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO(..), liftIO) +import GHC.Generics +import qualified Data.Text as T +-- import qualified Data.Text.Encoding as T (encodeUtf8) +-- import qualified Data.ByteString.Char8 as B8 +-- import qualified Data.ByteString.Lazy as LB +import qualified Data.Aeson as J +import Data.Aeson ((.:), (.:?)) +import Network.Utils.HTTP +import Data.Time + +import Network.Goggles.Control.Exceptions + + + +data OAuth2TokenUTC = OAuth2TokenUTC { + oauTokenExpiry :: UTCTime + , oauTokenString :: T.Text + , oauTokenType :: Maybe T.Text + } deriving (Eq, Show) + +mkOAuth2TokenUTC :: (MonadIO m, Integral t) => t -> OAuth2Token -> m OAuth2TokenUTC +mkOAuth2TokenUTC delta oa2 = liftIO $ + OAuth2TokenUTC <$> + tokenExpiryTime delta (oaTokenExpirySeconds oa2) <*> + pure (oaTokenString oa2) <*> + pure (oaTokenType oa2) + + +data OAuth2Token = OAuth2Token { + oaTokenExpirySeconds :: Int + , oaTokenString :: T.Text + , oaTokenType :: Maybe T.Text + } deriving (Eq, Show, Generic) + +instance J.FromJSON OAuth2Token where + parseJSON = J.withObject "OAuth2Token" $ \js -> OAuth2Token + <$> js .: "expires_in" + <*> js .: "access_token" + <*> js .:? "token_type" + + +-- | send a POST request over HTTPS to a given URI that will return a OAuth2Token +requestOAuth2Token + :: (MonadHttp m, MonadThrow m) => + Url scheme -- ^ Request URI + -> [(T.Text, T.Text)] -- ^ parameter list as a list of (key, value) pairs + -> Option scheme -- ^ request options (e.g. headers) + -> m OAuth2Token +requestOAuth2Token uri args httpOpts = do + let payload = encodeHttpParametersLB args + r <- req POST + uri + (ReqBodyLbs payload) + lbsResponse + httpOpts + maybe (throwM $ NotFound "Something went wrong with the token request") pure (J.decode (responseBody r) :: Maybe OAuth2Token) + + + + +-- | Returns the UTCTime (absolute) related to a delay in seconds from the time this function is executed. We need this helper function because the "expires_in" field in the OAuth2 response means "seconds from now". +tokenExpiryTime :: + (Integral t, Integral t1) => + t -- ^ Correction for system delays (e.g. processing and network time). Positive + -> t1 -- ^ "seconds from now" parameter. Positive + -> IO UTCTime +tokenExpiryTime delta s = do + tnow <- getCurrentTime + let sd = fromIntegral s + sdelta = fromIntegral delta + return $ addUTCTime (sd - sdelta) tnow diff --git a/src/Network/Goggles/Auth/TokenExchange.hs b/src/Network/Goggles/Auth/TokenExchange.hs new file mode 100644 --- /dev/null +++ b/src/Network/Goggles/Auth/TokenExchange.hs @@ -0,0 +1,144 @@ +{-# language OverloadedStrings, DeriveGeneric, TypeFamilies, GeneralizedNewtypeDeriving #-} +{-# language FlexibleContexts, MultiParamTypeClasses, DataKinds, FlexibleInstances #-} +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) + + + + +-- * The GCP type + +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] + +-- | We can provide a custom http exception handler rather than throwing exceptions with this instance +instance MonadHttp (Cloud GCP) where + handleHttpException = throwM + + + + + +-- * Constants + +-- | OAuth2 scopes for the various Google Cloud Platform services. +-- +-- Please refer to +-- +-- > https://developers.google.com/identity/protocols/googlescopes +-- +-- for the full list +scopesDefault :: [T.Text] +scopesDefault = ["https://www.googleapis.com/auth/cloud-platform"] + +uriBase :: Url 'Https +uriBase = https "www.googleapis.com" + + + +-- * Google Cloud Storage (GCS) + +-- | `getObject b p` retrieves the contents of a GCS object (of full path `p`) in bucket `b` +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 b p` retrieves the metadata of a GCS object (of full path `p`) in bucket `b` +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 + +-- +-- GET https://www.googleapis.com/storage/v1/b/bucket/o +-- | `listObjects b` retrieves a list of objects stored in bucket `b` +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 b p body` uploads a bytestring `body` into a GCS object (of full path `p`) in bucket `b` +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 + + + +-- | Constant request parameters required by GCS calls +altMedia, ulMedia :: Option 'Https +altMedia = "alt" =: ("media" :: T.Text) +ulMedia = "uploadType" =: ("media" :: T.Text) + + + + + +-- | Implementation of `tokenFetch` +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)) + + +-- | Request an OAuth2Token +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") diff --git a/src/Network/Goggles/Cloud.hs b/src/Network/Goggles/Cloud.hs new file mode 100644 --- /dev/null +++ b/src/Network/Goggles/Cloud.hs @@ -0,0 +1,164 @@ +{-# language OverloadedStrings, TypeFamilies, GeneralizedNewtypeDeriving #-} +{-# language FlexibleContexts, MultiParamTypeClasses, DeriveDataTypeable #-} +{-# language UndecidableInstances #-} +module Network.Goggles.Cloud ( + Cloud(..) + , evalCloudIO + , liftCloudIO + , HasCredentials(..) + , Token(..) + , accessToken + , refreshToken + , Handle(..) + , createHandle + ) where + +import Control.Applicative (Alternative(..)) +import Control.Monad.IO.Class +import Control.Monad.Catch +import Control.Monad.Reader +import qualified Control.Monad.Trans.Reader as RT (ask, local) +import Crypto.Random.Types (MonadRandom(..)) +import Crypto.Random.Entropy (getEntropy) +import Control.Exception (AsyncException, fromException) +import Control.Concurrent.STM +import Data.Time + +import Network.Goggles.Control.Exceptions + + +class HasCredentials c where + type Credentials c + type Options c + type TokenContent c + tokenFetch :: Cloud c (Token c) + +-- | A 'Token' with an expiry date +data Token c = Token { + tToken :: TokenContent c + , tTime :: UTCTime + } + +data Handle c = Handle { + credentials :: Credentials c + , token :: TVar (Maybe (Token c)) + , options :: Options c + } + + +-- | `cacheToken tok hdl` : Overwrite the token TVar `tv` containing a token if `tok` carries a more recent timestamp. +cacheToken :: + HasCredentials c => Token c -> Cloud c (Token c) +cacheToken tok = do + tv <- asks token + liftCloudIO $ atomically $ do + current <- readTVar tv + let new = case current of + Nothing -> tok + Just t -> if tTime t > tTime tok then t else tok + writeTVar tv (Just new) + return new + +refreshToken :: HasCredentials c => Cloud c (Token c) +refreshToken = tokenFetch >>= cacheToken + + + +-- | Extract the token content (needed to authenticate subsequent requests). The token will be valid for at least 60 seconds +accessToken :: HasCredentials c => Cloud c (TokenContent c) +accessToken = do + tokenTVar <- asks token + mbToken <- liftCloudIO $ atomically $ readTVar tokenTVar + tToken <$> case mbToken of + Nothing -> refreshToken + Just t -> do + now <- liftCloudIO $ getCurrentTime + if now > addUTCTime (- 60) (tTime t) + then refreshToken + else return t + +-- | Create a 'Handle' with an empty token +createHandle :: HasCredentials c => Credentials c -> Options c -> IO (Handle c) +createHandle sa opts = Handle <$> pure sa <*> newTVarIO Nothing <*> pure opts + +-- | The main type of the library. It can easily be re-used in libraries that interface with more than one cloud API provider because its type parameter `c` lets us be declare distinct behaviours for each. +newtype Cloud c a = Cloud { + runCloud :: ReaderT (Handle c) IO a + } deriving (Functor, Applicative, Monad) + + +instance HasCredentials c => Alternative (Cloud c) where + empty = throwM $ UnknownError "empty" + a1 <|> a2 = do + ra <- try a1 + case ra of + Right x -> pure x + Left e -> case (fromException e) :: Maybe CloudException of + Just _ -> a2 + Nothing -> throwM (UnknownError "Uncaught exception (not a CloudException)") + + +-- -- | NB : this works similarly to <|> in the Alternative instance; it must discard information on which exception case occurred +-- tryOrElse :: MonadCatch m => m b -> m b -> m b +-- tryOrElse a1 a2 = do +-- ra <- try a1 +-- case ra of +-- Right x -> pure x +-- Left e -> case (e :: CloudException) of _ -> a2 + + + + +-- | Lift an `IO a` action into the 'Cloud' monad +liftCloudIO_ :: IO a -> Cloud c a +liftCloudIO_ m = Cloud $ ReaderT (const m) + +-- | Lift an `IO a` action into the 'Cloud' monad, and catch synchronous exceptions, while rethrowing the asynchronous ones to IO +liftCloudIO :: HasCredentials c => IO a -> Cloud c a +liftCloudIO m = do + liftCloudIO_ m `catch` \e -> case fromException e of + Just asy -> throwM (asy :: AsyncException) + Nothing -> throwM $ IOError (show e) + + + + + + +-- | Evaluate a 'Cloud' action, given a 'Handle'. +-- +-- NB : Assumes all exceptions are handled by `throwM` +evalCloudIO :: Handle c -> Cloud c a -> IO a +evalCloudIO r (Cloud b) = runReaderT b r `catch` \e -> case (e :: CloudException) of + ex -> throwM ex + + + + + + + + + +instance HasCredentials c => MonadIO (Cloud c) where + liftIO = liftCloudIO + +instance HasCredentials c => MonadThrow (Cloud c) where + throwM = liftIO . throwM + +instance HasCredentials c => MonadCatch (Cloud c) where + catch (Cloud (ReaderT m)) c = + Cloud $ ReaderT $ \r -> m r `catch` \e -> runReaderT (runCloud $ c e) r + +{- | the whole point of this parametrization is to have a distinct MonadHttp for each API provider/DSP + +instance HasCredentials c => MonadHttp (Boo c) where + handleHttpException = throwM +-} + +instance HasCredentials c => MonadRandom (Cloud c) where + getRandomBytes = liftIO . getEntropy + +instance HasCredentials c => MonadReader (Handle c) (Cloud c) where + ask = Cloud RT.ask + local f m = Cloud $ RT.local f (runCloud m) diff --git a/src/Network/Goggles/Control/Exceptions.hs b/src/Network/Goggles/Control/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Network/Goggles/Control/Exceptions.hs @@ -0,0 +1,43 @@ +module Network.Goggles.Control.Exceptions ( + KeyException(..) + , JWTError(..) + , TokenExchangeException(..) + , CloudException(..) + )where + +import Control.Exception +import Data.Typeable + +-- | Authentication key exceptions +data KeyException = + NoSecretFound !String + | NoParsePK !String + | NoRSAKey !String + deriving (Eq, Show, Typeable) +instance Exception KeyException + +-- | Errors associated with JWT-encoded token request +data JWTError = + BadExpirationTime !String + | CryptoSignError !String + deriving (Show, Typeable) +instance Exception JWTError where + + +-- | Token exchange exceptions +data TokenExchangeException = + NotFound !String -- ^ Something went wrong with the request, token not found + | APICredentialsNotFound !String -- ^ + deriving (Show, Typeable) +instance Exception TokenExchangeException + +-- | Cloud API exception +data CloudException = + UnknownError !String + | IOError !String + | TimeoutError !String + | JsonDecodeError !String + deriving (Show, Typeable) +instance Exception CloudException + + diff --git a/src/Network/Goggles/Types.hs b/src/Network/Goggles/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Goggles/Types.hs @@ -0,0 +1,24 @@ +{-# language TypeFamilies, FlexibleInstances #-} +module Network.Goggles.Types ( + GCPServiceAccount(..) + , GCPTokenOptions(..) ) where + +import qualified Data.Text as T +import Crypto.PubKey.RSA.Types + + + + +-- | Credentials for Google Cloud Platform +data GCPServiceAccount = GCPServiceAccount { + _servicePrivateKey :: PrivateKey -- ^ Private key (i.e. the PEM string obtained from the Google API Console) + , _serviceEmail :: T.Text -- ^ Email address of the service account (ending in .gserviceaccount.com ) + , _serviceAccountUser :: Maybe T.Text -- ^ email address of the user for which the application is requesting delegated access (defaults to the service account email if Nothing) + , _gcpServiceAcctSecret :: T.Text -- ^ Service account secret + } deriving (Eq, Show) + + + +data GCPTokenOptions = GCPTokenOptions { + _tokenOptionsScopes :: [T.Text] -- ^ authentication scopes that the application requests + } deriving (Eq, Show) diff --git a/src/Network/Utils/HTTP.hs b/src/Network/Utils/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Network/Utils/HTTP.hs @@ -0,0 +1,69 @@ +{-# language OverloadedStrings, FlexibleContexts #-} +module Network.Utils.HTTP where + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T (encodeUtf8) +import qualified Data.ByteString.Lazy as LB +import Data.Char ( isAscii, isAlphaNum, digitToInt ) +import Network.HTTP.Req + +import Network.Goggles.Cloud + + + +getLbs :: (HasCredentials c, MonadHttp (Cloud c)) => + Url scheme -> Option scheme -> Cloud c LbsResponse +getLbs uri opts = req GET uri NoReqBody lbsResponse opts + +postLbs :: (HasCredentials c, MonadHttp (Cloud c)) => + Url scheme -> Option scheme -> LB.ByteString -> Cloud c LbsResponse +postLbs uri opts body = req POST uri (ReqBodyLbs body) lbsResponse opts + +putLbs :: (HasCredentials c, MonadHttp (Cloud c)) => + Url scheme -> Option scheme -> LB.ByteString -> Cloud c LbsResponse +putLbs uri opts body = req PUT uri (ReqBodyLbs body) lbsResponse opts + + + + + +-- | produce a '&'-separated list of parameters that can be passed to an HTTP querty from a list of key, value pairs +encodeHttpParametersLB :: [(T.Text, T.Text)] -> LB.ByteString +encodeHttpParametersLB ps = LB.fromStrict $ T.encodeUtf8 $ T.intercalate "&" $ map ins ps where + ins (k, v) = T.concat [k, "=", v] + +encodeHttpParameters :: (QueryParam p, Monoid p) => [(T.Text, T.Text)] -> p +encodeHttpParameters ll = mconcat $ map ins ll where + ins (a, b) = a =: b + + + +-- http://hackage.haskell.org/package/HTTP-4000.2.3/docs/src/Network-HTTP-Base.html + +urlEncode :: String -> String +urlEncode [] = [] +urlEncode (ch:t) + | (isAscii ch && isAlphaNum ch) || ch `elem` ("-_.~" :: String) = ch : urlEncode t + | not (isAscii ch) = foldr escape (urlEncode t) (eightBs [] (fromEnum ch)) + | otherwise = escape (fromEnum ch) (urlEncode t) + where + escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs) + + showH x xs + | x <= 9 = toEnum (o_0 + x) : xs + | otherwise = toEnum (o_A + (x-10)) : xs + where + o_0 = fromEnum '0' + o_A = fromEnum 'A' + + eightBs :: [Int] -> Int -> [Int] + eightBs acc x + | x <= 0xff = (x:acc) + | otherwise = eightBs ((x `mod` 256) : acc) (x `div` 256) + + +urlDecode :: String -> String +urlDecode ('%':a:b:rest) = toEnum (16 * digitToInt a + digitToInt b) + : urlDecode rest +urlDecode (h:t) = h : urlDecode t +urlDecode [] = [] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}