{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}

-- |
-- Module      : Network.OAuth.ThreeLegged
-- Copyright   : (c) Joseph Abrahamson 2013
-- License     : MIT
--
-- Maintainer  : me@jspha.com
-- Stability   : experimental
-- Portability : non-portable
--
-- The \"Three-legged OAuth\" protocol implementing RFC 5849's
-- /Redirection-Based Authorization/.

module Network.OAuth.ThreeLegged (
  -- * Configuration types
  ThreeLegged (..), parseThreeLegged, P.Callback (..),

  P.Verifier,

  -- * Actions
  requestTemporaryToken, buildAuthorizationUrl, requestPermanentToken,

  -- ** Raw forms
  requestTemporaryTokenRaw, requestPermanentTokenRaw,

  -- * Example system
  requestTokenProtocol, requestTokenProtocol'
  ) where

import           Control.Monad.IO.Class          (MonadIO, liftIO)
import           Crypto.Random                   (MonadRandom)
import qualified Data.ByteString.Lazy            as SL
import           Data.Data
import qualified Network.HTTP.Client             as C
import           Network.HTTP.Types              (renderQuery)
import qualified Network.OAuth                   as O
import           Network.OAuth.MuLens
import qualified Network.OAuth.Types.Credentials as Cred
import qualified Network.OAuth.Types.Params      as P
import           Network.URI

-- | Data parameterizing the \"Three-legged OAuth\" redirection-based
-- authorization protocol. These parameters cover the protocol as described
-- in the community editions /OAuth Core 1.0/ and /OAuth Core 1.0a/ as well
-- as RFC 5849.
data ThreeLegged =
  ThreeLegged { ThreeLegged -> Request
temporaryTokenRequest      :: C.Request
              -- ^ Base 'Request' for the \"endpoint used by the client to
              -- obtain a set of 'Temporary' 'Cred'entials\" in the form of
              -- a 'Temporary' 'Token'. This request is automatically
              -- instantiated and performed during the first leg of the
              -- 'ThreeLegged' authorization protocol.
              , ThreeLegged -> Request
resourceOwnerAuthorization :: C.Request
              -- ^ Base 'Request' for the \"endpoint to which the resource
              -- owner is redirected to grant authorization\". This request
              -- must be performed by the user granting token authorization
              -- to the client. Transmitting the parameters of this request
              -- to the user is out of scope of @oauthenticated@, but
              -- functions are provided to make it easier.
              , ThreeLegged -> Request
permanentTokenRequest      :: C.Request
              -- ^ Base 'Request' for the \"endpoint used by the client to
              -- request a set of token credentials using the set of
              -- 'Temporary' 'Cred'entials\". This request is also
              -- instantiated and performed by @oauthenticated@ in order to
              -- produce a 'Permanent' 'Token'.
              , ThreeLegged -> Callback
callback                   :: P.Callback
              -- ^ The 'Callback' parameter configures how the user is
              -- intended to communicate the 'Verifier' back to the client.
              }
    deriving ( Int -> ThreeLegged -> ShowS
[ThreeLegged] -> ShowS
ThreeLegged -> String
(Int -> ThreeLegged -> ShowS)
-> (ThreeLegged -> String)
-> ([ThreeLegged] -> ShowS)
-> Show ThreeLegged
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreeLegged] -> ShowS
$cshowList :: [ThreeLegged] -> ShowS
show :: ThreeLegged -> String
$cshow :: ThreeLegged -> String
showsPrec :: Int -> ThreeLegged -> ShowS
$cshowsPrec :: Int -> ThreeLegged -> ShowS
Show, Typeable )

-- | Convenience method for creating a 'ThreeLegged' configuration from
-- a trio of URLs and a 'Callback'. Returns 'Nothing' if one of the
-- callback URLs could not be parsed correctly.
parseThreeLegged :: String -> String -> String -> P.Callback -> Maybe ThreeLegged
parseThreeLegged :: String -> String -> String -> Callback -> Maybe ThreeLegged
parseThreeLegged String
a String
b String
c Callback
d =
  Request -> Request -> Request -> Callback -> ThreeLegged
ThreeLegged (Request -> Request -> Request -> Callback -> ThreeLegged)
-> Maybe Request
-> Maybe (Request -> Request -> Callback -> ThreeLegged)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
C.parseRequest String
a
              Maybe (Request -> Request -> Callback -> ThreeLegged)
-> Maybe Request -> Maybe (Request -> Callback -> ThreeLegged)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
C.parseRequest String
b
              Maybe (Request -> Callback -> ThreeLegged)
-> Maybe Request -> Maybe (Callback -> ThreeLegged)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
C.parseRequest String
c
              Maybe (Callback -> ThreeLegged)
-> Maybe Callback -> Maybe ThreeLegged
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Callback -> Maybe Callback
forall (f :: * -> *) a. Applicative f => a -> f a
pure Callback
d

-- | Request a 'Temporary' 'Token' based on the parameters of
-- a 'ThreeLegged' protocol. This returns the raw response which should be
-- encoded as @www-form-urlencoded@.
--
-- Throws 'C.HttpException's.
requestTemporaryTokenRaw
  :: (MonadIO m, MonadRandom m) => O.Cred O.Client -> O.Server
                                -> ThreeLegged -> C.Manager
                                -> m(C.Response SL.ByteString)
requestTemporaryTokenRaw :: Cred Client
-> Server -> ThreeLegged -> Manager -> m (Response ByteString)
requestTemporaryTokenRaw Cred Client
cr Server
srv (ThreeLegged {Request
Callback
callback :: Callback
permanentTokenRequest :: Request
resourceOwnerAuthorization :: Request
temporaryTokenRequest :: Request
callback :: ThreeLegged -> Callback
permanentTokenRequest :: ThreeLegged -> Request
resourceOwnerAuthorization :: ThreeLegged -> Request
temporaryTokenRequest :: ThreeLegged -> Request
..}) Manager
man = do
  Oa Client
oax <- Cred Client -> m (Oa Client)
forall (m :: * -> *) ty.
(MonadRandom m, MonadIO m) =>
Cred ty -> m (Oa ty)
O.freshOa Cred Client
cr
  let req :: Request
req = Oa Client -> Server -> Request -> Request
forall ty. Oa ty -> Server -> Request -> Request
O.sign (Oa Client
oax { workflow :: Workflow
P.workflow = Callback -> Workflow
P.TemporaryTokenRequest Callback
callback }) Server
srv Request
temporaryTokenRequest
  IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
C.httpLbs Request
req Manager
man

-- | Returns the raw result if the 'C.Response' could not be parsed as
-- a valid 'O.Token'.  Importantly, in RFC 5849 compliant modes this
-- requires that the token response includes @callback_confirmed=true@. See
-- also 'requestTemporaryTokenRaw'.
--
-- Throws 'C.HttpException's.
requestTemporaryToken
  :: (MonadIO m, MonadRandom m) => O.Cred O.Client -> O.Server
                                -> ThreeLegged -> C.Manager
                                -> m (C.Response (Either SL.ByteString (O.Token O.Temporary)))
requestTemporaryToken :: Cred Client
-> Server
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Temporary)))
requestTemporaryToken Cred Client
cr Server
srv ThreeLegged
tl Manager
man = do
  Response ByteString
raw <- Cred Client
-> Server -> ThreeLegged -> Manager -> m (Response ByteString)
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
Cred Client
-> Server -> ThreeLegged -> Manager -> m (Response ByteString)
requestTemporaryTokenRaw Cred Client
cr Server
srv ThreeLegged
tl Manager
man
  Response (Either ByteString (Token Temporary))
-> m (Response (Either ByteString (Token Temporary)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Response (Either ByteString (Token Temporary))
 -> m (Response (Either ByteString (Token Temporary))))
-> Response (Either ByteString (Token Temporary))
-> m (Response (Either ByteString (Token Temporary)))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString (Token Temporary)
forall ty. ByteString -> Either ByteString (Token ty)
tryParseToken (ByteString -> Either ByteString (Token Temporary))
-> Response ByteString
-> Response (Either ByteString (Token Temporary))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response ByteString
raw
  where
    tryParseToken :: ByteString -> Either ByteString (Token ty)
tryParseToken ByteString
lbs = case ByteString -> Maybe (Token ty)
forall ty. ByteString -> Maybe (Token ty)
maybeParseToken ByteString
lbs of
      Maybe (Token ty)
Nothing  -> ByteString -> Either ByteString (Token ty)
forall a b. a -> Either a b
Left ByteString
lbs
      Just Token ty
tok -> Token ty -> Either ByteString (Token ty)
forall a b. b -> Either a b
Right Token ty
tok
    maybeParseToken :: ByteString -> Maybe (Token ty)
maybeParseToken ByteString
lbs =
      do (Bool
confirmed, Token ty
tok) <- ByteString -> Maybe (Bool, Token ty)
forall ty. ByteString -> Maybe (Bool, Token ty)
O.fromUrlEncoded (ByteString -> Maybe (Bool, Token ty))
-> ByteString -> Maybe (Bool, Token ty)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
SL.toStrict ByteString
lbs
         case Server -> Version
P.oAuthVersion Server
srv of
           Version
O.OAuthCommunity1 -> Token ty -> Maybe (Token ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Token ty
tok
           Version
_                 -> if Bool
confirmed then Token ty -> Maybe (Token ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Token ty
tok else String -> Maybe (Token ty)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Must be confirmed"

-- | Produce a 'URI' which the user should be directed to in order to
-- authorize a set of 'Temporary' 'Cred's.
buildAuthorizationUrl :: O.Cred O.Temporary -> ThreeLegged -> URI
buildAuthorizationUrl :: Cred Temporary -> ThreeLegged -> URI
buildAuthorizationUrl Cred Temporary
cr (ThreeLegged {Request
Callback
callback :: Callback
permanentTokenRequest :: Request
resourceOwnerAuthorization :: Request
temporaryTokenRequest :: Request
callback :: ThreeLegged -> Callback
permanentTokenRequest :: ThreeLegged -> Request
resourceOwnerAuthorization :: ThreeLegged -> Request
temporaryTokenRequest :: ThreeLegged -> Request
..}) =
  Request -> URI
C.getUri (Request -> URI) -> Request -> URI
forall a b. (a -> b) -> a -> b
$ Request
resourceOwnerAuthorization {
    queryString :: ByteString
C.queryString = Bool -> Query -> ByteString
renderQuery Bool
True [ (ByteString
"oauth_token", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Cred Temporary
cr Cred Temporary
-> ((ByteString -> Constant ByteString ByteString)
    -> Cred Temporary -> Constant ByteString (Cred Temporary))
-> ByteString
forall s a. s -> ((a -> Constant a a) -> s -> Constant a s) -> a
^. (Token Temporary -> Constant ByteString (Token Temporary))
-> Cred Temporary -> Constant ByteString (Cred Temporary)
forall ty ty' (f :: * -> *).
(ResourceToken ty, ResourceToken ty', Functor f) =>
(Token ty -> f (Token ty')) -> Cred ty -> f (Cred ty')
Cred.resourceToken ((Token Temporary -> Constant ByteString (Token Temporary))
 -> Cred Temporary -> Constant ByteString (Cred Temporary))
-> ((ByteString -> Constant ByteString ByteString)
    -> Token Temporary -> Constant ByteString (Token Temporary))
-> (ByteString -> Constant ByteString ByteString)
-> Cred Temporary
-> Constant ByteString (Cred Temporary)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Constant ByteString ByteString)
-> Token Temporary -> Constant ByteString (Token Temporary)
forall (f :: * -> *) ty.
Functor f =>
(ByteString -> f ByteString) -> Token ty -> f (Token ty)
Cred.key)) ]
  }

-- | Request a 'Permanent 'Token' based on the parameters of
-- a 'ThreeLegged' protocol. This returns the raw response which should be
-- encoded as @www-form-urlencoded@.
--
-- Throws 'C.HttpException's.
requestPermanentTokenRaw
  :: (MonadIO m, MonadRandom m) => O.Cred O.Temporary -> O.Server
                                -> P.Verifier
                                -> ThreeLegged -> C.Manager
                                -> m (C.Response SL.ByteString)
requestPermanentTokenRaw :: Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response ByteString)
requestPermanentTokenRaw Cred Temporary
cr Server
srv ByteString
verifier (ThreeLegged {Request
Callback
callback :: Callback
permanentTokenRequest :: Request
resourceOwnerAuthorization :: Request
temporaryTokenRequest :: Request
callback :: ThreeLegged -> Callback
permanentTokenRequest :: ThreeLegged -> Request
resourceOwnerAuthorization :: ThreeLegged -> Request
temporaryTokenRequest :: ThreeLegged -> Request
..}) Manager
man = do
  Oa Temporary
oax <- Cred Temporary -> m (Oa Temporary)
forall (m :: * -> *) ty.
(MonadRandom m, MonadIO m) =>
Cred ty -> m (Oa ty)
O.freshOa Cred Temporary
cr
  let req :: Request
req = Oa Temporary -> Server -> Request -> Request
forall ty. Oa ty -> Server -> Request -> Request
O.sign (Oa Temporary
oax { workflow :: Workflow
P.workflow = ByteString -> Workflow
P.PermanentTokenRequest ByteString
verifier }) Server
srv Request
permanentTokenRequest
  IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
C.httpLbs Request
req Manager
man

-- | Returns 'Nothing' if the response could not be decoded as a 'Token'.
-- See also 'requestPermanentTokenRaw'.
--
-- Throws 'C.HttpException's.
requestPermanentToken
  :: (MonadIO m, MonadRandom m) => O.Cred O.Temporary -> O.Server
                                -> P.Verifier
                                -> ThreeLegged -> C.Manager
                                -> m (C.Response (Either SL.ByteString (O.Token O.Permanent)))
requestPermanentToken :: Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Permanent)))
requestPermanentToken Cred Temporary
cr Server
srv ByteString
verifier ThreeLegged
tl Manager
man = do
  Response ByteString
raw <- Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response ByteString)
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response ByteString)
requestPermanentTokenRaw Cred Temporary
cr Server
srv ByteString
verifier ThreeLegged
tl Manager
man
  Response (Either ByteString (Token Permanent))
-> m (Response (Either ByteString (Token Permanent)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Response (Either ByteString (Token Permanent))
 -> m (Response (Either ByteString (Token Permanent))))
-> Response (Either ByteString (Token Permanent))
-> m (Response (Either ByteString (Token Permanent)))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString (Token Permanent)
forall ty. ByteString -> Either ByteString (Token ty)
tryParseToken (ByteString -> Either ByteString (Token Permanent))
-> Response ByteString
-> Response (Either ByteString (Token Permanent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response ByteString
raw
  where
    tryParseToken :: ByteString -> Either ByteString (Token ty)
tryParseToken ByteString
lbs = case ByteString -> Maybe (Token ty)
forall ty. ByteString -> Maybe (Token ty)
maybeParseToken ByteString
lbs of
      Maybe (Token ty)
Nothing  -> ByteString -> Either ByteString (Token ty)
forall a b. a -> Either a b
Left ByteString
lbs
      Just Token ty
tok -> Token ty -> Either ByteString (Token ty)
forall a b. b -> Either a b
Right Token ty
tok
    maybeParseToken :: ByteString -> Maybe (Token ty)
maybeParseToken = ((Bool, Token ty) -> Token ty)
-> Maybe (Bool, Token ty) -> Maybe (Token ty)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Token ty) -> Token ty
forall a b. (a, b) -> b
snd (Maybe (Bool, Token ty) -> Maybe (Token ty))
-> (ByteString -> Maybe (Bool, Token ty))
-> ByteString
-> Maybe (Token ty)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Bool, Token ty)
forall ty. ByteString -> Maybe (Bool, Token ty)
O.fromUrlEncoded (ByteString -> Maybe (Bool, Token ty))
-> (ByteString -> ByteString)
-> ByteString
-> Maybe (Bool, Token ty)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SL.toStrict

-- | Like 'requestTokenProtocol' but allows for specification of the
-- 'C.ManagerSettings'.
requestTokenProtocol'
  :: (MonadIO m, MonadRandom m) => C.ManagerSettings -> O.Cred O.Client -> O.Server -> ThreeLegged
                                -> (URI -> m P.Verifier)
                                -> m (Maybe (O.Cred O.Permanent))
requestTokenProtocol' :: ManagerSettings
-> Cred Client
-> Server
-> ThreeLegged
-> (URI -> m ByteString)
-> m (Maybe (Cred Permanent))
requestTokenProtocol' ManagerSettings
mset Cred Client
cr Server
srv ThreeLegged
tl URI -> m ByteString
getVerifier = do
  Manager
man <- IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
C.newManager ManagerSettings
mset
  Response (Either ByteString (Token Temporary))
respTempToken <- Cred Client
-> Server
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Temporary)))
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
Cred Client
-> Server
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Temporary)))
requestTemporaryToken Cred Client
cr Server
srv ThreeLegged
tl Manager
man
  case Response (Either ByteString (Token Temporary))
-> Either ByteString (Token Temporary)
forall body. Response body -> body
C.responseBody Response (Either ByteString (Token Temporary))
respTempToken of
    Left ByteString
_ -> Maybe (Cred Permanent) -> m (Maybe (Cred Permanent))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Cred Permanent)
forall a. Maybe a
Nothing
    Right Token Temporary
tok -> do
      let tempCr :: Cred Temporary
tempCr = Token Temporary -> Cred Client -> Cred Temporary
O.temporaryCred Token Temporary
tok Cred Client
cr
      ByteString
verifier <- URI -> m ByteString
getVerifier (URI -> m ByteString) -> URI -> m ByteString
forall a b. (a -> b) -> a -> b
$ Cred Temporary -> ThreeLegged -> URI
buildAuthorizationUrl Cred Temporary
tempCr ThreeLegged
tl
      Response (Either ByteString (Token Permanent))
respPermToken <- Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Permanent)))
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Permanent)))
requestPermanentToken Cred Temporary
tempCr Server
srv ByteString
verifier ThreeLegged
tl Manager
man
      case Response (Either ByteString (Token Permanent))
-> Either ByteString (Token Permanent)
forall body. Response body -> body
C.responseBody Response (Either ByteString (Token Permanent))
respPermToken of
        Left ByteString
_ -> Maybe (Cred Permanent) -> m (Maybe (Cred Permanent))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Cred Permanent)
forall a. Maybe a
Nothing
        Right Token Permanent
tok' -> Maybe (Cred Permanent) -> m (Maybe (Cred Permanent))
forall (m :: * -> *) a. Monad m => a -> m a
return (Cred Permanent -> Maybe (Cred Permanent)
forall a. a -> Maybe a
Just (Cred Permanent -> Maybe (Cred Permanent))
-> Cred Permanent -> Maybe (Cred Permanent)
forall a b. (a -> b) -> a -> b
$ Token Permanent -> Cred Client -> Cred Permanent
O.permanentCred Token Permanent
tok' Cred Client
cr)

-- | Performs an interactive token request provided credentials,
-- configuration, and a way to convert a user authorization 'URI' into
-- a 'P.Verifier' out of band. Does not use any kind of TLS protection---it
-- will throw a 'C.TlsNotSupported' exception if TLS is required.
--
-- Throws 'C.HttpException's.
requestTokenProtocol
  :: (MonadIO m, MonadRandom m) => O.Cred O.Client -> O.Server -> ThreeLegged
                                -> (URI -> m P.Verifier)
                                -> m (Maybe (O.Cred O.Permanent))
requestTokenProtocol :: Cred Client
-> Server
-> ThreeLegged
-> (URI -> m ByteString)
-> m (Maybe (Cred Permanent))
requestTokenProtocol = ManagerSettings
-> Cred Client
-> Server
-> ThreeLegged
-> (URI -> m ByteString)
-> m (Maybe (Cred Permanent))
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
ManagerSettings
-> Cred Client
-> Server
-> ThreeLegged
-> (URI -> m ByteString)
-> m (Maybe (Cred Permanent))
requestTokenProtocol' ManagerSettings
C.defaultManagerSettings


  -- cCred <- lift getCredentials
  -- tok <- MaybeT (requestTemporaryToken threeLegged)
  -- MaybeT $ withCred (temporaryCred tok cCred) $ do
  --   url <- buildAuthorizationUrl threeLegged
  --   code <- liftIO $ do
  --     putStr "Please direct the user to the following address\n\n"
  --     putStr "    " >> print url >> putStr "\n\n"
  --     putStrLn "... then enter the verification code below (no spaces)\n"
  --     S.getLine
  --   requestPermanentToken threeLegged code