module Network.OAuth.Simple (
oauth, runOAuthSimple,
runOAuth, runOAuthT, OAuthT (..), OAuth,
upgradeCred, upgrade,
O.Token (..), O.Cred, O.Client, O.Temporary, O.Permanent,
O.clientCred, O.temporaryCred, O.permanentCred,
O.fromUrlEncoded,
O.Server (..), O.defaultServer,
O.ParameterMethod (..), O.SignatureMethod (..), O.Version (..),
O.ThreeLegged (..), O.parseThreeLegged, O.Callback (..),
O.Verifier,
requestTemporaryToken, buildAuthorizationUrl, requestPermanentToken,
requestTokenProtocol, TokenRequestFailure (..)
) where
import Control.Applicative
import qualified Control.Monad.Catch as E
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Either
import qualified Crypto.Random as R
import qualified Data.ByteString.Lazy as SL
import qualified Network.HTTP.Client as C
import qualified Network.OAuth as O
import qualified Network.OAuth.ThreeLegged as O
import qualified Network.OAuth.Types.Credentials as Cred
import Network.URI (URI)
data OaConfig ty =
OaConfig { cred :: O.Cred ty
, server :: O.Server
, threeLegged :: O.ThreeLegged
}
newtype OAuthT ty m a =
OAuthT { unOAuthT :: ReaderT (OaConfig ty) (StateT R.SystemRNG m) a }
deriving ( Functor, Applicative, Monad
, MonadReader (OaConfig ty)
, MonadState R.SystemRNG
, E.MonadCatch
, E.MonadThrow
, MonadIO
)
instance MonadTrans (OAuthT ty) where lift = OAuthT . lift . lift
type OAuth ty = OAuthT ty IO
runOAuthT
:: (MonadIO m) =>
OAuthT ty m a -> O.Cred ty -> O.Server -> O.ThreeLegged ->
m a
runOAuthT oat cr srv tl = do
entropy <- liftIO R.createEntropyPool
evalStateT (runReaderT (unOAuthT oat) (OaConfig cr srv tl)) (R.cprgCreate entropy)
runOAuth :: OAuth ty a -> O.Cred ty -> O.Server -> O.ThreeLegged -> IO a
runOAuth = runOAuthT
runOAuthSimple :: OAuth ty a -> O.Cred ty -> IO a
runOAuthSimple oat cr = runOAuth oat cr O.defaultServer tl where
Just tl = O.parseThreeLegged "http://example.com"
"http://example.com"
"http://example.com"
O.OutOfBand
upgradeCred :: (Cred.ResourceToken ty', Monad m) => O.Token ty' -> OAuthT ty m (O.Cred ty')
upgradeCred tok = liftM (Cred.upgradeCred tok . cred) ask
upgrade :: (Cred.ResourceToken ty', Monad m) => O.Token ty' -> OAuthT ty' m a -> OAuthT ty m a
upgrade tok oat = do
gen <- state R.cprgFork
conf <- ask
let conf' = conf { cred = Cred.upgradeCred tok (cred conf) }
lift $ evalStateT (runReaderT (unOAuthT oat) conf') gen
liftBasic :: MonadIO m => (R.SystemRNG -> OaConfig ty -> IO (a, R.SystemRNG)) -> OAuthT ty m a
liftBasic f = do
gen <- get
conf <- ask
(a, gen') <- liftIO (f gen conf)
put gen'
return a
oauth :: MonadIO m => C.Request -> OAuthT ty m C.Request
oauth req = liftBasic $ \gen conf -> O.oauth (cred conf) (server conf) req gen
requestTemporaryToken
:: MonadIO m => C.Manager ->
OAuthT O.Client m (C.Response (Either SL.ByteString (O.Token O.Temporary)))
requestTemporaryToken man =
liftBasic $ \gen conf ->
O.requestTemporaryToken (cred conf)
(server conf)
(threeLegged conf)
man
gen
buildAuthorizationUrl :: Monad m => OAuthT O.Temporary m URI
buildAuthorizationUrl = do
conf <- ask
return $ O.buildAuthorizationUrl (cred conf) (threeLegged conf)
requestPermanentToken
:: MonadIO m => C.Manager -> O.Verifier ->
OAuthT O.Temporary m (C.Response (Either SL.ByteString (O.Token O.Permanent)))
requestPermanentToken man ver =
liftBasic $ \gen conf ->
O.requestPermanentToken (cred conf)
(server conf)
ver
(threeLegged conf)
man
gen
data TokenRequestFailure =
OnTemporaryRequest C.HttpException
| BadTemporaryToken SL.ByteString
| OnPermanentRequest C.HttpException
| BadPermanentToken SL.ByteString
deriving ( Show )
requestTokenProtocol
:: (Functor m, MonadIO m, E.MonadCatch m) =>
C.Manager -> (URI -> m O.Verifier) ->
OAuthT O.Client m (Either TokenRequestFailure (O.Cred O.Permanent))
requestTokenProtocol man getVerifier = runEitherT $ do
tempResp <- liftE OnTemporaryRequest $ E.try (requestTemporaryToken man)
ttok <- upE BadTemporaryToken $ C.responseBody tempResp
upgradeE ttok $ do
verifier <- lift $ buildAuthorizationUrl >>= lift . getVerifier
permResp <- liftE OnPermanentRequest $ E.try (requestPermanentToken man verifier)
ptok <- upE BadPermanentToken $ C.responseBody permResp
lift $ upgradeCred ptok
where
mapE :: Functor m => (e -> f) -> EitherT e m b -> EitherT f m b
mapE f = bimapEitherT f id
liftE :: Functor m => (e -> f) -> m (Either e b) -> EitherT f m b
liftE f = mapE f . EitherT
upE :: (Monad m, Functor m) => (e -> f) -> Either e b -> EitherT f m b
upE f = liftE f . return
upgradeE :: (Monad m, Cred.ResourceToken ty') =>
Cred.Token ty'
-> EitherT e (OAuthT ty' m) a -> EitherT e (OAuthT ty m) a
upgradeE tok = EitherT . upgrade tok . runEitherT