req-oauth2 (empty) → 0.1.0.0
raw patch · 14 files changed
+510/−0 lines, 14 filesdep +aesondep +basedep +base64-bytestringsetup-changed
Dependencies added: aeson, base, base64-bytestring, bytestring, data-default-class, hspec, http-client, http-types, lens, modern-uri, req, req-url-extra, text, transformers
Files
- LICENSE +20/−0
- README.md +39/−0
- Setup.hs +10/−0
- app/Main.hs +4/−0
- lib/Network/HTTP/Req/OAuth2.hs +38/−0
- lib/Network/HTTP/Req/OAuth2/Internal.hs +3/−0
- lib/Network/HTTP/Req/OAuth2/Internal/AccessToken.hs +45/−0
- lib/Network/HTTP/Req/OAuth2/Internal/AuthCode.hs +47/−0
- lib/Network/HTTP/Req/OAuth2/Internal/RefreshToken.hs +36/−0
- lib/Network/HTTP/Req/OAuth2/Internal/Types.hs +54/−0
- lib/Network/HTTP/Req/OAuth2/Internal/Util.hs +67/−0
- lib/Network/HTTP/Req/OAuth2/Internal/Verbs.hs +67/−0
- req-oauth2.cabal +79/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2018 Richard Cook++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,39 @@+# req-oauth2 by Richard Cook++Haskell application with main executable only built using Stack++## Clone repository++```+git clone https://github.com/rcook/req-oauth2.git+```++## Install compiler++```+stack setup+```++## Build++```+stack build --fast+```++## Run application++```+stack exec req-oauth2-app+```++## Run tests++```+stack test+```++## Licence++Released under [MIT License][licence]++[licence]: LICENSE
+ Setup.hs view
@@ -0,0 +1,10 @@+--------------------------------------------------+-- Copyright (C) 2018, All rights reserved.+--------------------------------------------------++module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Hello world"
+ lib/Network/HTTP/Req/OAuth2.hs view
@@ -0,0 +1,38 @@+{-|+Module : Network.HTTP.Req.OAuth2+Description : Basic OAuth2 support for Req+Copyright : (C) Richard Cook, 2018+Licence : MIT+Maintainer : rcook@rcook.org+Stability : stable+Portability : portable++This package provides basic support of OAuth2 authentication for <https://hackage.haskell.org/package/req Req>.+-}++module Network.HTTP.Req.OAuth2+ ( AccessToken(..)+ , AccessTokenRequest(..)+ , AccessTokenResponse(..)+ , App(..)+ , ClientId(..)+ , ClientPair(..)+ , ClientSecret(..)+ , OAuth2+ , PromptForCallbackUri+ , RefreshToken(..)+ , TokenPair(..)+ , UpdateTokenPair+ , evalOAuth2+ , fetchAccessToken+ , getAuthCode+ , oAuth2Get+ , runOAuth2+ ) where++import Network.HTTP.Req.OAuth2.Internal.AccessToken+import Network.HTTP.Req.OAuth2.Internal.AuthCode+import Network.HTTP.Req.OAuth2.Internal.RefreshToken+import Network.HTTP.Req.OAuth2.Internal.Types+import Network.HTTP.Req.OAuth2.Internal.Util+import Network.HTTP.Req.OAuth2.Internal.Verbs
+ lib/Network/HTTP/Req/OAuth2/Internal.hs view
@@ -0,0 +1,3 @@+module Network.HTTP.Req.OAuth2.Internal+ (+ ) where
+ lib/Network/HTTP/Req/OAuth2/Internal/AccessToken.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Req.OAuth2.Internal.AccessToken+ ( AccessTokenRequest(..)+ , AccessTokenResponse(..)+ , fetchAccessToken+ ) where++import Data.Aeson ((.:), withObject)+import Data.Aeson.Types (Parser, Value, parseEither)+import Data.Monoid ((<>))+import Data.Text (Text)+import Network.HTTP.Req ((=:))+import Network.HTTP.Req.OAuth2.Internal.AuthCode+import Network.HTTP.Req.OAuth2.Internal.Types+import Network.HTTP.Req.OAuth2.Internal.Util+import Network.HTTP.Req.Url.Extra (toUrlHttps)++data AccessTokenRequest = AccessTokenRequest AuthCode++data AccessTokenResponse = AccessTokenResponse TokenPair++-- | Gets OAuth2 access token+--+-- Implements standard OAuth2 access token workflow for web server apps+-- as described <https://aaronparecki.com/oauth-2-simplified/#web-server-apps here>.+--+-- We don't pass @client_secret@ because that would be silly. We also don't bother+-- with @redirect_uri@ since this do not seem to be required.+fetchAccessToken :: App -> AccessTokenRequest -> IO (Either String AccessTokenResponse)+fetchAccessToken app (AccessTokenRequest (AuthCode ac)) = do+ let clientPair = appClientPair app+ ClientPair (ClientId cid) _ = clientPair+ Just (url, _) = toUrlHttps $ appTokenUri app+ parseEither pResponse <$>+ oAuth2PostRaw+ url+ (oAuth2AuthHeader clientPair)+ ("code" =: ac <> "grant_type" =: ("authorization_code" :: Text) <> "client_id" =: cid <> "expires_in" =: ("3600" :: Text))++pResponse :: Value -> Parser AccessTokenResponse+pResponse =+ withObject "AccessTokenResponse" $ \v -> (AccessTokenResponse .) . TokenPair+ <$> (AccessToken <$> v .: "access_token")+ <*> (RefreshToken <$> v .: "refresh_token")
+ lib/Network/HTTP/Req/OAuth2/Internal/AuthCode.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Req.OAuth2.Internal.AuthCode+ ( AuthCode(..)+ , PromptForCallbackUri+ , getAuthCode+ ) where++import Control.Lens ((^..), (.~), (&))+import Data.Text (Text)+import Network.HTTP.Req.OAuth2.Internal.Types+import Text.URI (QueryParam(..), URI, mkQueryKey, mkQueryValue, unRText)+import Text.URI.Lens (queryParam, uriQuery)++type PromptForCallbackUri = URI -> IO URI++newtype AuthCode = AuthCode Text deriving Show++convertParams :: [(Text, Text)] -> Maybe [QueryParam]+convertParams qs = mapM (\(k, v) -> do+ qk <- mkQueryKey k+ qv <- mkQueryValue v+ return $ QueryParam qk qv) qs++buildAuthUriWithOpts :: URI -> [(Text, Text)] -> Maybe URI+buildAuthUriWithOpts u qs = do+ qs' <- convertParams qs+ return $ u & uriQuery .~ qs'++-- | Gets OAuth2 authorization code+--+-- Implements standard OAuth2 authorization workflow for web server apps+-- as described <https://aaronparecki.com/oauth-2-simplified/#web-server-apps here>.+--+-- We don't bother with @redirect_uri@ or @state@ since they do not seem+-- to be required.+getAuthCode :: App -> ClientId -> PromptForCallbackUri -> IO AuthCode+getAuthCode app (ClientId clientId) prompt = do+ let Just authUriWithOpts = buildAuthUriWithOpts (appAuthUri app)+ [ ("client_id", clientId)+ , ("response_type", "code")+ , ("scope", "weight")+ ]+ callbackUri <- prompt authUriWithOpts+ codeKey <- mkQueryKey "code"+ let code = head $ callbackUri ^.. uriQuery . queryParam codeKey+ return $ AuthCode (unRText code)
+ lib/Network/HTTP/Req/OAuth2/Internal/RefreshToken.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Req.OAuth2.Internal.RefreshToken+ ( RefreshTokenRequest(..)+ , RefreshTokenResponse(..)+ , fetchRefreshToken+ ) where++import Data.Aeson ((.:), withObject)+import Data.Aeson.Types (Parser, Value, parseEither)+import Data.Monoid ((<>))+import Data.Text (Text)+import Network.HTTP.Req ((=:))+import Network.HTTP.Req.Url.Extra (toUrlHttps)+import Network.HTTP.Req.OAuth2.Internal.Types+import Network.HTTP.Req.OAuth2.Internal.Util++data RefreshTokenRequest = RefreshTokenRequest RefreshToken++data RefreshTokenResponse = RefreshTokenResponse TokenPair++fetchRefreshToken :: App -> RefreshTokenRequest -> IO (Either String RefreshTokenResponse)+fetchRefreshToken app (RefreshTokenRequest (RefreshToken rt)) = do+ let clientPair = appClientPair app+ Just (url, _) = toUrlHttps $ appTokenUri app+ parseEither pResponse <$>+ oAuth2PostRaw+ url+ (oAuth2AuthHeader clientPair)+ ("grant_type" =: ("refresh_token" :: Text) <> "refresh_token" =: rt <> "expires_in" =: ("3600" :: Text))++pResponse :: Value -> Parser RefreshTokenResponse+pResponse =+ withObject "RefreshTokenResponse" $ \v -> (RefreshTokenResponse . ) . TokenPair+ <$> (AccessToken <$> v .: "access_token")+ <*> (RefreshToken <$> v .: "refresh_token")
+ lib/Network/HTTP/Req/OAuth2/Internal/Types.hs view
@@ -0,0 +1,54 @@+module Network.HTTP.Req.OAuth2.Internal.Types+ ( AccessToken(..)+ , App(..)+ , ClientId(..)+ , ClientPair(..)+ , ClientSecret(..)+ , OAuth2+ , ParseError(..)+ , RefreshToken(..)+ , TokenPair(..)+ , UpdateTokenPair+ ) where++import Control.Exception (Exception)+import Control.Monad.Trans.State.Strict (StateT)+import Data.Text (Text)+import Data.Typeable (Typeable)+import Text.URI (URI)++-- | OAuth2 application monad+type OAuth2 = StateT TokenPair IO++-- | OAuth2 client ID+newtype ClientId = ClientId Text deriving (Eq, Show)++-- | OAuth2 client secret+newtype ClientSecret = ClientSecret Text deriving (Eq, Show)++-- | OAuth2 access token+newtype AccessToken = AccessToken Text deriving Show++-- | OAuth2 refresh token+newtype RefreshToken = RefreshToken Text deriving Show++-- | OAuth2 client ID/client secret pair+data ClientPair = ClientPair ClientId ClientSecret deriving (Eq, Show)++-- | OAuth2 access/refresh token pair+data TokenPair = TokenPair AccessToken RefreshToken deriving Show++-- | Action invoked in response to update to access/refresh token pair+type UpdateTokenPair = TokenPair -> IO ()++-- | A web API application+data App = App+ { appAuthUri :: URI+ , appTokenUri :: URI+ , appUpdateTokenPair :: UpdateTokenPair+ , appClientPair :: ClientPair+ }++-- | TODO+data ParseError = ParseError String deriving (Show, Typeable)+instance Exception ParseError
+ lib/Network/HTTP/Req/OAuth2/Internal/Util.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Network.HTTP.Req.OAuth2.Internal.Util+ ( acceptLanguage+ , evalOAuth2+ , hasResponseStatus+ , oAuth2AuthHeader+ , oAuth2BearerHeader+ , oAuth2PostRaw+ , runOAuth2+ ) where++import Control.Monad.Trans.State.Strict (evalStateT, runStateT)+import Data.Aeson (Value)+import qualified Data.ByteString as ByteString (append, concat)+import qualified Data.ByteString.Base64 as Base64 (encode)+import Data.Default.Class (def)+import qualified Data.Text.Encoding as Text (encodeUtf8)+import qualified Network.HTTP.Client as HTTP (HttpException(..), HttpExceptionContent(..), responseStatus)+import Network.HTTP.Req+ ( FormUrlEncodedParam+ , HttpException(..)+ , Option+ , POST(..)+ , ReqBodyUrlEnc(..)+ , Scheme(..)+ , Url+ , header+ , jsonResponse+ , oAuth2Bearer+ , req+ , responseBody+ , runReq+ )+import Network.HTTP.Req.OAuth2.Internal.Types+import Network.HTTP.Types (Status)++hasResponseStatus :: HttpException -> Status -> Bool+hasResponseStatus+ (VanillaHttpException (HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException response _))) status =+ HTTP.responseStatus response == status+hasResponseStatus _ _ = False++acceptLanguage :: Option scheme+acceptLanguage = header "Accept-Language" "en_US"++oAuth2AuthHeader :: ClientPair -> Option scheme+oAuth2AuthHeader clientPair =+ header "Authorization" (ByteString.append "Basic " (encodeClientAuth clientPair))+ where+ encodeClientAuth (ClientPair (ClientId cid) (ClientSecret cs)) = Base64.encode $ ByteString.concat [Text.encodeUtf8 cid, ":", Text.encodeUtf8 cs]++oAuth2BearerHeader :: AccessToken -> Option 'Https+oAuth2BearerHeader (AccessToken at) = oAuth2Bearer (Text.encodeUtf8 at)++oAuth2PostRaw :: Url 'Https -> Option 'Https -> FormUrlEncodedParam -> IO Value+oAuth2PostRaw url opts formBody =+ runReq def $+ responseBody <$> req POST url (ReqBodyUrlEnc formBody) jsonResponse opts++evalOAuth2 :: TokenPair -> OAuth2 a -> IO a+evalOAuth2 = flip evalStateT++runOAuth2 :: TokenPair -> OAuth2 a -> IO (a, TokenPair)+runOAuth2 = flip runStateT
+ lib/Network/HTTP/Req/OAuth2/Internal/Verbs.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds #-}++module Network.HTTP.Req.OAuth2.Internal.Verbs+ ( oAuth2Get+ ) where++import Control.Exception (catch, throwIO)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.State.Strict (get, put)+import Data.Aeson (Value)+import Data.Aeson.Types (Parser, parseEither)+import Data.Default.Class (def)+import Data.Monoid ((<>))+import Network.HTTP.Req+ ( GET(..)+ , NoReqBody(..)+ , Scheme(..)+ , Url+ , jsonResponse+ , req+ , responseBody+ , runReq+ )+import Network.HTTP.Req.OAuth2.Internal.RefreshToken+import Network.HTTP.Req.OAuth2.Internal.Types+import Network.HTTP.Req.OAuth2.Internal.Util+import Network.HTTP.Types (unauthorized401)++oAuth2Get ::+ (Value -> Parser a)+ -> Url 'Https+ -> App+ -> OAuth2 a+oAuth2Get p apiUrl app = do+ tokenPair@(TokenPair accessToken _) <- get+ (value, tokenPair') <-+ liftIO $ catch+ (getHelper apiUrl accessToken >>= \value -> return (value, tokenPair)) $ \e ->+ if hasResponseStatus e unauthorized401+ then do+ newTokenPair@(TokenPair newAccessToken _) <- refreshHelper app tokenPair+ result <- getHelper apiUrl newAccessToken+ return (result, newTokenPair)+ else throwIO e+ put tokenPair'+ case parseEither p value of+ Left e -> liftIO (throwIO $ ParseError e)+ Right result -> return result++getHelper ::+ Url 'Https+ -> AccessToken+ -> IO Value+getHelper url accessToken =+ responseBody <$> (runReq def $ req GET url NoReqBody jsonResponse (oAuth2BearerHeader accessToken <> acceptLanguage))++refreshHelper ::+ App+ -> TokenPair+ -> IO TokenPair+refreshHelper app@(App _ _ u _) (TokenPair _ refreshToken) = do+ result <- fetchRefreshToken app (RefreshTokenRequest refreshToken)+ let (RefreshTokenResponse newTokenPair) = case result of+ Left e -> error e -- TODO: Error handling+ Right x -> x+ u newTokenPair+ return newTokenPair
+ req-oauth2.cabal view
@@ -0,0 +1,79 @@++name: req-oauth2+version: 0.1.0.0+synopsis: Provides OAuth2 authentication for use with Req+description: This package adds OAuth2 authentication to Req.+homepage: https://github.com/rcook/req-oauth2#readme+license: MIT+license-file: LICENSE+author: Richard Cook+maintainer: rcook@rcook.org+copyright: 2018 Richard Cook+category: Command Line+build-type: Simple+cabal-version: >= 1.10+extra-source-files: README.md++source-repository head+ type: git+ location: https://github.com/rcook/req-oauth2.git++library+ default-language: Haskell2010+ hs-source-dirs: lib+ ghc-options: -W+ -Wall+ -Werror=incomplete-patterns+ -Werror=missing-methods+ -fwarn-unused-imports+ build-depends: aeson+ , base >= 4.7 && < 5+ , base64-bytestring+ , bytestring+ , data-default-class+ , http-client+ , http-types+ , lens+ , modern-uri+ , req+ , req-url-extra+ , text+ , transformers+ exposed-modules: Network.HTTP.Req.OAuth2+ , Network.HTTP.Req.OAuth2.Internal+ , Network.HTTP.Req.OAuth2.Internal.AccessToken+ , Network.HTTP.Req.OAuth2.Internal.AuthCode+ , Network.HTTP.Req.OAuth2.Internal.RefreshToken+ , Network.HTTP.Req.OAuth2.Internal.Types+ , Network.HTTP.Req.OAuth2.Internal.Util+ , Network.HTTP.Req.OAuth2.Internal.Verbs++executable req-oauth2-app+ default-language: Haskell2010+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N+ -W+ -Wall+ -Werror=incomplete-patterns+ -Werror=missing-methods+ -fwarn-unused-imports+ build-depends: base >= 4.7 && < 5++test-suite req-oauth2-test+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: test+ main-is: Spec.hs+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N+ -W+ -Wall+ -Werror=incomplete-patterns+ -Werror=missing-methods+ -fwarn-unused-imports+ build-depends: base >= 4.7 && < 5+ , hspec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}