diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,10 @@ +-------------------------------------------------- +-- Copyright (C) 2018, All rights reserved. +-------------------------------------------------- + +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Hello world" diff --git a/lib/Network/HTTP/Req/OAuth2.hs b/lib/Network/HTTP/Req/OAuth2.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/OAuth2.hs @@ -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 . +-} + +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 diff --git a/lib/Network/HTTP/Req/OAuth2/Internal.hs b/lib/Network/HTTP/Req/OAuth2/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/OAuth2/Internal.hs @@ -0,0 +1,3 @@ +module Network.HTTP.Req.OAuth2.Internal + ( + ) where diff --git a/lib/Network/HTTP/Req/OAuth2/Internal/AccessToken.hs b/lib/Network/HTTP/Req/OAuth2/Internal/AccessToken.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/OAuth2/Internal/AccessToken.hs @@ -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 . +-- +-- 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") diff --git a/lib/Network/HTTP/Req/OAuth2/Internal/AuthCode.hs b/lib/Network/HTTP/Req/OAuth2/Internal/AuthCode.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/OAuth2/Internal/AuthCode.hs @@ -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 . +-- +-- 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) diff --git a/lib/Network/HTTP/Req/OAuth2/Internal/RefreshToken.hs b/lib/Network/HTTP/Req/OAuth2/Internal/RefreshToken.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/OAuth2/Internal/RefreshToken.hs @@ -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") diff --git a/lib/Network/HTTP/Req/OAuth2/Internal/Types.hs b/lib/Network/HTTP/Req/OAuth2/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/OAuth2/Internal/Types.hs @@ -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 diff --git a/lib/Network/HTTP/Req/OAuth2/Internal/Util.hs b/lib/Network/HTTP/Req/OAuth2/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/OAuth2/Internal/Util.hs @@ -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 diff --git a/lib/Network/HTTP/Req/OAuth2/Internal/Verbs.hs b/lib/Network/HTTP/Req/OAuth2/Internal/Verbs.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/OAuth2/Internal/Verbs.hs @@ -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 diff --git a/req-oauth2.cabal b/req-oauth2.cabal new file mode 100644 --- /dev/null +++ b/req-oauth2.cabal @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}