authenticate 0.9.3.1 → 0.10.1
raw patch · 6 files changed
+73/−29 lines, 6 filesdep +aeson-nativedep −aesondep ~process
Dependencies added: aeson-native
Dependencies removed: aeson
Dependency ranges changed: process
Files
- OpenId2/Discovery.hs +5/−6
- OpenId2/XRDS.hs +1/−1
- Web/Authenticate/BrowserId.hs +0/−1
- Web/Authenticate/Internal.hs +0/−2
- Web/Authenticate/OAuth.hs +59/−15
- authenticate.cabal +8/−4
OpenId2/Discovery.hs view
@@ -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
OpenId2/XRDS.hs view
@@ -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
Web/Authenticate/BrowserId.hs view
@@ -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
Web/Authenticate/Internal.hs view
@@ -3,8 +3,6 @@ ( AuthenticateException (..) ) where -import Numeric (showHex)-import Data.List (intercalate) import Data.Typeable (Typeable) import Control.Exception (Exception)
Web/Authenticate/OAuth.hs view
@@ -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 }
authenticate.cabal view
@@ -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