HttpClient.hs

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

{-
  A simple OAuth2 client.
-}

module Network.OAuth2.HTTP.HttpClient 
       ( OAuth2 (..)
       , AccessToken (..)
       , authorizationUrl
       , postAccessToken
       , signRequest
       )
       where

import Control.Monad.Trans.Resource
import Data.Aeson
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.List
import Data.Maybe
import Data.Typeable (Typeable)
import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery)
import qualified Network.HTTP.Types as HT
import Network.HTTP.Conduit
import Control.Exception
import Control.Applicative ((<$>))
import Control.Monad (mzero)

-- | Query Parameter Representation
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

-- | The gained Access Token 
data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show)

instance FromJSON AccessToken where
    parseJSON (Object o) = AccessToken <$> o .: "access_token"
    parseJSON _ = mzero

-- | Prepare the authorization URL
authorizationUrl :: OAuth2 -> BS.ByteString
authorizationUrl oa = oauthOAuthorizeEndpoint oa `BS.append` queryStr
  where queryStr = renderSimpleQuery True query
        query = foldr step [] [ ("client_id", Just $ oauthClientId oa)
                              , ("response_type", Just "code")
                              , ("redirect_uri", oauthCallback oa)]

request  :: Control.Monad.Trans.Resource.ResourceIO m =>
            Request m -> m (Response BSL.ByteString)
request req = (withManager . httpLbs) (req { checkStatus = \_ _ -> Nothing })

postAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString
postAccessToken' oa code grant_type = do
    print url
    print query
    rsp <- request req
    if (HT.statusCode . statusCode) rsp == 200
        then return $ responseBody rsp
        else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp)
  where
    req = urlEncodedBody query . fromJust $ parseUrl url
    url = BS.unpack $ oauthAccessTokenEndpoint oa
    query = foldr step [] [ ("client_id", Just $ oauthClientId oa)
                          , ("client_secret", Just $ oauthClientSecret oa)
                          , ("code", Just code)
                          , ("redirect_uri", oauthCallback oa)
                          , ("grant_type", grant_type) ]



step :: (a, Maybe b) -> [(a, b)] -> [(a, b)]
step (a, Just b) xs = (a, b):xs
step _ xs = xs

-- | Request (POST method) access token URL in order to get @AccessToken@.
postAccessToken :: OAuth2 
                -> BS.ByteString          -- ^ Authentication code gained after authorization
                -> IO (Maybe AccessToken)
postAccessToken oa code = decode <$> postAccessToken' oa code (Just "authorization_code")

-- | 
signRequest :: OAuth2 -> Request m -> Request m
signRequest oa req = req { queryString = (renderSimpleQuery False newQuery) }
  where
    newQuery = case oauthAccessToken oa of
                    Just at -> insert ("oauth_token", at) oldQuery
                    _ -> insert ("client_id", oauthClientId oa) . insert ("client_secret", oauthClientSecret oa) $ oldQuery
    oldQuery = parseSimpleQuery (queryString req)