68b46a1 · gogol · git.iko.soy

git.iko.soy/gogol

Adding primitive logging of HTTP and token refresh requests

commit68b46a1adde9f383d7e58c052e44a67056f620c9 authorBrendan Hay <brendan.g.hay@gmail.com> dateThu 22 Oct 2015, 11:57 (11 years ago) parentf1cbd0d

6 files changed+331−51

compare with develop

unifiedsplit

gogol/gogol.cabal+1 gogol/src/Network/Google.hs+32−10 gogol/src/Network/Google/Auth.hs+75−35 gogol/src/Network/Google/Env.hs+13−5 gogol/src/Network/Google/Internal/HTTP.hs+9−1 gogol/src/Network/Google/Internal/Logger.hs+201

gogol/gogol.cabal+1

@@ -46,6 +46,7 @@ library

4646

4747 other-modules:

4848 Network.Google.Internal.HTTP

49+ , Network.Google.Internal.Logger

4950 , Network.Google.Internal.Multipart

5051

5152 build-depends:

gogol/src/Network/Google.hs+32−10

@@ -68,6 +68,15 @@ module Network.Google

6868 , trying

6969 , catching

7070

71+ -- * Logging

72+ -- $logging

73+

74+ , Logger

75+ , LogLevel (..)

76+

77+ -- ** Constructing a Logger

78+ , newLogger

79+

7180 -- * Re-exported Types

7281 , Proxy (..)

7382 , OctetStream

@@ -82,21 +91,22 @@ import Control.Monad

8291import Control.Monad.Base

8392import Control.Monad.Catch

8493import Control.Monad.Reader

85−import qualified Control.Monad.RWS.Lazy as LRW

86−import qualified Control.Monad.RWS.Strict as RW

87−import qualified Control.Monad.State.Lazy as LS

88−import qualified Control.Monad.State.Strict as S

94+import qualified Control.Monad.RWS.Lazy as LRW

95+import qualified Control.Monad.RWS.Strict as RW

96+import qualified Control.Monad.State.Lazy as LS

97+import qualified Control.Monad.State.Strict as S

8998import Control.Monad.Trans.Control

90−import Control.Monad.Trans.Except (ExceptT)

91−import Control.Monad.Trans.Identity (IdentityT)

92−import Control.Monad.Trans.List (ListT)

93−import Control.Monad.Trans.Maybe (MaybeT)

99+import Control.Monad.Trans.Except (ExceptT)

100+import Control.Monad.Trans.Identity (IdentityT)

101+import Control.Monad.Trans.List (ListT)

102+import Control.Monad.Trans.Maybe (MaybeT)

94103import Control.Monad.Trans.Resource

95−import qualified Control.Monad.Writer.Lazy as LW

96−import qualified Control.Monad.Writer.Strict as W

104+import qualified Control.Monad.Writer.Lazy as LW

105+import qualified Control.Monad.Writer.Strict as W

97106import Network.Google.Auth

98107import Network.Google.Env

99108import Network.Google.Internal.HTTP

109+import Network.Google.Internal.Logger

100110import Network.Google.Prelude

101111import Network.Google.Types

102112

@@ -187,3 +197,15 @@ hoistError = either (throwingM _Error) return

187197Requests can be sent asynchronously, but due to guarantees about resource closure

188198require the use of <http://hackage.haskell.org/package/lifted-async lifted-async>.

189199-}

200+

201+{- $logging

202+The exposed logging interface is a primitive 'Logger' function which gets

203+threaded through service calls and serialisation routines. This allows the

204+library to output useful information and diagnostics.

205+

206+The 'newLogger' function can be used to construct a simple logger which writes

207+output to a 'Handle', but in most production code you should probably consider

208+using a more robust logging library such as

209+<http://hackage.haskell.org/package/tiny-log tiny-log> or

210+<http://hackage.haskell.org/package/fast-logger fast-logger>.

211+-}

gogol/src/Network/Google/Auth.hs+75−35

@@ -57,6 +57,7 @@ module Network.Google.Auth

5757 , ClientId (..)

5858 ) where

5959

60+import Control.Applicative

6061import Control.Concurrent

6162import Control.Exception.Lens

6263import Control.Lens hiding ((.=))

@@ -82,6 +83,7 @@ import Data.Typeable

8283import Data.X509

8384import Data.X509.Memory

8485import Network.Google.Compute.Metadata

86+import Network.Google.Internal.Logger

8587import Network.Google.Prelude

8688import Network.HTTP.Conduit hiding (Request)

8789import qualified Network.HTTP.Conduit as Client

@@ -198,47 +200,64 @@ data Credentials

198200--

199201-- Throws 'AuthError' when environment variables or service account information

200202-- cannot be read, and credentials files are invalid or cannot be found.

201−getAuth :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Auth

202−getAuth c m = case c of

203+getAuth :: (MonadIO m, MonadCatch m)

204+ => Credentials

205+ -> Logger

206+ -> Manager

207+ -> m Auth

208+getAuth c l m = case c of

203209 FromToken t -> pure (AuthToken t)

204− FromFile f -> fromFilePath f m

205− FromAccount s -> fromMetadata s m

210+ FromFile f -> fromFilePath f l m

211+ FromAccount s -> fromMetadata s l m

206212 Discover ->

207− catching _MissingFileError (fromFile m) $ \f -> do

213+ catching _MissingFileError (fromFile l m) $ \f -> do

208214 p <- isGCE m

209215 unless p $

210216 throwingM _MissingFileError f

211− fromMetadata "default" m

217+ fromMetadata "default" l m

212218

213219-- | Refresh a token from the local GCE metadata endpoint for the specified

214220-- 'ServiceId'.

215−fromMetadata :: (MonadIO m, MonadCatch m) => ServiceId -> Manager -> m Auth

216−fromMetadata s = refresh s >=> fmap AuthMeta . liftIO . newMVar

221+fromMetadata :: (MonadIO m, MonadCatch m)

222+ => ServiceId

223+ -> Logger

224+ -> Manager

225+ -> m Auth

226+fromMetadata s l = refresh s l >=> fmap AuthMeta . liftIO . newMVar

217227

218228-- | Attempt to load either a @service_account@ or @authorized_user@ formatted

219229-- file to obtain the credentials neccessary to perform a token refresh.

220−fromFile :: (MonadIO m, MonadCatch m) => Manager -> m Auth

221−fromFile m = do

230+fromFile :: (MonadIO m, MonadCatch m) => Logger -> Manager -> m Auth

231+fromFile l m = do

222232 f <- defaultCredentialsPath

223233 case f of

224− Just x -> fromFilePath x m

234+ Just x -> fromFilePath x l m

225235 Nothing -> do

226236 x <- cloudSDKConfigPath

227− fromFilePath x m

237+ fromFilePath x l m

238+

239+data Parse = SA !ServiceAccount | AU !AuthorisedUser

240+

241+instance FromJSON Parse where

242+ parseJSON o = SA <$> parseJSON o <|> AU <$> parseJSON o

228243

229244-- | Attempt to load either a @service_account@ or @authorized_user@ formatted

230245-- file to obtain the credentials neccessary to perform a token refresh from

231246-- the specified file.

232−fromFilePath :: (MonadIO m, MonadCatch m) => FilePath -> Manager -> m Auth

233−fromFilePath f m = do

247+fromFilePath :: (MonadIO m, MonadCatch m)

248+ => FilePath

249+ -> Logger

250+ -> Manager

251+ -> m Auth

252+fromFilePath f l m = do

234253 p <- liftIO (doesFileExist f)

235254 unless p $

236255 throwM (MissingFileError f)

237256 e <- liftIO (LBS.readFile f) >>=

238257 either (throwM . InvalidFileError f) pure . parseLBS

239258 case e of

240− Left a -> refresh a m >>= fmap AuthSign . liftIO . newMVar

241− Right u -> refresh u m >>= fmap AuthUser . liftIO . newMVar

259+ SA a -> refresh a l m >>= fmap AuthSign . liftIO . newMVar

260+ AU u -> refresh u l m >>= fmap AuthUser . liftIO . newMVar

242261

243262-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the

244263-- default application credentials filepath.

@@ -289,15 +308,16 @@ data Auth

289308 | AuthUser !(MVar (Expires AuthorisedUser))

290309

291310authorise :: (MonadIO m, MonadCatch m)

292− => Manager

311+ => Logger

312+ -> Manager

293313 -> Client.Request

294314 -> Auth

295315 -> m Client.Request

296−authorise m rq = \case

316+authorise l m rq = \case

297317 AuthToken t -> pure $! authoriseBearer rq t

298− AuthSign r -> authoriseToken m r rq

299− AuthMeta r -> authoriseToken m r rq

300− AuthUser r -> authoriseToken m r rq

318+ AuthSign r -> authoriseToken l m r rq

319+ AuthMeta r -> authoriseToken l m r rq

320+ AuthUser r -> authoriseToken l m r rq

301321

302322authoriseBearer :: Client.Request -> OAuthToken -> Client.Request

303323authoriseBearer rq t = rq

@@ -306,17 +326,19 @@ authoriseBearer rq t = rq

306326 }

307327

308328authoriseToken :: (MonadIO m, MonadCatch m, Refresh a)

309− => Manager

329+ => Logger

330+ -> Manager

310331 -> MVar (Expires a)

311332 -> Client.Request

312333 -> m Client.Request

313−authoriseToken m r rq = authoriseBearer rq <$> refreshToken m r

334+authoriseToken l m r rq = authoriseBearer rq <$> refreshToken l m r

314335

315336refreshToken :: (MonadIO m, MonadCatch m, Refresh a)

316− => Manager

337+ => Logger

338+ -> Manager

317339 -> MVar (Expires a)

318340 -> m OAuthToken

319−refreshToken m r = do

341+refreshToken l m r = do

320342 x <- liftIO (readMVar r)

321343 xv <- isValid x

322344 if xv

@@ -326,7 +348,7 @@ refreshToken m r = do

326348 if yv

327349 then pure (y, _token y)

328350 else do

329− z <- refresh (_details y) m

351+ z <- refresh (_details y) l m

330352 pure (z, _token z)

331353

332354-- {

@@ -400,10 +422,14 @@ instance FromJSON AuthorisedUser where

400422 <*> o .: "refresh_token"

401423

402424class Refresh a where

403− refresh :: (MonadIO m, MonadCatch m) => a -> Manager -> m (Expires a)

425+ refresh :: (MonadIO m, MonadCatch m)

426+ => a

427+ -> Logger

428+ -> Manager

429+ -> m (Expires a)

404430

405431instance Refresh ServiceAccount where

406− refresh s m = do

432+ refresh s l m = do

407433 b <- jwtEncode s

408434 let rq = accountsRequest

409435 { Client.requestBody = RequestBodyBS $

@@ -411,7 +437,7 @@ instance Refresh ServiceAccount where

411437 <> "&assertion="

412438 <> b

413439 }

414− refreshRequest s rq m

440+ refreshRequest s rq l m

415441

416442jwtEncode :: (MonadIO m, MonadThrow m) => ServiceAccount -> m ByteString

417443jwtEncode s = liftIO $ do

@@ -477,15 +503,22 @@ accountsRequest = def

477503refreshRequest :: (MonadIO m, MonadCatch m)

478504 => a

479505 -> Client.Request

506+ -> Logger

480507 -> Manager

481508 -> m (Expires a)

482−refreshRequest r rq m = do

509+refreshRequest r rq l m = do

510+ logDebug l rq -- debug:ClientRequest

511+

483512 rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)

513+

514+ logDebug l rs -- debug:ClientResponse

515+

484516 let bs = responseBody rs

485517 s = responseStatus rs

518+

486519 if fromEnum s == 200

487520 then success s bs

488− else failure s bs

521+ else failure s

489522 where

490523 success s bs = do

491524 f <- parseErr s bs

@@ -493,17 +526,24 @@ refreshRequest r rq m = do

493526 let Bearer {..} = f ts

494527 pure $! Expires _bearerExpiry _bearerAccess r

495528

496− failure s = const $

497− refreshErr s ("Failure refreshing token from " <> Text.decodeUtf8 (Client.host rq))

498− Nothing

529+ failure s = do

530+ let e = "Failure refreshing token from " <> host <> path

531+ logError l $ "[Refresh Error] " <> build e

532+ refreshErr s e Nothing

499533

500534 parseErr s bs =

501535 case parseLBS bs of

502− Left e -> refreshErr s e Nothing

503536 Right !x -> pure x

537+ Left e -> do

538+ logError l $ "[Parse Error] Failure parsing token refresh " <> build e

539+ refreshErr s e Nothing

504540

541+ refreshErr :: MonadThrow m => Status -> Text -> Maybe Text -> m a

505542 refreshErr s e = throwM . TokenRefreshError s e

506543

544+ host = Text.decodeUtf8 (Client.host rq)

545+ path = Text.decodeUtf8 (Client.path rq)

546+

507547parseLBS :: FromJSON a => LBS.ByteString -> Either Text a

508548parseLBS = either (Left . Text.pack) Right . eitherDecode'

509549

gogol/src/Network/Google/Env.hs+13−5

@@ -13,15 +13,17 @@ import Control.Lens

1313import Control.Monad.Catch

1414import Control.Monad.IO.Class

1515import Control.Monad.Reader

16−import Data.Function (on)

16+import Data.Function (on)

1717import Data.Monoid

1818import Network.Google.Auth

19+import Network.Google.Internal.Logger

1920import Network.Google.Types

2021import Network.HTTP.Conduit

2122

2223-- | The environment containing the parameters required to make Google requests.

2324data Env = Env

24− { _envOverride :: !(Dual (Endo Service))

25+ { _envLogger :: !Logger

26+ , _envOverride :: !(Dual (Endo Service))

2527 , _envManager :: !Manager

2628 , _envAuth :: !Auth

2729 }

@@ -33,6 +35,9 @@ class HasEnv a where

3335 environment :: Lens' a Env

3436 {-# MINIMAL environment #-}

3537

38+ -- | The function used to output log messages.

39+ envLogger :: Lens' a Logger

40+

3641 -- | The currently applied overrides to all 'Service' configuration.

3742 envOverride :: Lens' a (Dual (Endo Service))

3843

@@ -42,6 +47,7 @@ class HasEnv a where

4247 -- | The credentials used to sign requests for authentication with Google.

4348 envAuth :: Lens' a Auth

4449

50+ envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a })

4551 envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a })

4652 envManager = environment . lens _envManager (\s a -> s { _envManager = a })

4753 envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })

@@ -101,8 +107,10 @@ timeout s = local (override (serviceTimeout ?~ s))

101107--

102108-- /See:/ 'newEnvWith'.

103109newEnv :: (MonadIO m, MonadCatch m) => Credentials -> m Env

104−newEnv c = liftIO (newManager tlsManagerSettings) >>= newEnvWith c

110+newEnv c = liftIO (newManager tlsManagerSettings) >>= newEnvWith c logger

111+ where

112+ logger _ _ = pure ()

105113

106114-- | /See:/ 'newEnv'

107−newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Env

108−newEnvWith c m = Env mempty m <$> getAuth c m

115+newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Logger -> Manager -> m Env

116+newEnvWith c l m = Env l mempty m <$> getAuth c l m

gogol/src/Network/Google/Internal/HTTP.hs+9−1

@@ -27,6 +27,7 @@ import qualified Data.Text.Lazy.Builder as Build

2727import GHC.Exts (toList)

2828import Network.Google.Auth

2929import Network.Google.Env (Env (..))

30+import Network.Google.Internal.Logger

3031import Network.Google.Internal.Multipart

3132import Network.Google.Types

3233import qualified Network.HTTP.Client.Conduit as Client

@@ -56,9 +57,16 @@ perform Env{..} x = catches go handlers

5657

5758 go = liftResourceT $ do

5859 (ct, b) <- getContent _rqBody

59− rq <- authorise _envManager (request ct b) _envAuth

60+ rq <- authorise _envLogger _envManager (request ct b) _envAuth

61+

62+ logDebug _envLogger rq -- debug:ClientRequest

63+

6064 rs <- http rq _envManager

65+

66+ logDebug _envLogger rs -- debug:ClientResponse

67+

6168 r <- _cliResponse (responseBody rs)

69+

6270 pure $! case r of

6371 Right y -> Right y

6472 Left e -> Left . SerializeError $ SerializeError'

gogol/src/Network/Google/Internal/Logger.hsnew file+201

@@ -0,0 +1,201 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE RecordWildCards #-}

6+{-# LANGUAGE ViewPatterns #-}

8+-- |

9+-- Module : Network.Google.Internal.Logger

11+-- License : Mozilla Public License, v. 2.0.

12+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>

13+-- Stability : provisional

14+-- Portability : non-portable (GHC extensions)

15+--

16+-- Types and functions for constructing loggers and emitting log messages.

17+module Network.Google.Internal.Logger

18+ (

19+ -- * Constructing a Logger

20+ Logger

21+ , newLogger

22+

23+ -- * Levels

24+ , LogLevel (..)

25+ , logError

26+ , logInfo

27+ , logDebug

28+

29+ -- * Building Messages

30+ , ToLog (..)

31+ , buildLines

32+ ) where

33+

34+import Control.Monad

35+import Control.Monad.IO.Class

36+import Data.ByteString (ByteString)

37+import qualified Data.ByteString as BS

38+import Data.ByteString.Builder (Builder)

39+import qualified Data.ByteString.Char8 as BS8

40+import qualified Data.ByteString.Lazy as LBS

41+import qualified Data.ByteString.Lazy.Builder as Build

42+import Data.CaseInsensitive (CI)

43+import qualified Data.CaseInsensitive as CI

44+import Data.Int

45+import Data.List (intersperse)

46+import Data.Monoid

47+import qualified Data.Text as Text

48+import qualified Data.Text.Encoding as Text

49+import qualified Data.Text.Lazy as LText

50+import qualified Data.Text.Lazy.Encoding as LText

51+import Data.Word

52+import Network.Google.Prelude hiding (Header, Request)

53+import Network.Google.Types hiding (Request)

54+import Network.HTTP.Conduit

55+import Network.HTTP.Types

56+import Numeric

57+import System.IO

58+

59+-- | A function threaded through various request and serialisation routines

60+-- to log informational and debug messages.

61+type Logger = LogLevel -> Builder -> IO ()

62+

63+data LogLevel

64+ = Info -- ^ Info messages supplied by the user - this level is not emitted by the library.

65+ | Error -- ^ Error messages only.

66+ | Debug -- ^ Useful debug information + info + error levels.

67+ deriving (Eq, Ord, Enum, Show, Data, Typeable)

68+

69+instance FromText LogLevel where

70+ fromText (Text.toLower -> t) =

71+ case t of

72+ "info" -> Just Info

73+ "error" -> Just Error

74+ "debug" -> Just Debug

75+ _ -> Nothing

76+

77+instance ToText LogLevel where

78+ toText = \case

79+ Info -> "info"

80+ Error -> "error"

81+ Debug -> "debug"

82+

83+-- | This is a primitive logger which can be used to log builds to a 'Handle'.

84+--

85+-- /Note:/ A more sophisticated logging library such as

86+-- <http://hackage.haskell.org/package/tinylog tinylog> or

87+-- <http://hackage.haskell.org/package/FastLogger fast-logger>

88+-- should be used in production code.

89+newLogger :: MonadIO m => LogLevel -> Handle -> m Logger

90+newLogger x hd = liftIO $ do

91+ hSetBinaryMode hd True

92+ hSetBuffering hd LineBuffering

93+ return $ \y b ->

94+ when (x >= y) $

95+ Build.hPutBuilder hd (b <> "\n")

96+

97+logError, logInfo, logDebug :: (MonadIO m, ToLog a) => Logger -> a -> m ()

98+logError f = liftIO . f Error . build

99+logInfo f = liftIO . f Info . build

100+logDebug f = liftIO . f Debug . build

101+

102+class ToLog a where

103+ -- | Convert a value to a loggable builder.

104+ build :: a -> Builder

105+

106+instance ToLog Builder where build = id

107+instance ToLog LBS.ByteString where build = Build.lazyByteString

108+instance ToLog ByteString where build = Build.byteString

109+instance ToLog Int where build = Build.intDec

110+instance ToLog Int8 where build = Build.int8Dec

111+instance ToLog Int16 where build = Build.int16Dec

112+instance ToLog Int32 where build = Build.int32Dec

113+instance ToLog Int64 where build = Build.int64Dec

114+instance ToLog Integer where build = Build.integerDec

115+instance ToLog Word where build = Build.wordDec

116+instance ToLog Word8 where build = Build.word8Dec

117+instance ToLog Word16 where build = Build.word16Dec

118+instance ToLog Word32 where build = Build.word32Dec

119+instance ToLog Word64 where build = Build.word64Dec

120+instance ToLog UTCTime where build = Build.stringUtf8 . show

121+instance ToLog Float where build = build . ($ "") . showFFloat Nothing

122+instance ToLog Double where build = build . ($ "") . showFFloat Nothing

123+instance ToLog Text where build = build . Text.encodeUtf8

124+instance ToLog LText.Text where build = build . LText.encodeUtf8

125+instance ToLog Char where build = build . BS8.singleton

126+instance ToLog [Char] where build = build . BS8.pack

127+-- instance ToLog StdMethod where build = build . renderStdMethod

128+

129+-- | Intercalate a list of 'Builder's with newlines.

130+buildLines :: [Builder] -> Builder

131+buildLines = mconcat . intersperse "\n"

132+

133+instance ToLog a => ToLog (CI a) where

134+ build = build . CI.foldedCase

135+

136+instance ToLog a => ToLog (Maybe a) where

137+ build Nothing = "Nothing"

138+ build (Just x) = "Just " <> build x

139+

140+instance ToLog Bool where

141+ build True = "True"

142+ build False = "False"

143+

144+instance ToLog Status where

145+ build x = build (statusCode x) <> " " <> build (statusMessage x)

146+

147+instance ToLog [Header] where

148+ build = mconcat

149+ . intersperse "; "

150+ . map (\(k, v) -> build k <> ": " <> build v)

151+

152+instance ToLog HttpVersion where

153+ build HttpVersion{..} =

154+ "HTTP/"

155+ <> build httpMajor

156+ <> build '.'

157+ <> build httpMinor

158+

159+instance ToLog RequestBody where

160+ build = \case

161+ RequestBodyBuilder n _ -> " <msger:" <> build n <> ">"

162+ RequestBodyStream n _ -> " <stream:" <> build n <> ">"

163+ RequestBodyStreamChunked _ -> " <chunked>"

164+

165+ RequestBodyLBS lbs

166+ | n <= 4096 -> build lbs

167+ | otherwise -> " <lazy:" <> build n <> ">"

168+ where

169+ n = LBS.length lbs

170+

171+ RequestBodyBS bs

172+ | n <= 4096 -> build bs

173+ | otherwise -> " <strict:" <> build n <> ">"

174+ where

175+ n = BS.length bs

176+

177+instance ToLog HttpException where

178+ build x = "[HttpException] {\n" <> build (show x) <> "\n}"

179+

180+instance ToLog Request where

181+ build x = buildLines

182+ [ "[Client Request] {"

183+ , " host = " <> build (host x) <> ":" <> build (port x)

184+ , " secure = " <> build (secure x)

185+ , " method = " <> build (method x)

186+ , " timeout = " <> build (responseTimeout x)

187+ , " redirects = " <> build (redirectCount x)

188+ , " path = " <> build (path x)

189+ , " query = " <> build (queryString x)

190+ , " headers = " <> build (requestHeaders x)

191+ , " body = " <> build (requestBody x)

192+ , "}"

193+ ]

194+

195+instance ToLog (Response a) where

196+ build x = buildLines

197+ [ "[Client Response] {"

198+ , " status = " <> build (responseStatus x)

199+ , " headers = " <> build (responseHeaders x)

200+ , "}"

201+ ]