module Network.OAuth.OAuth2 where
import Control.Applicative ((<$>), (<*>))
import Control.Exception
import Control.Monad (mzero)
import Data.Aeson
import qualified Data.ByteString as BS
import Data.Maybe (fromMaybe)
import Data.Typeable (Typeable)
import Network.HTTP.Types (renderSimpleQuery)
data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString
, oauthClientSecret :: BS.ByteString
, oauthOAuthorizeEndpoint :: BS.ByteString
, oauthAccessTokenEndpoint :: BS.ByteString
, oauthCallback :: Maybe BS.ByteString
, oauthAccessToken :: Maybe BS.ByteString
} deriving (Show, Eq)
data OAuthException = OAuthException String
deriving (Show, Eq, Typeable)
instance Exception OAuthException
data AccessToken = AccessToken { accessToken :: BS.ByteString
, refreshToken :: Maybe BS.ByteString }
deriving (Show)
instance FromJSON AccessToken where
parseJSON (Object o) = AccessToken
<$> o .: "access_token"
<*> o .:? "refresh_token"
parseJSON _ = mzero
type QueryParams = [(BS.ByteString, BS.ByteString)]
type PostBody = [(BS.ByteString, BS.ByteString)]
type URI = BS.ByteString
type AccessCode = BS.ByteString
authorizationUrl :: OAuth2 -> URI
authorizationUrl oa = oauthOAuthorizeEndpoint oa `appendQueryParam` queryStr
where queryStr = transform' [ ("client_id", Just $ oauthClientId oa)
, ("response_type", Just "code")
, ("redirect_uri", oauthCallback oa)]
accessTokenUrl :: OAuth2
-> AccessCode
-> (URI, PostBody)
accessTokenUrl oa code = accessTokenUrl' oa code (Just "authorization_code")
accessTokenUrl' :: OAuth2
-> AccessCode
-> Maybe BS.ByteString
-> (URI, PostBody)
accessTokenUrl' oa code gt = (uri, body)
where uri = oauthAccessTokenEndpoint oa
body = transform' [ ("client_id", Just $ oauthClientId oa)
, ("client_secret", Just $ oauthClientSecret oa)
, ("code", Just code)
, ("redirect_uri", oauthCallback oa)
, ("grant_type", gt) ]
refreshAccessTokenUrl :: OAuth2
-> BS.ByteString
-> (URI, PostBody)
refreshAccessTokenUrl oa rtoken = (uri, body)
where uri = oauthAccessTokenEndpoint oa
body = transform' [ ("client_id", Just $ oauthClientId oa)
, ("client_secret", Just $ oauthClientSecret oa)
, ("grant_type", Just "refresh_token")
, ("refresh_token", Just rtoken) ]
appendQueryParam :: URI -> QueryParams -> URI
appendQueryParam uri q = uri `BS.append` renderSimpleQuery True q
appendQueryParam' :: URI -> QueryParams -> URI
appendQueryParam' uri q = uri `BS.append` "&" `BS.append` renderSimpleQuery False q
appendAccessToken :: URI
-> OAuth2
-> URI
appendAccessToken uri oauth = appendQueryParam uri
(token $ oauthAccessToken oauth)
where token :: Maybe BS.ByteString -> QueryParams
token = accessTokenToParam . fromMaybe ""
accessTokenToParam :: BS.ByteString -> QueryParams
accessTokenToParam token = [("access_token", token)]
transform' :: [(a, Maybe b)] -> [(a, b)]
transform' = foldr step' []
where step' :: (a, Maybe b) -> [(a, b)] -> [(a, b)]
step' (a, Just b) xs = (a, b):xs
step' _ xs = xs