git.iko.soy/gogol
on develop help sign in
Expanding basic credentials specification mechanisms
8ac8825Brendan Hay
gogol/gogol.cabal+16−3
compare with develop
unifiedsplit
@@ -27,10 +27,23 @@ library
27 ghc-options: -Wall
27 ghc-options: -Wall
28
28
29 exposed-modules:
29 exposed-modules:
30+ Network.Google
31+ Network.Google.Auth
30− Network.Google
32+ Network.Google.Env
31
33
32 other-modules:
34 other-modules:
35+ Network.Google.Internal.Types
33
36
34 build-depends:
37 build-depends:
35− base >= 4.7 && < 5
38+ base >= 4.7 && < 5
39+ , exceptions
36− , gogol-core == 0.0.1.*
40+ , gogol-core == 0.0.1.*
41+ , http-conduit
42+ , lens
43+ , monad-control
44+ , mtl
45+ , resourcet
46+ , retry
47+ , time
48+ , transformers
49+ , transformers-base
gogol/src/Network/Google.hs+94−1
@@ -1,3 +1,11 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+
1-- |
9-- |
2-- Module : Network.Google
10-- Module : Network.Google
3-- Copyright : (c) 2015 Brendan Hay
11-- Copyright : (c) 2015 Brendan Hay
@@ -8,4 +16,89 @@
8--
16--
9module Network.Google where
17module Network.Google where
10
18
19+import Control.Applicative
20+import Control.Monad
21+import Control.Monad.Base
22+import Control.Monad.Catch
23+import Control.Monad.IO.Class (MonadIO)
24+import Control.Monad.Reader
25+import qualified Control.Monad.RWS.Lazy as LRW
26+import qualified Control.Monad.RWS.Strict as RW
27+import qualified Control.Monad.State.Lazy as LS
28+import qualified Control.Monad.State.Strict as S
29+import Control.Monad.Trans.Class (lift)
30+import Control.Monad.Trans.Control
31+import Control.Monad.Trans.Except (ExceptT)
32+import Control.Monad.Trans.Identity (IdentityT)
33+import Control.Monad.Trans.List (ListT)
34+import Control.Monad.Trans.Maybe (MaybeT)
35+import Control.Monad.Trans.Resource
36+import qualified Control.Monad.Writer.Lazy as LW
37+import qualified Control.Monad.Writer.Strict as W
38+import Network.Google.Auth
39+import Network.Google.Env
11−import Network.Google.Prelude ()
40+import Network.Google.Prelude
41+
42+newtype Google a = Google { unGoogle :: ReaderT Env (ResourceT IO) a }
43+ deriving
44+ ( Functor
45+ , Applicative
46+ , Alternative
47+ , Monad
48+ , MonadPlus
49+ , MonadIO
50+ , MonadThrow
51+ , MonadCatch
52+ , MonadMask
53+ , MonadBase IO
54+ , MonadReader Env
55+ , MonadResource
56+ )
57+
58+instance MonadBaseControl IO Google where
59+ type StM Google a = StM (ReaderT Env (ResourceT IO)) a
60+
61+ liftBaseWith f = Google . liftBaseWith $ \g -> f (g . unGoogle)
62+ restoreM = Google . restoreM
63+
64+-- | Monads in which 'Google' actions may be embedded.
65+class ( Functor m
66+ , Applicative m
67+ , Monad m
68+ , MonadIO m
69+ , MonadCatch m
70+ ) => MonadGoogle m where
71+ -- | Lift a computation to the 'Google' monad.
72+ liftGoogle :: Google a -> m a
73+
74+instance MonadGoogle Google where
75+ liftGoogle = id
76+
77+instance MonadGoogle m => MonadGoogle (IdentityT m) where liftGoogle = lift . liftGoogle
78+instance MonadGoogle m => MonadGoogle (ListT m) where liftGoogle = lift . liftGoogle
79+instance MonadGoogle m => MonadGoogle (MaybeT m) where liftGoogle = lift . liftGoogle
80+instance MonadGoogle m => MonadGoogle (ExceptT e m) where liftGoogle = lift . liftGoogle
81+instance MonadGoogle m => MonadGoogle (ReaderT r m) where liftGoogle = lift . liftGoogle
82+instance MonadGoogle m => MonadGoogle (S.StateT s m) where liftGoogle = lift . liftGoogle
83+instance MonadGoogle m => MonadGoogle (LS.StateT s m) where liftGoogle = lift . liftGoogle
84+
85+instance (Monoid w, MonadGoogle m) => MonadGoogle (W.WriterT w m) where
86+ liftGoogle = lift . liftGoogle
87+
88+instance (Monoid w, MonadGoogle m) => MonadGoogle (LW.WriterT w m) where
89+ liftGoogle = lift . liftGoogle
90+
91+instance (Monoid w, MonadGoogle m) => MonadGoogle (RW.RWST r w s m) where
92+ liftGoogle = lift . liftGoogle
93+
94+instance (Monoid w, MonadGoogle m) => MonadGoogle (LRW.RWST r w s m) where
95+ liftGoogle = lift . liftGoogle
96+
97+runGoogle :: MonadResource m => Env -> Google a -> m a
98+runGoogle e m = liftResourceT $ runReaderT (unGoogle m) e -- (e ^. environment)
99+
100+send :: GoogleRequest a => a -> m (Rs a)
101+send = undefined
102+
103+download :: GoogleRequest (MediaDownload a) => a -> m (Rs (MediaDownload a))
104+download = send . MediaDownload
gogol/src/Network/Google/Auth.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE LambdaCase #-}
2+
3+-- |
4+-- Module : Network.Google.Auth
5+-- Copyright : (c) 2015 Brendan Hay
6+-- License : Mozilla Public License, v. 2.0.
7+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
8+-- Stability : provisional
9+-- Portability : non-portable (GHC extensions)
10+--
11+-- Explicitly specify your Google credentials, or retrieve them
12+-- from the underlying OS.
13+module Network.Google.Auth where
14+
15+import Control.Concurrent (ThreadId)
16+import Control.Monad.IO.Class
17+import Data.IORef
18+import Data.Time
19+import Network.Google.Types
20+
21+data Credentials
22+ = FromKey AuthKey
23+ | FromToken OAuthToken
24+ deriving (Eq)
25+
26+-- | The authorisation environment.
27+data AuthEnv = AuthEnv
28+ { _authCreds :: Either AuthKey OAuthToken
29+ , _authExpiry :: Maybe UTCTime
30+ }
31+
32+-- | An authorisation environment containing Google credentials, and potentially
33+-- a reference which can be refreshed out-of-band as credentials expire.
34+data Auth
35+ = Ref ThreadId (IORef AuthEnv)
36+ | Auth AuthEnv
37+
38+withAuth :: MonadIO m => Auth -> (AuthEnv -> m a) -> m a
39+withAuth (Ref _ r) f = liftIO (readIORef r) >>= f
40+withAuth (Auth e) f = f e
41+
42+-- | Retrieve authentication information via the specified 'Credentials' mechanism.
43+getAuth :: Monad m => Credentials -> m Auth
44+getAuth = \case
45+ FromKey k -> pure $! Auth (AuthEnv (Left k) Nothing)
46+ FromToken t -> pure $! Auth (AuthEnv (Right t) Nothing)
gogol/src/Network/Google/Env.hsnew file+98
@@ -0,0 +1,98 @@
1+-- |
2+-- Module : Network.Google.Env
3+-- Copyright : (c) 2015 Brendan Hay
4+-- License : Mozilla Public License, v. 2.0.
5+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
6+-- Stability : provisional
7+-- Portability : non-portable (GHC extensions)
8+--
9+-- Environment and Google specific configuration for the 'Network.Google' monad.
10+module Network.Google.Env where
11+
12+import Control.Applicative
13+import Control.Lens
14+import Control.Monad
15+import Control.Monad.Catch
16+import Control.Monad.IO.Class
17+import Control.Monad.Reader
18+import Control.Retry
19+import Data.Monoid
20+import Network.Google.Auth
21+import Network.Google.Internal.Types
22+import Network.Google.Types
23+import Network.HTTP.Conduit
24+
25+-- | The environment containing the parameters required to make Google requests.
26+data Env = Env
27+ { _envRetryCheck :: !(Int -> HttpException -> Bool)
28+ , _envRetryPolicy :: !RetryPolicy
29+ , _envTimeout :: !(Maybe Seconds)
30+ , _envManager :: !Manager
31+ , _envAuth :: !Auth
32+ }
33+
34+-- Note: The strictness annotations aobe are applied to ensure
35+-- total field initialisation.
36+
37+class HasEnv a where
38+ environment :: Lens' a Env
39+ {-# MINIMAL environment #-}
40+
41+ -- | The function used to determine if an 'HttpException' should be retried.
42+ envRetryCheck :: Lens' a (Int -> HttpException -> Bool)
43+
44+ -- | TODO
45+ envRetryPolicy :: Lens' a RetryPolicy
46+
47+ -- | TODO
48+ envTimeout :: Lens' a (Maybe Seconds)
49+
50+ -- | The 'Manager' used to create and manage open HTTP connections.
51+ envManager :: Lens' a Manager
52+
53+ -- | The credentials used to sign requests for authentication with Google.
54+ envAuth :: Lens' a Auth
55+
56+ envRetryCheck = environment . lens _envRetryCheck (\s a -> s { _envRetryCheck = a })
57+ envRetryPolicy = environment . lens _envRetryPolicy (\s a -> s { _envRetryPolicy = a })
58+ envTimeout = environment . lens _envTimeout (\s a -> s { _envTimeout = a })
59+ envManager = environment . lens _envManager (\s a -> s { _envManager = a })
60+ envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })
61+
62+instance HasEnv Env where
63+ environment = id
64+
65+-- | Scope an action such that any retry logic for the 'Env' is
66+-- ignored and any requests will at most be sent once.
67+once :: (MonadReader r m, HasEnv r) => m a -> m a
68+once = policy (limitRetries 0)
69+
70+-- | TODO
71+policy :: (MonadReader r m, HasEnv r) => RetryPolicy -> m a -> m a
72+policy r = local (envRetryPolicy <>~ r)
73+
74+-- | Scope an action such that any HTTP response will use this timeout value.
75+--
76+-- Default timeouts are chosen by considering:
77+--
78+-- * This 'timeout', if set.
79+--
80+-- * The 'envManager' timeout if set.
81+--
82+-- * The default 'ClientRequest' timeout. (Approximately 30s)
83+timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a
84+timeout s = local (envTimeout ?~ s)
85+
86+-- | Creates a new environment with a new 'Manager' without debug logging
87+-- and uses 'getAuth' to expand/discover the supplied 'Credentials'.
88+-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.
89+--
90+-- /See:/ 'newEnvWith'.
91+newEnv :: (MonadIO m, MonadCatch m) => Credentials -> m Env
92+newEnv c = liftIO (newManager conduitManagerSettings) >>= newEnvWith c
93+
94+-- | /See:/ 'newEnv'
95+newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Manager -> m Env
96+newEnvWith c m = Env check mempty Nothing m <$> getAuth c
97+ where
98+ check _ _ = True
gogol/src/Network/Google/Internal/Types.hsnew file+41
@@ -0,0 +1,41 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
5+-- |
6+-- Module : Network.Google.Env
7+-- Copyright : (c) 2015 Brendan Hay
8+-- License : Mozilla Public License, v. 2.0.
9+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
10+-- Stability : provisional
11+-- Portability : non-portable (GHC extensions)
12+--
13+module Network.Google.Internal.Types where
14+
15+import Data.Data
16+import GHC.Generics
17+
18+-- | An integral value representing seconds.
19+newtype Seconds = Seconds Int
20+ deriving
21+ ( Eq
22+ , Ord
23+ , Read
24+ , Show
25+ , Enum
26+ , Num
27+ , Bounded
28+ , Integral
29+ , Real
30+ , Data
31+ , Typeable
32+ , Generic
33+ )
34+
35+seconds :: Seconds -> Int
36+seconds (Seconds n)
37+ | n < 0 = 0
38+ | otherwise = n
39+
40+microseconds :: Seconds -> Int
41+microseconds = (1000000 *) . seconds