packages feed

goggles-gcs (empty) → 0.1.0.0

raw patch · 9 files changed

+382/−0 lines, 9 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, cryptonite, exceptions, goggles, memory, mtl, req, text, unix-time

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++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 Author name here 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.
+ README.md view
@@ -0,0 +1,5 @@+# goggles-gcs++[![Build Status](https://travis-ci.org/ocramz/goggles-gcs.png)](https://travis-ci.org/ocramz/goggles-gcs)++TODO Description.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ goggles-gcs.cabal view
@@ -0,0 +1,51 @@+name:                goggles-gcs+version:             0.1.0.0+synopsis:            `goggles` interface to Google Cloud Storage+description:         `goggles` interface to Google Cloud Storage+homepage:            https://github.com/ocramz/goggles-gcs+license:             BSD3+license-file:        LICENSE+author:              Marco Zocca+maintainer:          zocca.marco gmail+copyright:           2018 Marco Zocca+category:            Acme+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10+tested-with:         GHC == 8.0.2, GHC == 8.2.2++library+  default-language:    Haskell2010+  ghc-options:         -Wall+  hs-source-dirs:      src+  exposed-modules:     Network.Goggles.GCS+  other-modules:       Network.Goggles.Auth.GCP+                       Network.Goggles.Types.GCP+                       Network.Goggles.Auth.GCP.JWT+                       Network.Goggles.Auth.GCP.TokenExchange+  build-depends:       base >= 4.7 && < 5+                     , goggles+                     , aeson+                     , unix-time+                     , mtl+                     , text+                     , bytestring+                     , cryptonite+                     , memory+                     , exceptions+                     , req++-- 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-gcs+--                      , hspec+--                      , QuickCheck++source-repository head+  type:     git+  location: https://github.com/ocramz/goggles
+ src/Network/Goggles/Auth/GCP.hs view
@@ -0,0 +1,11 @@+module Network.Goggles.Auth.GCP+  (+  GCP(..), scopesDefault,+  getObject,+  getObjectMetadata,+  listObjects,+  putObject+  )+where++import Network.Goggles.Auth.GCP.TokenExchange
+ src/Network/Goggles/Auth/GCP/JWT.hs view
@@ -0,0 +1,73 @@+{-# language OverloadedStrings, FlexibleContexts, RecordWildCards #-}+module Network.Goggles.Auth.GCP.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+import Network.Goggles.Types.GCP+++++-- | 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
+ src/Network/Goggles/Auth/GCP/TokenExchange.hs view
@@ -0,0 +1,145 @@+{-# language OverloadedStrings, DeriveGeneric, TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# language FlexibleContexts, MultiParamTypeClasses, DataKinds, FlexibleInstances #-}+module Network.Goggles.Auth.GCP.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+import Network.Goggles.Types.GCP+import Network.Goggles.Auth+import Network.Goggles.Auth.GCP.JWT+-- import Network.Utils.HTTP (putLbs, getLbs, urlEncode)+++++-- * The GCP type++data GCP++instance HasCredentials GCP where+  type Credentials GCP = GCPServiceAccount++instance HasToken GCP where+  type Options GCP = GCPTokenOptions -- [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 (WebApiM 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 -> WebApiM 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 -> WebApiM 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 -> WebApiM 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 -> WebApiM 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 :: WebApiM GCP (Token GCP)+requestTokenGCP = do+   saOk <- asks credentials+   opts <- asks options+   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")
+ src/Network/Goggles/GCS.hs view
@@ -0,0 +1,40 @@+{-|+== /Dependencies/++The examples require the following declarations (which in turn mean that the @req@ and @bytestring@ libraries are imported by the user's project). You will also need the @OverloadedStrings@ language extension :++> import qualified Data.ByteString.Lazy as LB+> import Network.HTTP.Req (responseBody)+> import Network.Goggles++== /Examples/++This first example, @listBucket@, reads content from a cloud storage bucket:++1. it loads the GCP credentials (username and RSA key),+2. retrieves a token via OAuth2,+3. performs a single call to the Cloud Storage API endpoint that lists the metadata related to the contents of a storage bucket, and+4. returns the raw API data to the user as a lazy ByteString.++> listBucket :: IO LB.ByteString+> listBucket = do+>   let usr = "...iam.gserviceaccount.com"+>       bucket = "<my-gcs-bucket>"+>       key = "<rsa_key>"+>   pvtkey <- parseRSAPrivateKey key+>   let creds = GCPServiceAccount pvtkey usr Nothing ""+>   hdl <- createHandle creds scopesDefault+>   responseBody <$> evalWebApiIO hdl (listObjects bucket)++-}++module Network.Goggles.GCS (+  GCP(..), scopesDefault,+  getObject,+  getObjectMetadata,+  listObjects,+  putObject+  )+where++import Network.Goggles.Auth.GCP
+ src/Network/Goggles/Types/GCP.hs view
@@ -0,0 +1,25 @@+{-# language TypeFamilies, FlexibleInstances #-}+module Network.Goggles.Types.GCP (+    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)