diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -25,16 +25,15 @@ import Debug.Trace -- Libraries import Data.Char -import Data.List import Data.Maybe import Network.HTTP.Enumerator import qualified Data.ByteString.Char8 as S8 -import Control.Arrow (first, (***)) +import Control.Arrow (first) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Failure (Failure (failure)) import Control.Monad (mplus, liftM) import qualified Data.CaseInsensitive as CI -import Data.Text (Text, pack, unpack) +import Data.Text (Text, unpack) import Data.Text.Lazy (toStrict) import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8With) @@ -136,7 +135,7 @@ . mapMaybe linkTag . parseTags where - isOpenId (rel, x) = "openid" `T.isPrefixOf` rel + isOpenId (rel, _x) = "openid" `T.isPrefixOf` rel resolve1 ls = do server <- lookup "openid.server" ls let delegate = lookup "openid.delegate" ls @@ -151,6 +150,6 @@ -- | Filter out link tags from a list of html tags. ---linkTags :: [Tag Text] -> [(Text, Text)] +linkTag :: Tag Text -> Maybe (Text, Text) linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x -linkTag x = Nothing +linkTag _x = Nothing diff --git a/OpenId2/XRDS.hs b/OpenId2/XRDS.hs --- a/OpenId2/XRDS.hs +++ b/OpenId2/XRDS.hs @@ -23,7 +23,7 @@ import Control.Monad ((>=>)) import Data.Maybe (listToMaybe) import Text.XML.Enumerator.Resolved (parseLBS, decodeEntities) -import Text.XML.Enumerator.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute, node) +import Text.XML.Enumerator.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute) import qualified Data.ByteString.Lazy as L import Data.Text (Text) import qualified Data.Text.Read diff --git a/Web/Authenticate/BrowserId.hs b/Web/Authenticate/BrowserId.hs --- a/Web/Authenticate/BrowserId.hs +++ b/Web/Authenticate/BrowserId.hs @@ -6,7 +6,6 @@ import Data.Text (Text) import Network.HTTP.Enumerator (parseUrl, responseBody, httpLbs, withManager, method, urlEncodedBody) -import Network.HTTP.Types (queryTextToQuery) import Data.Aeson (json, Value (Object, String)) import Data.Attoparsec.Lazy (parse, maybeResult) import qualified Data.Map as Map diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -3,8 +3,6 @@ ( AuthenticateException (..) ) where -import Numeric (showHex) -import Data.List (intercalate) import Data.Typeable (Typeable) import Control.Exception (Exception) diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -9,9 +9,12 @@ signOAuth, genSign, -- * Url & operation for authentication authorizeUrl, getAccessToken, getTemporaryCredential, - getTokenCredential, + getTokenCredential, getTemporaryCredentialWithScope, + getAccessTokenProxy, getTemporaryCredentialProxy, + getTokenCredentialProxy, + getAccessToken', getTemporaryCredential', -- * Utility Methods - paramEncode + paramEncode, addScope, addMaybeProxy ) where import Network.HTTP.Enumerator import Data.Data @@ -89,10 +92,32 @@ -- | Get temporary credential for requesting acces token. getTemporaryCredential :: OAuth -- ^ OAuth Application -> IO Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredential oa = do +getTemporaryCredential = getTemporaryCredential' id + +-- | Get temporary credential for requesting access token with Scope parameter. +getTemporaryCredentialWithScope :: BS.ByteString -- ^ Scope parameter string + -> OAuth -- ^ OAuth Application + -> IO Credential -- ^ Temporay Credential (Request Token & Secret). +getTemporaryCredentialWithScope = getTemporaryCredential' . addScope + +addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m +addScope scope req | BS.null scope = req + | otherwise = urlEncodedBody [("scope", scope)] req + +-- | Get temporary credential for requesting access token via the proxy. +getTemporaryCredentialProxy :: Maybe Proxy -- ^ Proxy + -> OAuth -- ^ OAuth Application + -> IO Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredentialProxy p = getTemporaryCredential' $ addMaybeProxy p + +getTemporaryCredential' :: (Request IO -> Request IO) -- ^ Request Hook + -> OAuth -- ^ OAuth Application + -> IO Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredential' hook oa = do let req = fromJust $ parseUrl $ oauthRequestUri oa - req' <- signOAuth oa emptyCredential (req { method = "POST" }) - rsp <- withManager $ httpLbs req' + crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential + req' <- signOAuth oa crd $ hook (req { method = "POST" }) + rsp <- withManager . httpLbs $ req' if statusCode rsp == 200 then do let dic = parseSimpleQuery . toStrict . responseBody $ rsp @@ -110,17 +135,32 @@ :: OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential with oauth_verifier -> IO Credential -- ^ Token Credential (Access Token & Secret) -getAccessToken oa cr = do - let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } - rsp <- signOAuth oa cr req >>= withManager . httpLbs +getAccessToken = getAccessToken' id + +-- | Get Access token via the proxy. +getAccessTokenProxy, getTokenCredentialProxy + :: Maybe Proxy -- ^ Proxy + -> OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> IO Credential -- ^ Token Credential (Access Token & Secret) +getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p + +getAccessToken' :: (Request IO -> Request IO) -- ^ Request Hook + -> OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> IO Credential -- ^ Token Credential (Access Token & Secret) +getAccessToken' hook oa cr = do + let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } + rsp <- withManager . httpLbs =<< signOAuth oa cr req if statusCode rsp == 200 then do let dic = parseSimpleQuery . toStrict . responseBody $ rsp return $ Credential dic - else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp) + else throwIO . OAuthException $ "Gaining OAuth Token Credential Failed: " ++ BSL.unpack (responseBody rsp) getTokenCredential = getAccessToken +getTokenCredentialProxy = getAccessTokenProxy insertMap :: Eq a => a -> b -> [(a,b)] -> [(a,b)] insertMap key val = ((key,val):) . filter ((/=key).fst) @@ -177,11 +217,11 @@ return $ insert "oauth_timestamp" (BS.pack $ show stamp) cred injectOAuthToCred :: OAuth -> Credential -> Credential -injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa) $ - inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa) - , ("oauth_consumer_key", oauthConsumerKey oa) - , ("oauth_version", "1.0") - ] cred +injectOAuthToCred oa cred = + inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa) + , ("oauth_consumer_key", oauthConsumerKey oa) + , ("oauth_version", "1.0") + ] cred genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString genSign oa tok req = @@ -227,7 +267,8 @@ allParams = bsQuery++bsBodyQ++bsAuthParams bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams - -- FIXME it would be much better to use http-types functions here + -- parameter encoding method in OAuth is slight different from ordinary one. + -- So this is OK. return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] toLBS :: MonadIO m => RequestBody m -> m BS.ByteString @@ -257,3 +298,6 @@ LT -> LT EQ -> compare b d GT -> GT + +addMaybeProxy :: Maybe Proxy -> Request m -> Request m +addMaybeProxy p req = req { proxy = p } diff --git a/authenticate.cabal b/authenticate.cabal --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.3.1 +version: 0.10.1 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani @@ -9,13 +9,13 @@ rpxnow and Facebook. category: Web stability: Stable -cabal-version: >= 1.2 +cabal-version: >= 1.6 build-type: Simple homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, - aeson >= 0.3.1.1 && < 0.4, + aeson-native >= 0.3.2.11 && < 0.4, http-enumerator >= 0.6.5.4 && < 0.7, tagsoup >= 0.12 && < 0.13, failure >= 0.0.0 && < 0.2, @@ -36,7 +36,7 @@ attoparsec >= 0.9 && < 0.10, tls >= 0.7 && < 0.8, containers, - process >= 1.0.1.1 && < 1.1 + process >= 1.0.1.1 && < 1.2 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.BrowserId, @@ -50,3 +50,7 @@ OpenId2.Types, OpenId2.XRDS ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/snoyberg/authenticate.git