module Network.OAuth.Stateful
(
OAuth, runOAuth,
OAuthT, runOAuthT, runOAuthT',
oauth, sign, newParams,
withGen, withManager, withCred, getServer, getCredentials,
)
where
import Control.Applicative
import Control.Monad.Catch
import Control.Monad.State
import Crypto.Random
import Network.HTTP.Client.Types (Request)
import Network.OAuth.MuLens
import qualified Network.OAuth.Signing as S
import Network.OAuth.Types.Credentials (Cred, Token, clientCred,
clientToken, resourceToken)
import Network.OAuth.Types.Params (Server (..))
import qualified Network.OAuth.Types.Params as P
import Network.HTTP.Client.Manager (Manager, ManagerSettings, closeManager,
defaultManagerSettings, newManager)
newtype OAuthT ty m a =
OAuthT { unOAuthT :: StateT (OAuthConfig ty) m a }
deriving ( Functor, Applicative, Monad, MonadIO )
type OAuth ty a = OAuthT ty IO a
instance MonadTrans (OAuthT ty) where
lift = OAuthT . lift
runOAuth :: Cred ty -> Server -> OAuth ty a -> IO a
runOAuth = runOAuthT
runOAuthT :: (MonadIO m, MonadCatch m) => Cred ty -> Server -> OAuthT ty m a -> m a
runOAuthT = runOAuthT' defaultManagerSettings
runOAuthT' :: (MonadIO m, MonadCatch m) => ManagerSettings -> Cred ty -> Server -> OAuthT ty m a -> m a
runOAuthT' settings creds srv m = do
pool <- liftIO createEntropyPool
bracket (liftIO $ newManager settings) (liftIO . closeManager) $ \man ->
let conf = OAuthConfig man (cprgCreate pool) srv creds
in evalStateT (unOAuthT m) conf
oauth :: MonadIO m => Request -> OAuthT ty m Request
oauth req = newParams >>= flip sign req
withGen :: Monad m => (SystemRNG -> m (a, SystemRNG)) -> OAuthT ty m a
withGen = OAuthT . zoom crng . StateT
withManager :: Monad m => (Manager -> m a) -> OAuthT ty m a
withManager f = OAuthT $ zoom manager (get >>= lift . f)
newParams :: MonadIO m => OAuthT ty m (P.Oa ty)
newParams = do
px <- withGen (liftIO . P.freshPin)
c <- OAuthT $ use credentials
return P.Oa { P.credentials = c
, P.workflow = P.Standard
, P.pin = px
}
sign :: Monad m => P.Oa ty -> Request -> OAuthT ty m Request
sign oax req = do
s <- OAuthT $ use server
return (S.sign oax s req)
withCred :: Monad m => Cred ty -> OAuthT ty m a -> OAuthT ty' m a
withCred c op = OAuthT $ do
s <- get
lift $ evalStateT (unOAuthT op) (s & credentials .~ c)
data OAuthConfig ty =
OAuthConfig !Manager
!SystemRNG
!Server
!(Cred ty)
getServer :: Monad m => OAuthT ty m Server
getServer = OAuthT (use server)
getCredentials :: Monad m => OAuthT ty m (Cred ty)
getCredentials = OAuthT (use credentials)
manager :: Lens (OAuthConfig ty) (OAuthConfig ty) Manager Manager
manager inj (OAuthConfig m rng sv c) = (\m' -> OAuthConfig m' rng sv c) <$> inj m
crng :: Lens (OAuthConfig ty) (OAuthConfig ty) SystemRNG SystemRNG
crng inj (OAuthConfig m rng sv c) = (\rng' -> OAuthConfig m rng' sv c) <$> inj rng
server :: Lens (OAuthConfig ty) (OAuthConfig ty) Server Server
server inj (OAuthConfig m rng sv c) = (\sv' -> OAuthConfig m rng sv' c) <$> inj sv
credentials :: Lens (OAuthConfig ty) (OAuthConfig ty') (Cred ty) (Cred ty')
credentials inj (OAuthConfig m rng sv c) = OAuthConfig m rng sv <$> inj c