authenticate 0.10.4 → 1.3.5.2
raw patch · 13 files changed
Files
- ChangeLog.md +29/−0
- LICENSE +17/−22
- OpenId2/Discovery.hs +62/−42
- OpenId2/Normalization.hs +4/−3
- README.md +5/−0
- Web/Authenticate/BrowserId.hs +19/−10
- Web/Authenticate/Facebook.hs +0/−115
- Web/Authenticate/Kerberos.hs +0/−72
- Web/Authenticate/OAuth.hs +0/−306
- Web/Authenticate/OpenId.hs +81/−34
- Web/Authenticate/OpenId/Providers.hs +1/−0
- Web/Authenticate/Rpxnow.hs +25/−22
- authenticate.cabal +33/−33
+ ChangeLog.md view
@@ -0,0 +1,29 @@+# authenticate changelog++## 1.3.5.2++* Support for aeson-2.2 [#61](https://github.com/yesodweb/authenticate/pull/61)++## 1.3.5.1++* Support for aeson-2.0 [#56](https://github.com/yesodweb/authenticate/pull/56)++## 1.3.5++* Drop tagstream-conduit dep (for GHC 8.8 support)++## 1.3.4++* Relaxed a bunch of type signatures++## 1.3.3.2++* Support for http-conduit-2.2.0 [#47](https://github.com/yesodweb/authenticate/issues/47)++## 1.3.3.1++* License update [#46](https://github.com/yesodweb/authenticate/issues/46)++## 1.3.3++Deprecated Google OpenID support
LICENSE view
@@ -1,25 +1,20 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright 2008, Michael Snoyman. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.+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: -* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.+The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+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.
OpenId2/Discovery.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- |@@ -22,77 +23,95 @@ import OpenId2.Types import OpenId2.XRDS -import Debug.Trace -- Libraries import Data.Char import Data.Maybe-import Network.HTTP.Enumerator+import Network.HTTP.Conduit import qualified Data.ByteString.Char8 as S8 import Control.Arrow (first) import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Failure (Failure (failure))-import Control.Monad (mplus, liftM)+import Control.Monad (mplus, liftM, guard) import qualified Data.CaseInsensitive as CI import Data.Text (Text, unpack) import Data.Text.Lazy (toStrict) import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)-import Text.HTML.TagSoup (parseTags, Tag (TagOpen)) import Control.Applicative ((<$>), (<*>))+import Network.HTTP.Types (status200)+import Control.Exception (throwIO)+import Text.HTML.DOM+import Text.XML.Cursor+import Text.XML (Node (..), Element (..))+import qualified Data.Map as Map data Discovery = Discovery1 Text (Maybe Text) | Discovery2 Provider Identifier IdentType deriving Show -- | Attempt to resolve an OpenID endpoint, and user identifier.-discover :: ( MonadIO m- , Failure AuthenticateException m- , Failure HttpException m- )- => Identifier- -> m Discovery-discover ident@(Identifier i) = do- res1 <- discoverYADIS ident Nothing 10+discover :: MonadIO m => Identifier -> Manager -> m Discovery+discover ident@(Identifier i) manager = do+ res1 <- discoverYADIS ident Nothing 10 manager case res1 of Just (x, y, z) -> return $ Discovery2 x y z Nothing -> do- res2 <- discoverHTML ident+ res2 <- discoverHTML ident manager case res2 of Just x -> return x- Nothing -> failure $ DiscoveryException $ unpack i+ Nothing -> liftIO $ throwIO $ DiscoveryException $ unpack i -- YADIS-Based Discovery ------------------------------------------------------- -- | Attempt a YADIS based discovery, given a valid identifier. The result is -- an OpenID endpoint, and the actual identifier for the user.-discoverYADIS :: ( MonadIO m- , Failure HttpException m- )+discoverYADIS :: MonadIO m => Identifier -> Maybe String -> Int -- ^ remaining redirects+ -> Manager -> m (Maybe (Provider, Identifier, IdentType))-discoverYADIS _ _ 0 = failure TooManyRedirects-discoverYADIS ident mb_loc redirects = do+discoverYADIS _ _ 0 _ =+#if MIN_VERSION_http_conduit(2, 2, 0)+ error "discoverYADIS: Too many redirects"+#else+ liftIO $ throwIO $ TooManyRedirects+#if MIN_VERSION_http_conduit(1,6,0)+ []+#endif+#endif+discoverYADIS ident mb_loc redirects manager = do let uri = fromMaybe (unpack $ identifier ident) mb_loc- req <- parseUrl uri- res <- liftIO $ withManager $ httpLbs req+#if MIN_VERSION_http_conduit(2, 2, 0)+ req <- liftIO $ parseRequest uri+#else+ req <- liftIO $ parseUrl uri+#endif+ res <- httpLbs req+#if !MIN_VERSION_http_conduit(2, 2, 0)+#if MIN_VERSION_http_conduit(1, 9, 0)+ { checkStatus = \_ _ _ -> Nothing+#else+ { checkStatus = \_ _ -> Nothing+#endif+ }+#endif+ manager let mloc = fmap S8.unpack $ lookup "x-xrds-location" $ map (first $ map toLower . S8.unpack . CI.original) $ responseHeaders res let mloc' = if mloc == mb_loc then Nothing else mloc- case statusCode res of- 200 ->+ if responseStatus res == status200+ then case mloc' of- Just loc -> discoverYADIS ident (Just loc) (redirects - 1)+ Just loc -> discoverYADIS ident (Just loc) (redirects - 1) manager Nothing -> do let mdoc = parseXRDS $ responseBody res case mdoc of Just doc -> return $ parseYADIS ident doc Nothing -> return Nothing- _ -> return Nothing+ else return Nothing -- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml@@ -120,21 +139,27 @@ -- | Attempt to discover an OpenID endpoint, from an HTML document. The result -- will be an endpoint on success, and the actual identifier of the user.-discoverHTML :: ( MonadIO m, Failure HttpException m)- => Identifier- -> m (Maybe Discovery)-discoverHTML ident'@(Identifier ident) =- (parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident)+discoverHTML :: MonadIO m => Identifier -> Manager -> m (Maybe Discovery)+discoverHTML ident'@(Identifier ident) manager = do+ req <- liftIO $ parseUrlThrow $ unpack ident+ lbs <- liftM responseBody $ httpLbs req manager+ return $ parseHTML ident' . toStrict . decodeUtf8With lenientDecode $ lbs -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. parseHTML :: Identifier -> Text -> Maybe Discovery-parseHTML ident = resolve- . filter isOpenId- . mapMaybe linkTag- . parseTags+parseHTML ident text0 = do+ let doc = parseSTChunks [text0]+ cursor = fromDocument doc+ links = map node $ cursor $// element "link"+ ls = do+ NodeElement (Element "link" as _) <- links+ Just rel <- pure $ Map.lookup "rel" as+ Just href <- pure $ Map.lookup "href" as+ guard $ "openid" `T.isPrefixOf` rel+ pure (rel, href)+ resolve ls where- isOpenId (rel, _x) = "openid" `T.isPrefixOf` rel resolve1 ls = do server <- lookup "openid.server" ls let delegate = lookup "openid.delegate" ls@@ -145,10 +170,5 @@ -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only -- result in a claimed identifier. return $ Discovery2 (Provider prov) lid ClaimedIdent- resolve ls = resolve2 ls `mplus` resolve1 ls ---- | Filter out link tags from a list of html tags.-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+ resolve ls = resolve2 ls `mplus` resolve1 ls
OpenId2/Normalization.hs view
@@ -21,18 +21,19 @@ import Control.Applicative import Control.Monad import Data.List-import Control.Failure (Failure (..)) import Network.URI ( uriToString, normalizeCase, normalizeEscape , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment ) import Data.Text (Text, pack, unpack)+import Control.Monad.IO.Class+import Control.Exception (throwIO) -normalize :: Failure AuthenticateException m => Text -> m Identifier+normalize :: MonadIO m => Text -> m Identifier normalize ident = case normalizeIdentifier $ Identifier ident of Just i -> return i- Nothing -> failure $ NormalizationException $ unpack ident+ Nothing -> liftIO $ throwIO $ NormalizationException $ unpack ident -- | Normalize an identifier, discarding XRIs. normalizeIdentifier :: Identifier -> Maybe Identifier
+ README.md view
@@ -0,0 +1,5 @@+## authenticate++Focus is on third-party authentication methods, such as OpenID and BrowserID.++Note: Facebook support is now provided by [the fb package](http://www.stackage.org/package/fb).
Web/Authenticate/BrowserId.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Web.Authenticate.BrowserId ( browserIdJs@@ -6,30 +7,38 @@ ) where import Data.Text (Text)-import Network.HTTP.Enumerator (parseUrl, responseBody, httpLbs, withManager, method, urlEncodedBody)+import Network.HTTP.Conduit (parseUrlThrow, responseBody, httpLbs, Manager, method, urlEncodedBody)+#if MIN_VERSION_aeson(2,2,0)+import Data.Aeson (Value (Object, String))+import Data.Aeson.Parser (json)+#else import Data.Aeson (json, Value (Object, String))+#endif import Data.Attoparsec.Lazy (parse, maybeResult)-#if MIN_VERSION_aeson(0, 4, 0)-import qualified Data.HashMap.Lazy as Map+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as Map #else-import qualified Data.Map as Map+import qualified Data.HashMap.Lazy as Map #endif import Data.Text.Encoding (encodeUtf8)+import Control.Monad.IO.Class (MonadIO, liftIO) -- | Location of the Javascript file hosted by browserid.org browserIdJs :: Text-browserIdJs = "https://browserid.org/include.js"+browserIdJs = "https://login.persona.org/include.js" -checkAssertion :: Text -- ^ audience+checkAssertion :: MonadIO m+ => Text -- ^ audience -> Text -- ^ assertion- -> IO (Maybe Text)-checkAssertion audience assertion = do- req' <- parseUrl "https://browserid.org/verify"+ -> Manager+ -> m (Maybe Text)+checkAssertion audience assertion manager = do+ req' <- liftIO $ parseUrlThrow "https://verifier.login.persona.org/verify" let req = urlEncodedBody [ ("audience", encodeUtf8 audience) , ("assertion", encodeUtf8 assertion) ] req' { method = "POST" }- res <- withManager $ httpLbs req+ res <- httpLbs req manager let lbs = responseBody res return $ maybeResult (parse json lbs) >>= getEmail where
− Web/Authenticate/Facebook.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-module Web.Authenticate.Facebook- ( Facebook (..)- , AccessToken (..)- , getForwardUrlParams- , getForwardUrlWithState- , getForwardUrl- , getAccessToken- , getGraphData- , getGraphData_- , getLogoutUrl- ) where--import Network.HTTP.Enumerator-import Network.HTTP.Types (parseSimpleQuery)-import Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as L8-import Data.Data (Data)-import Data.Typeable (Typeable)-import Control.Exception (Exception, throwIO)-import Data.Attoparsec.Lazy (parse, eitherResult)-import qualified Data.ByteString.Char8 as S8-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Blaze.ByteString.Builder (toByteString, copyByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromText)-import Network.HTTP.Types (renderQueryText)-import Data.Monoid (mappend)-import Data.ByteString (ByteString)-import Control.Arrow ((***))--data Facebook = Facebook- { facebookClientId :: Text- , facebookClientSecret :: Text- , facebookRedirectUri :: Text- }- deriving (Show, Eq, Read, Ord, Data, Typeable)--newtype AccessToken = AccessToken { unAccessToken :: Text }- deriving (Show, Eq, Read, Ord, Data, Typeable)--getForwardUrlParams :: Facebook -> [(Text, Text)] -> Text-getForwardUrlParams fb params =- TE.decodeUtf8 $ toByteString $- copyByteString "https://graph.facebook.com/oauth/authorize"- `mappend`- renderQueryText True- ( ("client_id", Just $ facebookClientId fb)- : ("redirect_uri", Just $ facebookRedirectUri fb)- : map (id *** Just) params)---- Internal function used to simplify getForwardUrl & getForwardUrlWithState-getForwardUrlWithExtra_ :: Facebook -> [Text] -> [(Text, Text)] -> Text-getForwardUrlWithExtra_ fb perms extra = getForwardUrlParams fb $ (if null perms- then id- else (("scope", T.intercalate "," perms):)) extra--getForwardUrlWithState :: Facebook -> [Text] -> Text -> Text-getForwardUrlWithState fb perms state = getForwardUrlWithExtra_ fb perms [("state", state)]--getForwardUrl :: Facebook -> [Text] -> Text-getForwardUrl fb perms = getForwardUrlWithExtra_ fb perms []--accessTokenUrl :: Facebook -> Text -> ByteString-accessTokenUrl fb code =- toByteString $- copyByteString "https://graph.facebook.com/oauth/access_token"- `mappend`- renderQueryText True- [ ("client_id", Just $ facebookClientId fb)- , ("redirect_uri", Just $ facebookRedirectUri fb)- , ("code", Just code)- , ("client_secret", Just $ facebookClientSecret fb)- ]--getAccessToken :: Facebook -> Text -> IO AccessToken-getAccessToken fb code = do- let url = accessTokenUrl fb code- b <- simpleHttp $ S8.unpack url- let params = parseSimpleQuery $ S8.concat $ L8.toChunks b- case lookup "access_token" params of- Just x -> return $ AccessToken $ T.pack $ S8.unpack x- Nothing -> error $ "Invalid facebook response: " ++ L8.unpack b--graphUrl :: AccessToken -> Text -> ByteString-graphUrl (AccessToken s) func =- toByteString $- copyByteString "https://graph.facebook.com/"- `mappend` fromText func- `mappend` renderQueryText True [("access_token", Just s)]--getGraphData :: AccessToken -> Text -> IO (Either String Value)-getGraphData at func = do- let url = graphUrl at func- b <- simpleHttp $ S8.unpack url- return $ eitherResult $ parse json b--getGraphData_ :: AccessToken -> Text -> IO Value-getGraphData_ a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return--data InvalidJsonException = InvalidJsonException String- deriving (Show, Typeable)-instance Exception InvalidJsonException---- | Logs out the user from their Facebook session.-getLogoutUrl :: AccessToken- -> Text -- ^ URL the user should be directed to in your site domain.- -> Text -- ^ Logout URL in @https://www.facebook.com/@.-getLogoutUrl (AccessToken s) next =- TE.decodeUtf8 $ toByteString $- copyByteString "https://www.facebook.com/logout.php"- `mappend` renderQueryText True [("next", Just next), ("access_token", Just s)]
− Web/Authenticate/Kerberos.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Module for using a kerberos authentication service.------ Please note that all configuration should have been done--- manually on the machine prior to running the code.------ On linux machines the configuration might be in /etc/krb5.conf.--- It's worth checking if the Kerberos service provider (e.g. your university)--- already provide a complete configuration file.------ Be certain that you can manually login from a shell by typing------ > kinit username------ If you fill in your password and the program returns no error code,--- then your kerberos configuration is setup properly.--- Only then can this module be of any use.-module Web.Authenticate.Kerberos- ( loginKerberos- , KerberosAuthResult(..)- ) where--import Data.Text (Text)-import qualified Data.Text as T-import Data.Maybe (fromJust)-import Control.Monad (msum, guard)-import System.Process (readProcessWithExitCode)-import System.Timeout (timeout)-import System.Exit (ExitCode(..))---- | Occurreable results of a Kerberos login-data KerberosAuthResult = Ok- | NoSuchUser- | WrongPassword- | TimeOut- | UnknownError Text--instance Show KerberosAuthResult where- show Ok = "Login sucessful"- show NoSuchUser = "Wrong username"- show WrongPassword = "Wrong password"- show TimeOut = "kinit respone timeout"- show (UnknownError msg) = "Unkown error: " ++ T.unpack msg----- Given the errcode and stderr, return error-value-interpretError :: Int -> Text -> KerberosAuthResult-interpretError _ errmsg = fromJust . msum $- ["Client not found in Kerberos database while getting" --> NoSuchUser,- "Preauthentication failed while getting" --> WrongPassword,- Just $ UnknownError errmsg]- where- substr --> kError = guard (substr `T.isInfixOf` errmsg) >> Just kError---- | Given the username and password, try login to Kerberos service-loginKerberos :: Text -- ^ Username- -> Text -- ^ Password- -> IO KerberosAuthResult-loginKerberos username password = do- timedFetch <- timeout (10*1000000) fetch- case timedFetch of- Just res -> return res- Nothing -> return TimeOut- where- fetch :: IO KerberosAuthResult- fetch = do- (exitCode, _out, err) <- readProcessWithExitCode- "kinit" [T.unpack username] (T.unpack password)- case exitCode of- ExitSuccess -> return Ok- ExitFailure x -> return $ interpretError x (T.pack err)-
− Web/Authenticate/OAuth.hs
@@ -1,306 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}-module Web.Authenticate.OAuth- ( -- * Data types- OAuth(..), SignMethod(..), Credential(..), OAuthException(..),- -- * Operations for credentials- emptyCredential, insert, delete, inserts,- -- * Signature- signOAuth, genSign,- -- * Url & operation for authentication- authorizeUrl, getAccessToken, getTemporaryCredential,- getTokenCredential, getTemporaryCredentialWithScope,- getAccessTokenProxy, getTemporaryCredentialProxy,- getTokenCredentialProxy, - getAccessToken', getTemporaryCredential',- -- * Utility Methods- paramEncode, addScope, addMaybeProxy- ) where-import Network.HTTP.Enumerator-import Data.Data-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.Maybe-import Control.Applicative-import Network.HTTP.Types (parseSimpleQuery)-import Control.Exception-import Control.Monad-import Data.List (sortBy)-import System.Random-import Data.Char-import Data.Digest.Pure.SHA-import Data.ByteString.Base64-import Data.Time-import Numeric-import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..))-import Network.HTTP.Types (Header)-import Control.Arrow (second)-import Blaze.ByteString.Builder (toByteString)-import Data.Enumerator (($$), run_, Stream (..), continue)-import Data.Monoid (mconcat)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Data.IORef (newIORef, readIORef, atomicModifyIORef)-import Network.HTTP.Types (renderSimpleQuery)---- | Data type for OAuth client (consumer).-data OAuth = OAuth { oauthServerName :: String -- ^ Service name- , oauthRequestUri :: String -- ^ URI to request temporary credential- , oauthAccessTokenUri :: String -- ^ Uri to obtain access token- , oauthAuthorizeUri :: String -- ^ Uri to authorize- , oauthSignatureMethod :: SignMethod -- ^ Signature Method- , oauthConsumerKey :: BS.ByteString -- ^ Consumer key- , oauthConsumerSecret :: BS.ByteString -- ^ Consumer Secret- , oauthCallback :: Maybe BS.ByteString -- ^ Callback uri to redirect after authentication- } deriving (Show, Eq, Ord, Read, Data, Typeable)----- | Data type for signature method.-data SignMethod = PLAINTEXT- | HMACSHA1- | RSASHA1 PrivateKey- deriving (Show, Eq, Ord, Read, Data, Typeable)--deriving instance Typeable PrivateKey-deriving instance Data PrivateKey-deriving instance Read PrivateKey-deriving instance Ord PrivateKey-deriving instance Eq PrivateKey---- | Data type for redential.-data Credential = Credential { unCredential :: [(BS.ByteString, BS.ByteString)] }- deriving (Show, Eq, Ord, Read, Data, Typeable)---- | Empty credential.-emptyCredential :: Credential-emptyCredential = Credential []--token, tokenSecret :: Credential -> BS.ByteString-token = fromMaybe "" . lookup "oauth_token" . unCredential-tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential--data OAuthException = OAuthException String- deriving (Show, Eq, Data, Typeable)--instance Exception OAuthException--toStrict :: BSL.ByteString -> BS.ByteString-toStrict = BS.concat . BSL.toChunks--fromStrict :: BS.ByteString -> BSL.ByteString-fromStrict = BSL.fromChunks . return---- | Get temporary credential for requesting acces token.-getTemporaryCredential :: OAuth -- ^ OAuth Application- -> IO Credential -- ^ Temporary Credential (Request Token & Secret).-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- 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- return $ Credential dic- else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp)---- | URL to obtain OAuth verifier.-authorizeUrl :: OAuth -- ^ OAuth Application- -> Credential -- ^ Temporary Credential (Request Token & Secret)- -> String -- ^ URL to authorize-authorizeUrl oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True queries)- where queries = case oauthCallback oa of- Nothing -> [("oauth_token", token cr)]- Just callback -> [("oauth_token", token cr), ("oauth_callback", callback)]---- | Get Access token.-getAccessToken, getTokenCredential- :: OAuth -- ^ OAuth Application- -> Credential -- ^ Temporary Credential with oauth_verifier- -> IO Credential -- ^ Token Credential (Access Token & Secret)-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 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)--deleteMap :: Eq a => a -> [(a,b)] -> [(a,b)]-deleteMap k = filter ((/=k).fst)---- | Insert an oauth parameter into given 'Credential'.-insert :: BS.ByteString -- ^ Parameter Name- -> BS.ByteString -- ^ Value- -> Credential -- ^ Credential- -> Credential -- ^ Result-insert k v = Credential . insertMap k v . unCredential---- | Convenient method for inserting multiple parameters into credential.-inserts :: [(BS.ByteString, BS.ByteString)] -> Credential -> Credential-inserts = flip $ foldr (uncurry insert)---- | Remove an oauth parameter for key from given 'Credential'.-delete :: BS.ByteString -- ^ Parameter name- -> Credential -- ^ Credential- -> Credential -- ^ Result-delete key = Credential . deleteMap key . unCredential---- | Add OAuth headers & sign to 'Request'.-signOAuth :: OAuth -- ^ OAuth Application- -> Credential -- ^ Credential- -> Request IO -- ^ Original Request- -> IO (Request IO) -- ^ Signed OAuth Request-signOAuth oa crd req = do- crd' <- addTimeStamp =<< addNonce crd- let tok = injectOAuthToCred oa crd'- sign <- genSign oa tok req- return $ addAuthHeader (insert "oauth_signature" sign tok) req--baseTime :: UTCTime-baseTime = UTCTime day 0- where- day = ModifiedJulianDay 40587--showSigMtd :: SignMethod -> BS.ByteString-showSigMtd PLAINTEXT = "PLAINTEXT"-showSigMtd HMACSHA1 = "HMAC-SHA1"-showSigMtd (RSASHA1 _) = "RSA-SHA1"--addNonce :: Credential -> IO Credential-addNonce cred = do- nonce <- replicateM 10 (randomRIO ('a','z'))- return $ insert "oauth_nonce" (BS.pack nonce) cred--addTimeStamp :: Credential -> IO Credential-addTimeStamp cred = do- stamp <- floor . (`diffUTCTime` baseTime) <$> getCurrentTime :: IO Integer- return $ insert "oauth_timestamp" (BS.pack $ show stamp) cred--injectOAuthToCred :: OAuth -> Credential -> Credential-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 =- case oauthSignatureMethod oa of- HMACSHA1 -> do- text <- getBaseString tok req- let key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]- return $ encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text- PLAINTEXT ->- return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]- RSASHA1 pr ->- liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req)--addAuthHeader :: Credential -> Request a -> Request a-addAuthHeader (Credential cred) req =- req { requestHeaders = insertMap "Authorization" (renderAuthHeader cred) $ requestHeaders req }--renderAuthHeader :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString-renderAuthHeader = ("OAuth " `BS.append`). BS.intercalate "," . map (\(a,b) -> BS.concat [paramEncode a, "=\"", paramEncode b, "\""]) . filter ((`elem` ["realm", "oauth_token", "oauth_verifier", "oauth_consumer_key", "oauth_signature_method", "oauth_timestamp", "oauth_nonce", "oauth_version", "oauth_callback", "oauth_signature"]) . fst)---- | Encode a string using the percent encoding method for OAuth.-paramEncode :: BS.ByteString -> BS.ByteString-paramEncode = BS.concatMap escape- where- escape c | isAscii c && (isAlpha c || isDigit c || c `elem` "-._~") = BS.singleton c- | otherwise = let num = map toUpper $ showHex (ord c) ""- oct = '%' : replicate (2 - length num) '0' ++ num- in BS.pack oct--getBaseString :: MonadIO m => Credential -> Request m -> m BSL.ByteString-getBaseString tok req = do- let bsMtd = BS.map toUpper $ method req- isHttps = secure req- scheme = if isHttps then "https" else "http"- bsPort = if (isHttps && port req /= 443) || (not isHttps && port req /= 80)- then ':' `BS.cons` BS.pack (show $ port req) else ""- bsURI = BS.concat [scheme, "://", host req, bsPort, path req]- bsQuery = map (second $ fromMaybe "") $ queryString req- bsBodyQ <- if isBodyFormEncoded $ requestHeaders req- then liftM parseSimpleQuery $ toLBS (requestBody req)- else return []- let bsAuthParams = filter ((`elem`["oauth_consumer_key","oauth_token", "oauth_version","oauth_signature_method","oauth_timestamp", "oauth_nonce", "oauth_verifier", "oauth_version","oauth_callback"]).fst) $ unCredential tok- allParams = bsQuery++bsBodyQ++bsAuthParams- bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple- $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams- -- 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-toLBS (RequestBodyLBS l) = return $ toStrict l-toLBS (RequestBodyBS s) = return s-toLBS (RequestBodyBuilder _ b) = return $ toByteString b-toLBS (RequestBodyEnum _ enum) = do- i <- liftIO $ newIORef id- run_ $ enum $$ go i- liftIO $ liftM (toByteString . mconcat . ($ [])) $ readIORef i- where- go i =- continue go'- where- go' (Chunks []) = continue go'- go' (Chunks x) = do- liftIO (atomicModifyIORef i $ \y -> (y . (x ++), ()))- continue go'- go' EOF = return ()--isBodyFormEncoded :: [Header] -> Bool-isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"--compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering-compareTuple (a,b) (c,d) =- case compare a c of- LT -> LT- EQ -> compare b d- GT -> GT--addMaybeProxy :: Maybe Proxy -> Request m -> Request m-addMaybeProxy p req = req { proxy = p }
Web/Authenticate/OpenId.hs view
@@ -1,24 +1,32 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Web.Authenticate.OpenId- ( getForwardUrl+ ( -- * Functions+ getForwardUrl , authenticate+ , authenticateClaimed+ -- * Types , AuthenticateException (..) , Identifier (..)+ -- ** Response+ , OpenIdResponse+ , oirOpLocal+ , oirParams+ , oirClaimed ) where import Control.Monad.IO.Class import OpenId2.Normalization (normalize) import OpenId2.Discovery (discover, Discovery (..))-import Control.Failure (Failure (failure)) import OpenId2.Types import Control.Monad (unless)+import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Lazy (toStrict)-import Network.HTTP.Enumerator- ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect- , HttpException, withManager+import Network.HTTP.Conduit+ ( parseUrlThrow, urlEncodedBody, responseBody, httpLbs+ , Manager ) import Control.Arrow ((***), second) import Data.List (unfoldr)@@ -27,54 +35,73 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Blaze.ByteString.Builder (toByteString) import Network.HTTP.Types (renderQueryText)-import Data.Monoid (mappend)+import Control.Exception (throwIO) getForwardUrl- :: ( MonadIO m- , Failure AuthenticateException m- , Failure HttpException m- )+ :: MonadIO m => Text -- ^ The openid the user provided. -> Text -- ^ The URL for this application\'s complete page. -> Maybe Text -- ^ Optional realm -> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.+ -> Manager -> m Text -- ^ URL to send the user to.-getForwardUrl openid' complete mrealm params = do+getForwardUrl openid' complete mrealm params manager = do let realm = fromMaybe complete mrealm- disc <- normalize openid' >>= discover- let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q)+ claimed <- normalize $ T.strip openid'+ disc <- discover claimed manager+ let helper s q = return $ T.concat+ [ s+ , if "?" `T.isInfixOf` s then "&" else "?"+ , decodeUtf8 (toByteString $ renderQueryText False $ map (second Just) q)+ ] case disc of Discovery1 server mdelegate -> helper server $ ("openid.mode", "checkid_setup")- : ("openid.identity", maybe openid' id mdelegate)+ : ("openid.identity", maybe (identifier claimed) id mdelegate) : ("openid.return_to", complete) : ("openid.realm", realm) : ("openid.trust_root", complete) : params Discovery2 (Provider p) (Identifier i) itype -> do- let i' =+ let (claimed', identity') = case itype of- ClaimedIdent -> i- OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select"+ ClaimedIdent -> (identifier claimed, i)+ OPIdent ->+ let x = "http://specs.openid.net/auth/2.0/identifier_select"+ in (x, x) helper p $ ("openid.ns", "http://specs.openid.net/auth/2.0") : ("openid.mode", "checkid_setup")- : ("openid.claimed_id", i')- : ("openid.identity", i')+ : ("openid.claimed_id", claimed')+ : ("openid.identity", identity') : ("openid.return_to", complete) : ("openid.realm", realm) : params authenticate- :: ( MonadIO m- , Failure AuthenticateException m- , Failure HttpException m- )+ :: MonadIO m => [(Text, Text)]+ -> Manager -> m (Identifier, [(Text, Text)])-authenticate params = do+authenticate ps m = do+ x <- authenticateClaimed ps m+ return (oirOpLocal x, oirParams x)+{-# DEPRECATED authenticate "Use authenticateClaimed" #-}++data OpenIdResponse = OpenIdResponse+ { oirOpLocal :: Identifier+ , oirParams :: [(Text, Text)]+ , oirClaimed :: Maybe Identifier+ }++authenticateClaimed+ :: MonadIO m+ => [(Text, Text)]+ -> Manager+ -> m OpenIdResponse+authenticateClaimed params manager = do unless (lookup "openid.mode" params == Just "id_res")- $ failure $ case lookup "openid.mode" params of+ $ liftIO $ throwIO $ case lookup "openid.mode" params of Nothing -> AuthenticationException "openid.mode was not found in the params." (Just m) | m == "error" ->@@ -85,21 +112,41 @@ ident <- case lookup "openid.identity" params of Just i -> return i Nothing ->- failure $ AuthenticationException "Missing identity"- disc <- normalize ident >>= discover- let endpoint = case disc of- Discovery1 p _ -> p- Discovery2 (Provider p) _ _ -> p+ liftIO $ throwIO $ AuthenticationException "Missing identity"+ discOP <- normalize ident >>= flip discover manager++ let endpoint d =+ case d of+ Discovery1 p _ -> p+ Discovery2 (Provider p) _ _ -> p let params' = map (encodeUtf8 *** encodeUtf8) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params- req' <- parseUrl $ unpack endpoint+ req' <- liftIO $ parseUrlThrow $ unpack $ endpoint discOP let req = urlEncodedBody params' req'- rsp <- liftIO $ withManager $ httpLbsRedirect req+ rsp <- httpLbs req manager let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp++ claimed <-+ case lookup "openid.claimed_id" params of+ Nothing -> return Nothing+ Just claimed' -> do+ -- need to validate that this provider can speak for the given+ -- claimed identifier+ claimedN <- normalize claimed'+ discC <- discover claimedN manager+ return $+ if endpoint discOP == endpoint discC+ then Just claimedN+ else Nothing+ case lookup "is_valid" rps of- Just "true" -> return (Identifier ident, rps)- _ -> failure $ AuthenticationException "OpenID provider did not validate"+ Just "true" -> return OpenIdResponse+ { oirOpLocal = Identifier ident+ , oirParams = rps+ , oirClaimed = claimed+ }+ _ -> liftIO $ throwIO $ AuthenticationException "OpenID provider did not validate" -- | Turn a response body into a list of parameters. parseDirectResponse :: Text -> [(Text, Text)]
Web/Authenticate/OpenId/Providers.hs view
@@ -15,6 +15,7 @@ google :: String google = "https://www.google.com/accounts/o8/id"+{-# DEPRECATED google "Google no longer provides OpenID support" #-} yahoo :: String yahoo = "http://me.yahoo.com/"
Web/Authenticate/Rpxnow.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} ---------------------------------------------------------@@ -23,14 +22,15 @@ ) where import Data.Aeson-import Network.HTTP.Enumerator-import "transformers" Control.Monad.IO.Class-import Control.Failure+#if MIN_VERSION_aeson(2,2,0)+import Data.Aeson.Parser (json)+#endif+import Network.HTTP.Conduit+import Control.Monad.IO.Class import Data.Maybe import Control.Monad import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L-import Control.Exception (throwIO) import Web.Authenticate.Internal import Data.Data (Data) import Data.Typeable (Typeable)@@ -38,12 +38,14 @@ import qualified Data.Attoparsec.Lazy as AT import Data.Text (Text) import qualified Data.Aeson.Types-#if MIN_VERSION_aeson(0, 4, 0)-import qualified Data.HashMap.Lazy as Map+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as Map+import qualified Data.Aeson.Key as Key #else-import qualified Data.Map as Map+import qualified Data.HashMap.Lazy as Map #endif import Control.Applicative ((<$>), (<*>))+import Control.Exception (throwIO) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier@@ -53,20 +55,19 @@ deriving (Eq, Ord, Read, Show, Data, Typeable) -- | Attempt to log a user in.-authenticate :: (MonadIO m,- Failure HttpException m,- Failure AuthenticateException m)+authenticate :: MonadIO m => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client.+ -> Manager -> m Identifier-authenticate apiKey token = do+authenticate apiKey token manager = do let body = L.fromChunks [ "apiKey=" , S.pack apiKey , "&token=" , S.pack token ]- req' <- parseUrl "https://rpxnow.com"+ req' <- liftIO $ parseUrlThrow "https://rpxnow.com" let req = req' { method = "POST"@@ -76,10 +77,8 @@ ] , requestBody = RequestBodyLBS body }- res <- liftIO $ withManager $ httpLbsRedirect req+ res <- httpLbs req manager let b = responseBody res- unless (200 <= statusCode res && statusCode res < 300) $- liftIO $ throwIO $ StatusCodeException (statusCode res) b o <- unResult $ parse json b --m <- fromMapping o let mstat = flip Data.Aeson.Types.parse o $ \v ->@@ -88,15 +87,15 @@ _ -> mzero case mstat of Success "ok" -> return ()- Success stat -> failure $ RpxnowException $+ Success stat -> liftIO $ throwIO $ RpxnowException $ "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b- _ -> failure $ RpxnowException "Now stat value found on Rpxnow response"+ _ -> liftIO $ throwIO $ RpxnowException "Now stat value found on Rpxnow response" case Data.Aeson.Types.parse parseProfile o of Success x -> return x- Error e -> failure $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e+ Error e -> liftIO $ throwIO $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e -unResult :: Failure AuthenticateException m => AT.Result a -> m a-unResult = either (failure . RpxnowException) return . AT.eitherResult+unResult :: MonadIO m => AT.Result a -> m a+unResult = either (liftIO . throwIO . RpxnowException) return . AT.eitherResult parseProfile :: Value -> Data.Aeson.Types.Parser Identifier parseProfile (Object m) = do@@ -106,6 +105,10 @@ <*> return (mapMaybe go (Map.toList profile)) where go ("identifier", _) = Nothing- go (k, String v) = Just (k, v)+ go (k, String v) = Just (+#if MIN_VERSION_aeson(2,0,0)+ Key.toText+#endif+ k, v) go _ = Nothing parseProfile _ = mzero
authenticate.cabal view
@@ -1,56 +1,56 @@ name: authenticate-version: 0.10.4-license: BSD3+version: 1.3.5.2+license: MIT license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani maintainer: Michael Snoyman <michael@snoyman.com> synopsis: Authentication methods for Haskell web applications.-description: Focus is on third-party authentication methods, such as OpenID,- rpxnow and Facebook.+description: API docs and the README are available at <http://www.stackage.org/package/authenticate>. category: Web stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.10 build-type: Simple homepage: http://github.com/yesodweb/authenticate+extra-source-files: README.md ChangeLog.md +flag network-uri+ description: Get Network.URI from the network-uri package+ default: True+ library- build-depends: base >= 4 && < 5,- aeson >= 0.3.2.11,- http-enumerator >= 0.6.5.4 && < 0.8,- tagsoup >= 0.12 && < 0.13,- failure >= 0.0.0 && < 0.2,- transformers >= 0.1 && < 0.3,- bytestring >= 0.9 && < 0.10,- network >= 2.2.1 && < 2.4,- case-insensitive >= 0.2,- RSA >= 1.0 && < 1.1,- time >= 1.1,- base64-bytestring >= 0.1 && < 0.2,- SHA >= 1.4 && < 1.6,- random >= 1.0 && < 1.1,- text >= 0.5 && < 1.0,- http-types >= 0.6 && < 0.7,- enumerator >= 0.4.7 && < 0.5,- xml-enumerator >= 0.4 && < 0.5,- blaze-builder >= 0.2 && < 0.4,- attoparsec >= 0.9,- tls >= 0.7 && < 0.9,- containers,- unordered-containers,- process >= 1.0.1.1 && < 1.2+ default-language: Haskell2010+ build-depends: base >= 4.10 && < 5+ , aeson >= 0.5+ , attoparsec-aeson >= 2.1+ , http-conduit >= 1.5+ , transformers >= 0.1+ , bytestring >= 0.9+ , case-insensitive >= 0.2+ , text+ , http-types >= 0.6+ , xml-conduit >= 1.0+ , blaze-builder+ , attoparsec+ , containers+ , unordered-containers+ , conduit >= 0.5+ , html-conduit >= 1.3+ , resourcet exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.BrowserId,- Web.Authenticate.OpenId.Providers,- Web.Authenticate.OAuth,- Web.Authenticate.Facebook- Web.Authenticate.Kerberos+ Web.Authenticate.OpenId.Providers other-modules: Web.Authenticate.Internal, OpenId2.Discovery, OpenId2.Normalization, OpenId2.Types, OpenId2.XRDS ghc-options: -Wall++ if flag(network-uri)+ build-depends: network-uri >= 2.6+ else+ build-depends: network < 2.6 source-repository head type: git