module PokitDok.OAuth2
( OAuth2(..)
, AccessToken(..)
, ResponseData(..)
, Parameters
, keyModAccessToken
, authenticateClientCredentials
, authenticateAuthorizationCode
, authenticateRefreshToken
, getRequest
, deleteRequest
, postRequest
, multipartRequest
, putRequest
, makeUserAgentHeader
, makeContentHeader
, makeAuthHeader
, appendParams
) where
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Codec.Binary.Base64.String as B64
import Control.Applicative ((<$>), (<*>))
import Control.Monad (mzero)
import Data.CaseInsensitive (foldCase, mk)
import Data.Time.Calendar (fromGregorian)
import Network.HTTP.Conduit
( Response
, Request(method, requestHeaders, requestBody)
, RequestBody(RequestBodyBS)
, parseUrl
, urlEncodedBody
, httpLbs
, withManager
, responseBody
, responseStatus
, responseHeaders
)
import Network.HTTP.Client.MultipartFormData
( Part
, partBS
, partFile
, formDataBodyWithBoundary
)
import Network.HTTP.Types (statusCode)
import Network.HTTP.Types.Header (Header)
import Network.HTTP.Base (urlEncode)
import Data.Aeson
import Data.Maybe (fromJust)
type Parameters = [(String, String)]
type Headers = [(String, String)]
data OAuth2 = OAuth2
{ oauthClientId :: String
, oauthClientSecret :: String
, oauthAccessTokenEndpoint :: String
, oauthOAuthorizeEndpoint :: Maybe String
, oauthCallback :: Maybe String
, oauthAccessToken :: Maybe AccessToken
} deriving (Show, Eq)
data AccessToken = AccessToken
{ accessToken :: String
, refreshToken :: Maybe String
, expires :: Maybe Int
, expiresIn :: Maybe Int
, token_type :: Maybe String
} deriving (Show, Eq)
data ResponseData = ResponseData
{ headers :: Headers
, body :: String
, status :: Int
} deriving Show
instance FromJSON AccessToken where
parseJSON (Object o) = AccessToken <$> at <*> rt <*> ex <*> ei <*> tt
where
at = o .: T.pack "access_token"
rt = o .:? T.pack "refresh_token"
ex = o .:? T.pack "expires"
ei = o .:? T.pack "expires_in"
tt = o .: T.pack "token_type"
parseJSON _ = mzero
keyModAccessToken :: OAuth2 -> Maybe AccessToken -> OAuth2
keyModAccessToken oauth n@Nothing = oauth { oauthAccessToken = n }
keyModAccessToken oauth j = oauth { oauthAccessToken = j }
authenticateRequest :: Request -> IO AccessToken
authenticateRequest request = do
response <- getResponse request
let maybeToken = decode $ responseBody response
case maybeToken of
Nothing -> error $ "***** Error decoding response:\n"++show response
Just token -> return token
authenticateClientCredentials :: Headers -> OAuth2 -> IO AccessToken
authenticateClientCredentials headers auth@(OAuth2 _ _ url _ _ _) = do
req <- makeRegularPostRequest url $ makeHeaders headers
authenticateRequest $ urlEncodedBody clientCredentialParams req
where
clientCredentialParams = map strToBS $
[ ("grant_type" , "client_credentials")
, ("client_id" , oauthClientId auth)
, ("client_secret", oauthClientSecret auth)
]
authenticateAuthorizationCode :: Headers -> OAuth2 -> String -> IO AccessToken
authenticateAuthorizationCode headers auth@(OAuth2 _ _ url _ _ _) code = do
req <- makeRegularPostRequest url $ makeHeaders headers
authenticateRequest $ urlEncodedBody authorizationCodeParams req
where
authorizationCodeParams = map strToBS $
[ ("grant_type" , "authorization_code")
, ("client_id" , oauthClientId auth)
, ("client_secret", oauthClientSecret auth)
, ("redirect_uri" , fromJust $ oauthCallback auth)
, ("code" , code)
, ("scope" , "user_schedule")
]
authenticateRefreshToken :: Headers -> OAuth2 -> IO AccessToken
authenticateRefreshToken h a@(OAuth2 id sec url _ _ (Just (AccessToken _ (Just rt) _ _ _))) = do
let parameters = map strToBS refreshTokenParams
req <- makeRegularPostRequest url $ makeHeaders h
authenticateRequest req
where
refreshTokenParams =
[ ("grant_type" , "refresh_token")
, ("client_id" , id)
, ("client_secret", sec)
, ("refresh_token", rt)
, ("scope" , "user_schedle")
]
getRequest :: Headers -> String -> Parameters -> IO ResponseData
getRequest headers url params = do
req <- makeGetRequest (appendParams url params) $ makeHeaders headers
handleRequest req
deleteRequest :: Headers -> String -> IO ResponseData
deleteRequest headers url =
makeDeleteRequest url (makeHeaders headers) >>= handleRequest
postRequest :: Headers -> String -> String -> IO ResponseData
postRequest headers url body = do
req <- makePostRequest url $ makeHeaders headers
handleRequest $ req { requestBody = RequestBodyBS $ BS.pack body }
multipartRequest
:: Headers
-> String
-> Parameters
-> String
-> String
-> IO ResponseData
multipartRequest headers url params path boundary = do
let part0 = partFile (T.pack "file") path
parts = makeMultipartParts params ++ [part0]
req <- parseUrl url >>= formDataBodyWithBoundary (BS.pack boundary) parts
handleRequest $ req { requestHeaders = requestHeaders req ++ makeHeaders headers }
putRequest :: Headers -> String -> String -> IO ResponseData
putRequest headers url body = do
req <- makePutRequest url $ makeHeaders headers
handleRequest $ req { requestBody = RequestBodyBS $ BS.pack body }
handleRequest :: Request -> IO ResponseData
handleRequest req = do
resp <- getResponse req
return $ ResponseData
{ headers = map showpair $ responseHeaders resp
, body = BSL.unpack $ responseBody resp
, status = statusCode $ responseStatus resp
}
where
showpair (a, b) = (show a, show b)
getResponse :: Request -> IO (Response BSL.ByteString)
getResponse = withManager . httpLbs
makeHeader :: (String, String) -> Header
makeHeader (key, val) = (toCI key, BS.pack val)
where
toCI = mk . foldCase . BS.pack
makeHeaders :: Headers -> [Header]
makeHeaders = map makeHeader
makeUserAgentHeader :: String -> (String,String)
makeUserAgentHeader str = ("User-Agent" , str)
makeAuthHeader :: String -> (String,String)
makeAuthHeader str = ("Authorization", str)
makeContentHeader :: String -> (String,String)
makeContentHeader str = ("Content-Type" , str)
appendParams :: String -> Parameters -> String
appendParams url ((k,v):ps)
| '?' `elem` url = appendParams (url ++ "&" ++ k ++ "=" ++ urlEncode v) ps
| otherwise = appendParams (url ++ "?" ++ k ++ "=" ++ urlEncode v) ps
appendParams url [] = url
strToBS :: (String,String) -> (BS.ByteString,BS.ByteString)
strToBS (a,b) = (BS.pack a,BS.pack b)
makeGetRequest :: String -> [Header] -> IO Request
makeGetRequest uri headers = do
req <- parseUrl uri
return $ req
{ requestHeaders = makeHeader contentHeader : headers
}
where
contentHeader = makeContentHeader "application/x-www-form-urlencoded"
makeDeleteRequest :: String -> [Header] -> IO Request
makeDeleteRequest uri headers = do
req <- makeGetRequest uri headers
return $ req { method = BS.pack "DELETE" }
makePostRequest :: String -> [Header] -> IO Request
makePostRequest uri headers = do
req <- makeRegularPostRequest uri headers
return $ req
{ requestHeaders = (makeHeader $ makeContentHeader "application/json")
: headers
}
makeRegularPostRequest :: String -> [Header] -> IO Request
makeRegularPostRequest uri headers = do
req <- makeGetRequest uri headers
return $ req { method = BS.pack "POST" }
makePutRequest :: String -> [Header] -> IO Request
makePutRequest uri headers = do
req <- makePostRequest uri headers
return $ req { method = BS.pack "PUT" }
makeMultipartParts :: Parameters -> [Part]
makeMultipartParts ((a,b):cs) = partBS (T.pack a) (BS.pack b) : makeMultipartParts cs
makeMultipartParts _ = []