From 66e9e203f87caee1da382ccf1835de5131ac35b7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 27 Mar 2014 17:40:58 +0200 Subject: [PATCH] Remove some old files --- .gitmodules | 3 - authenticate-oauth/.gitignore | 6 - authenticate-oauth/LICENSE | 25 - authenticate-oauth/Setup.lhs | 7 - authenticate-oauth/Web/Authenticate/OAuth.hs | 455 ------------------ .../Web/Authenticate/OAuth/IO.hs | 95 ---- authenticate-oauth/authenticate-oauth.cabal | 39 -- authenticate/LICENSE | 25 - authenticate/OpenId2/Discovery.hs | 159 ------ authenticate/OpenId2/Normalization.hs | 69 --- authenticate/OpenId2/Types.hs | 34 -- authenticate/OpenId2/XRDS.hs | 77 --- authenticate/Setup.lhs | 7 - authenticate/Web/Authenticate/BrowserId.hs | 40 -- authenticate/Web/Authenticate/Internal.hs | 15 - authenticate/Web/Authenticate/OpenId.hs | 164 ------- .../Web/Authenticate/OpenId/Providers.hs | 44 -- authenticate/Web/Authenticate/Rpxnow.hs | 103 ---- authenticate/authenticate.cabal | 48 -- authenticate/browserid.hs | 45 -- authenticate/openid2.hs | 91 ---- authenticate/rpxnow.hs | 38 -- package-list.sh | 15 - scripts | 1 - sources.txt | 1 - 25 files changed, 1606 deletions(-) delete mode 100644 .gitmodules delete mode 100644 authenticate-oauth/.gitignore delete mode 100644 authenticate-oauth/LICENSE delete mode 100755 authenticate-oauth/Setup.lhs delete mode 100644 authenticate-oauth/Web/Authenticate/OAuth.hs delete mode 100644 authenticate-oauth/Web/Authenticate/OAuth/IO.hs delete mode 100644 authenticate-oauth/authenticate-oauth.cabal delete mode 100644 authenticate/LICENSE delete mode 100644 authenticate/OpenId2/Discovery.hs delete mode 100644 authenticate/OpenId2/Normalization.hs delete mode 100644 authenticate/OpenId2/Types.hs delete mode 100644 authenticate/OpenId2/XRDS.hs delete mode 100755 authenticate/Setup.lhs delete mode 100644 authenticate/Web/Authenticate/BrowserId.hs delete mode 100644 authenticate/Web/Authenticate/Internal.hs delete mode 100644 authenticate/Web/Authenticate/OpenId.hs delete mode 100644 authenticate/Web/Authenticate/OpenId/Providers.hs delete mode 100644 authenticate/Web/Authenticate/Rpxnow.hs delete mode 100644 authenticate/authenticate.cabal delete mode 100644 authenticate/browserid.hs delete mode 100644 authenticate/openid2.hs delete mode 100644 authenticate/rpxnow.hs delete mode 100644 package-list.sh delete mode 160000 scripts diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index 91468aac..00000000 --- a/.gitmodules +++ /dev/null @@ -1,3 +0,0 @@ -[submodule "scripts"] - path = scripts - url = git://github.com/yesodweb/scripts.git diff --git a/authenticate-oauth/.gitignore b/authenticate-oauth/.gitignore deleted file mode 100644 index 0d82556e..00000000 --- a/authenticate-oauth/.gitignore +++ /dev/null @@ -1,6 +0,0 @@ -.DS_Store -*.hi -*.o -dist -*~ -cabal-dev diff --git a/authenticate-oauth/LICENSE b/authenticate-oauth/LICENSE deleted file mode 100644 index 11dc17a1..00000000 --- a/authenticate-oauth/LICENSE +++ /dev/null @@ -1,25 +0,0 @@ -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: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* 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. - -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. diff --git a/authenticate-oauth/Setup.lhs b/authenticate-oauth/Setup.lhs deleted file mode 100755 index 06e2708f..00000000 --- a/authenticate-oauth/Setup.lhs +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff --git a/authenticate-oauth/Web/Authenticate/OAuth.hs b/authenticate-oauth/Web/Authenticate/OAuth.hs deleted file mode 100644 index e7dc6dbe..00000000 --- a/authenticate-oauth/Web/Authenticate/OAuth.hs +++ /dev/null @@ -1,455 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving, FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -module Web.Authenticate.OAuth - ( -- * Data types - OAuth, def, newOAuth, oauthServerName, oauthRequestUri, oauthAccessTokenUri, - oauthAuthorizeUri, oauthSignatureMethod, oauthConsumerKey, - oauthConsumerSecret, oauthCallback, oauthRealm, oauthVersion, - OAuthVersion(..), SignMethod(..), Credential(..), OAuthException(..), - -- * Operations for credentials - newCredential, emptyCredential, insert, delete, inserts, injectVerifier, - -- * Signature - signOAuth, genSign, - -- * Url & operation for authentication - authorizeUrl, authorizeUrl', getAccessToken, getTemporaryCredential, - getTokenCredential, getTemporaryCredentialWithScope, - getAccessTokenProxy, getTemporaryCredentialProxy, - getTokenCredentialProxy, - getAccessToken', getTemporaryCredential', - -- * Utility Methods - paramEncode, addScope, addMaybeProxy - ) where -import Network.HTTP.Conduit -import Data.Data -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.Maybe -import Network.HTTP.Types (parseSimpleQuery, SimpleQuery) -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 -#if MIN_VERSION_RSA(2, 0, 0) -import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, hashSHA1) -#else -import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1) -#endif -import Crypto.Types.PubKey.RSA (PrivateKey(..), PublicKey(..)) -import Network.HTTP.Types (Header) -import Blaze.ByteString.Builder (toByteString) -import Control.Monad.IO.Class (MonadIO) -import Network.HTTP.Types (renderSimpleQuery, status200) -import Data.Conduit (($$), ($=), Source) -import qualified Data.Conduit.List as CL -import Data.Conduit.Blaze (builderToByteString) -import Blaze.ByteString.Builder (Builder) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Control -import Control.Monad.Trans.Resource -import Data.Default -import qualified Data.IORef as I - --- | Data type for OAuth client (consumer). --- --- The constructor for this data type is not exposed. --- Instead, you should use the 'def' method or 'newOAuth' function to retrieve a default instance, --- and then use the records below to make modifications. --- This approach allows us to add configuration options without breaking backwards compatibility. -data OAuth = OAuth { oauthServerName :: String -- ^ Service name (default: @\"\"@) - , oauthRequestUri :: String - -- ^ URI to request temporary credential (default: @\"\"@). - -- You MUST specify if you use 'getTemporaryCredential'', 'getTemporaryCredentialProxy' - -- or 'getTemporaryCredential'; otherwise you can just leave this empty. - , oauthAccessTokenUri :: String - -- ^ Uri to obtain access token (default: @\"\"@). - -- You MUST specify if you use 'getAcessToken' or 'getAccessToken''; - -- otherwise you can just leave this empty. - , oauthAuthorizeUri :: String - -- ^ Uri to authorize (default: @\"\"@). - -- You MUST specify if you use 'authorizeUrl' or 'authorizeZUrl''; - -- otherwise you can just leave this empty. - , oauthSignatureMethod :: SignMethod - -- ^ Signature Method (default: 'HMACSHA1') - , oauthConsumerKey :: BS.ByteString - -- ^ Consumer key (You MUST specify) - , oauthConsumerSecret :: BS.ByteString - -- ^ Consumer Secret (You MUST specify) - , oauthCallback :: Maybe BS.ByteString - -- ^ Callback uri to redirect after authentication (default: @Nothing@) - , oauthRealm :: Maybe BS.ByteString - -- ^ Optional authorization realm (default: @Nothing@) - , oauthVersion :: OAuthVersion - -- ^ OAuth spec version (default: 'OAuth10a') - } deriving (Show, Eq, Ord, Read, Data, Typeable) - -data OAuthVersion = OAuth10 -- ^ OAuth protocol ver 1.0 (no oauth_verifier; differs from RFC 5849). - | OAuth10a -- ^ OAuth protocol ver 1.0a. This corresponds to community's 1.0a spec and RFC 5849. - deriving (Show, Eq, Ord, Data, Typeable, Read) - --- | Default value for OAuth datatype. --- You must specify at least oauthServerName, URIs and Tokens. -newOAuth :: OAuth -newOAuth = OAuth { oauthSignatureMethod = HMACSHA1 - , oauthCallback = Nothing - , oauthRealm = Nothing - , oauthServerName = "" - , oauthRequestUri = "" - , oauthAccessTokenUri = "" - , oauthAuthorizeUri = "" - , oauthConsumerKey = error "You MUST specify oauthConsumerKey parameter." - , oauthConsumerSecret = error "You MUST specify oauthConsumerSecret parameter." - , oauthVersion = OAuth10a - } - -instance Default OAuth where - def = newOAuth - --- | Data type for signature method. -data SignMethod = PLAINTEXT - | HMACSHA1 - | RSASHA1 PrivateKey - deriving (Show, Eq, Ord, Read, Data, Typeable) -deriving instance Ord PrivateKey -deriving instance Ord PublicKey - --- | 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 [] - --- | Convenient function to create 'Credential' with OAuth Token and Token Secret. -newCredential :: BS.ByteString -- ^ value for oauth_token - -> BS.ByteString -- ^ value for oauth_token_secret - -> Credential -newCredential tok sec = Credential [("oauth_token", tok), ("oauth_token_secret", sec)] - -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 :: (MonadResource m, MonadBaseControl IO m) - => OAuth -- ^ OAuth Application - -> Manager - -> m Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredential = getTemporaryCredential' id - --- | Get temporary credential for requesting access token with Scope parameter. -getTemporaryCredentialWithScope :: (MonadResource m, MonadBaseControl IO m) - => BS.ByteString -- ^ Scope parameter string - -> OAuth -- ^ OAuth Application - -> Manager - -> m Credential -- ^ Temporay Credential (Request Token & Secret). -getTemporaryCredentialWithScope bs = getTemporaryCredential' (addScope bs) - -#if MIN_VERSION_http_conduit(2, 0, 0) -addScope :: BS.ByteString -> Request -> Request -#else -addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m -#endif -addScope scope req | BS.null scope = req - | otherwise = urlEncodedBody [("scope", scope)] req - --- | Get temporary credential for requesting access token via the proxy. -getTemporaryCredentialProxy :: (MonadResource m, MonadBaseControl IO m) - => Maybe Proxy -- ^ Proxy - -> OAuth -- ^ OAuth Application - -> Manager - -> m Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredentialProxy p oa m = getTemporaryCredential' (addMaybeProxy p) oa m - -getTemporaryCredential' :: (MonadResource m, MonadBaseControl IO m) -#if MIN_VERSION_http_conduit(2, 0, 0) - => (Request -> Request) -- ^ Request Hook -#else - => (Request m -> Request m) -- ^ Request Hook -#endif - -> OAuth -- ^ OAuth Application - -> Manager - -> m Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredential' hook oa manager = 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 <- httpLbs req' manager - if responseStatus rsp == status200 - then do - let dic = parseSimpleQuery . toStrict . responseBody $ rsp - return $ Credential dic - else liftIO . 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 = authorizeUrl' $ \oa -> const [("oauth_consumer_key", oauthConsumerKey oa)] - --- | Convert OAuth and Credential to URL to authorize. --- This takes function to choice parameter to pass to the server other than --- /oauth_callback/ or /oauth_token/. -authorizeUrl' :: (OAuth -> Credential -> SimpleQuery) - -> OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential (Request Token & Secret) - -> String -- ^ URL to authorize -authorizeUrl' f oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True queries) - where fixed = ("oauth_token", token cr):f oa cr - queries = - case oauthCallback oa of - Nothing -> fixed - Just callback -> ("oauth_callback", callback):fixed - - --- | Get Access token. -getAccessToken, getTokenCredential - :: (MonadResource m, MonadBaseControl IO m) - => OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a) - -> Manager - -> m Credential -- ^ Token Credential (Access Token & Secret) -getAccessToken = getAccessToken' id - --- | Get Access token via the proxy. -getAccessTokenProxy, getTokenCredentialProxy - :: (MonadResource m, MonadBaseControl IO m) - => Maybe Proxy -- ^ Proxy - -> OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a) - -> Manager - -> m Credential -- ^ Token Credential (Access Token & Secret) -getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p - -getAccessToken' :: (MonadResource m, MonadBaseControl IO m) -#if MIN_VERSION_http_conduit(2, 0, 0) - => (Request -> Request) -- ^ Request Hook -#else - => (Request m -> Request m) -- ^ Request Hook -#endif - -> OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a) - -> Manager - -> m Credential -- ^ Token Credential (Access Token & Secret) -getAccessToken' hook oa cr manager = do - let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } - rsp <- flip httpLbs manager =<< signOAuth oa (if oauthVersion oa == OAuth10 then delete "oauth_verifier" cr else cr) req - if responseStatus rsp == status200 - then do - let dic = parseSimpleQuery . toStrict . responseBody $ rsp - return $ Credential dic - else liftIO . 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 - -injectVerifier :: BS.ByteString -> Credential -> Credential -injectVerifier = insert "oauth_verifier" - --- | Add OAuth headers & sign to 'Request'. -signOAuth :: (MonadUnsafeIO m) - => OAuth -- ^ OAuth Application - -> Credential -- ^ Credential -#if MIN_VERSION_http_conduit(2, 0, 0) - -> Request -- ^ Original Request - -> m Request -- ^ Signed OAuth Request -#else - -> Request m -- ^ Original Request - -> m (Request m) -- ^ Signed OAuth Request -#endif -signOAuth oa crd req = do - crd' <- addTimeStamp =<< addNonce crd - let tok = injectOAuthToCred oa crd' - sign <- genSign oa tok req - return $ addAuthHeader prefix (insert "oauth_signature" sign tok) req - where - prefix = case oauthRealm oa of - Nothing -> "OAuth " - Just v -> "OAuth realm=\"" `BS.append` v `BS.append` "\"," - -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 :: MonadUnsafeIO m => Credential -> m Credential -addNonce cred = do - nonce <- unsafeLiftIO $ replicateM 10 (randomRIO ('a','z')) -- FIXME very inefficient - return $ insert "oauth_nonce" (BS.pack nonce) cred - -addTimeStamp :: MonadUnsafeIO m => Credential -> m Credential -addTimeStamp cred = do - stamp <- (floor . (`diffUTCTime` baseTime)) `liftM` unsafeLiftIO getCurrentTime - return $ insert "oauth_timestamp" (BS.pack $ show (stamp :: Integer)) 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 - -#if MIN_VERSION_http_conduit(2, 0, 0) -genSign :: MonadUnsafeIO m => OAuth -> Credential -> Request -> m BS.ByteString -#else -genSign :: MonadUnsafeIO m => OAuth -> Credential -> Request m -> m BS.ByteString -#endif -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 -> -#if MIN_VERSION_RSA(2, 0, 0) - liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign hashSHA1 pr) (getBaseString tok req) -#else - liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req) -#endif - -#if MIN_VERSION_http_conduit(2, 0, 0) -addAuthHeader :: BS.ByteString -> Credential -> Request -> Request -#else -addAuthHeader :: BS.ByteString -> Credential -> Request a -> Request a -#endif -addAuthHeader prefix (Credential cred) req = - req { requestHeaders = insertMap "Authorization" (renderAuthHeader prefix cred) $ requestHeaders req } - -renderAuthHeader :: BS.ByteString -> [(BS.ByteString, BS.ByteString)] -> BS.ByteString -renderAuthHeader prefix = (prefix `BS.append`). BS.intercalate "," . map (\(a,b) -> BS.concat [paramEncode a, "=\"", paramEncode b, "\""]) . filter ((`elem` ["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 - -#if MIN_VERSION_http_conduit(2, 0, 0) -getBaseString :: MonadUnsafeIO m => Credential -> Request -> m BSL.ByteString -#else -getBaseString :: MonadUnsafeIO m => Credential -> Request m -> m BSL.ByteString -#endif -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 = parseSimpleQuery $ 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] - -#if MIN_VERSION_http_conduit(2, 0, 0) -toLBS :: MonadUnsafeIO m => RequestBody -> m BS.ByteString -toLBS (RequestBodyLBS l) = return $ toStrict l -toLBS (RequestBodyBS s) = return s -toLBS (RequestBodyBuilder _ b) = return $ toByteString b -toLBS (RequestBodyStream _ givesPopper) = toLBS' givesPopper -toLBS (RequestBodyStreamChunked givesPopper) = toLBS' givesPopper - -type Popper = IO BS.ByteString -type NeedsPopper a = Popper -> IO a -type GivesPopper a = NeedsPopper a -> IO a - -toLBS' :: MonadUnsafeIO m => GivesPopper () -> m BS.ByteString --- FIXME probably shouldn't be using MonadUnsafeIO -toLBS' gp = unsafeLiftIO $ do - ref <- I.newIORef BS.empty - gp (go ref) - I.readIORef ref - where - go ref popper = - loop id - where - loop front = do - bs <- popper - if BS.null bs - then I.writeIORef ref $ BS.concat $ front [] - else loop (front . (bs:)) -#else -toLBS :: MonadUnsafeIO m => RequestBody m -> m BS.ByteString -toLBS (RequestBodyLBS l) = return $ toStrict l -toLBS (RequestBodyBS s) = return s -toLBS (RequestBodyBuilder _ b) = return $ toByteString b -toLBS (RequestBodySource _ src) = toLBS' src -toLBS (RequestBodySourceChunked src) = toLBS' src - -toLBS' :: MonadUnsafeIO m => Source m Builder -> m BS.ByteString -toLBS' src = liftM BS.concat $ src $= builderToByteString $$ CL.consume -#endif - -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 - -#if MIN_VERSION_http_conduit(2, 0, 0) -addMaybeProxy :: Maybe Proxy -> Request -> Request -#else -addMaybeProxy :: Maybe Proxy -> Request m -> Request m -#endif -addMaybeProxy p req = req { proxy = p } diff --git a/authenticate-oauth/Web/Authenticate/OAuth/IO.hs b/authenticate-oauth/Web/Authenticate/OAuth/IO.hs deleted file mode 100644 index d00a537f..00000000 --- a/authenticate-oauth/Web/Authenticate/OAuth/IO.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} --- | This Module provides interface for the instance of 'MonadIO' instead of 'MonadIO'. --- What this module do is just adding 'withManager' or 'runResourceT'. -module Web.Authenticate.OAuth.IO - {-# DEPRECATED "This module is deprecated; rewrite your code using MonadResource" #-} - ( - module Web.Authenticate.OAuth, - getAccessToken, - getTemporaryCredential, getTemporaryCredentialWithScope, - getTemporaryCredentialProxy, getTemporaryCredential', - getTokenCredential, - getAccessTokenProxy, getTokenCredentialProxy, - getAccessToken' - ) where -import Network.HTTP.Conduit -import qualified Web.Authenticate.OAuth as OA -import Web.Authenticate.OAuth hiding - (getAccessToken, - getTemporaryCredential, getTemporaryCredentialWithScope, - getTemporaryCredentialProxy, getTemporaryCredential', - getTokenCredential, getTemporaryCredentialWithScope, - getAccessTokenProxy, getTemporaryCredentialProxy, - getTokenCredentialProxy, - getAccessToken', getTemporaryCredential') -import Data.Conduit -import Control.Monad.IO.Class -import qualified Data.ByteString.Char8 as BS - - --- | Get temporary credential for requesting acces token. -getTemporaryCredential :: MonadIO m - => OA.OAuth -- ^ OAuth Application - -> m OA.Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredential = liftIO . withManager . OA.getTemporaryCredential - --- | Get temporary credential for requesting access token with Scope parameter. -getTemporaryCredentialWithScope :: MonadIO m - => BS.ByteString -- ^ Scope parameter string - -> OAuth -- ^ OAuth Application - -> m Credential -- ^ Temporay Credential (Request Token & Secret). -getTemporaryCredentialWithScope bs oa = - liftIO $ withManager $ OA.getTemporaryCredentialWithScope bs oa - - --- | Get temporary credential for requesting access token via the proxy. -getTemporaryCredentialProxy :: MonadIO m - => Maybe Proxy -- ^ Proxy - -> OAuth -- ^ OAuth Application - -> m Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredentialProxy p oa = liftIO $ withManager $ OA.getTemporaryCredential' (addMaybeProxy p) oa - -getTemporaryCredential' :: MonadIO m -#if MIN_VERSION_http_conduit(2, 0, 0) - => (Request -> Request) -- ^ Request Hook -#else - => (Request (ResourceT IO) -> Request (ResourceT IO)) -- ^ Request Hook -#endif - -> OAuth -- ^ OAuth Application - -> m Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredential' hook oa = liftIO $ withManager $ OA.getTemporaryCredential' hook oa - - --- | Get Access token. -getAccessToken, getTokenCredential - :: MonadIO m - => OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential with oauth_verifier - -> m Credential -- ^ Token Credential (Access Token & Secret) -getAccessToken oa cr = liftIO $ withManager $ OA.getAccessToken oa cr - --- | Get Access token via the proxy. -getAccessTokenProxy, getTokenCredentialProxy - :: MonadIO m - => Maybe Proxy -- ^ Proxy - -> OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential with oauth_verifier - -> m Credential -- ^ Token Credential (Access Token & Secret) -getAccessTokenProxy p oa cr = liftIO $ withManager $ OA.getAccessTokenProxy p oa cr - -getAccessToken' :: MonadIO m -#if MIN_VERSION_http_conduit(2, 0, 0) - => (Request -> Request) -- ^ Request Hook -#else - => (Request (ResourceT IO) -> Request (ResourceT IO)) -- ^ Request Hook -#endif - -> OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential with oauth_verifier - -> m Credential -- ^ Token Credential (Access Token & Secret) -getAccessToken' hook oa cr = liftIO $ withManager $ OA.getAccessToken' hook oa cr - - -getTokenCredential = getAccessToken -getTokenCredentialProxy = getAccessTokenProxy diff --git a/authenticate-oauth/authenticate-oauth.cabal b/authenticate-oauth/authenticate-oauth.cabal deleted file mode 100644 index ea4db124..00000000 --- a/authenticate-oauth/authenticate-oauth.cabal +++ /dev/null @@ -1,39 +0,0 @@ - -name: authenticate-oauth -version: 1.4.0.7 -license: BSD3 -license-file: LICENSE -author: Hiromi Ishii -maintainer: Hiromi Ishii -synopsis: Library to authenticate with OAuth for Haskell web applications. -description: OAuth authentication, e.g. Twitter. -category: Web -stability: Stable -cabal-version: >= 1.6 -build-type: Simple -homepage: http://github.com/yesodweb/authenticate - -library - build-depends: base >= 4 && < 5 - , http-conduit >= 1.4 - , transformers >= 0.1 && < 0.4 - , bytestring >= 0.9 - , crypto-pubkey-types >= 0.1 && < 0.5 - , RSA >= 1.2 && < 2.1 - , time - , data-default - , base64-bytestring >= 0.1 && < 1.1 - , SHA >= 1.4 && < 1.7 - , random - , http-types >= 0.6 && < 0.9 - , blaze-builder - , conduit >= 0.4 - , resourcet >= 0.3 && < 0.5 - , blaze-builder-conduit >= 0.4 - , monad-control >= 0.3 && < 0.4 - exposed-modules: Web.Authenticate.OAuth, Web.Authenticate.OAuth.IO - ghc-options: -Wall - -source-repository head - type: git - location: git://github.com/yesodweb/authenticate.git diff --git a/authenticate/LICENSE b/authenticate/LICENSE deleted file mode 100644 index 11dc17a1..00000000 --- a/authenticate/LICENSE +++ /dev/null @@ -1,25 +0,0 @@ -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: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* 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. - -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. diff --git a/authenticate/OpenId2/Discovery.hs b/authenticate/OpenId2/Discovery.hs deleted file mode 100644 index 8cdd66fb..00000000 --- a/authenticate/OpenId2/Discovery.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} - --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Discovery --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -module OpenId2.Discovery ( - -- * Discovery - discover - , Discovery (..) - ) where - --- Friends -import OpenId2.Types -import OpenId2.XRDS - --- Libraries -import Data.Char -import Data.Maybe -import Network.HTTP.Conduit -import qualified Data.ByteString.Char8 as S8 -import Control.Arrow (first) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad (mplus, liftM) -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 Data.Conduit (MonadBaseControl, MonadResource) - -data Discovery = Discovery1 Text (Maybe Text) - | Discovery2 Provider Identifier IdentType - deriving Show - --- | Attempt to resolve an OpenID endpoint, and user identifier. -discover :: (MonadBaseControl IO m, MonadIO m, MonadResource 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 manager - case res2 of - Just x -> return x - 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 :: (MonadResource m, MonadBaseControl IO m) - => Identifier - -> Maybe String - -> Int -- ^ remaining redirects - -> Manager - -> m (Maybe (Provider, Identifier, IdentType)) -discoverYADIS _ _ 0 _ = liftIO $ throwIO $ TooManyRedirects -#if MIN_VERSION_http_conduit(1,6,0) - [] -#endif -discoverYADIS ident mb_loc redirects manager = do - let uri = fromMaybe (unpack $ identifier ident) mb_loc - req <- liftIO $ parseUrl uri - res <- httpLbs req -#if MIN_VERSION_http_conduit(1, 9, 0) - { checkStatus = \_ _ _ -> Nothing -#else - { checkStatus = \_ _ -> Nothing -#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 - if responseStatus res == status200 - then - case mloc' of - 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 - else return Nothing - - --- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml --- document. -parseYADIS :: Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType) -parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat - where - isOpenId svc = do - let tys = serviceTypes svc - localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc - f (x,y) | x `elem` tys = Just y - | otherwise = Nothing - (lid, itype) <- listToMaybe $ mapMaybe f - [ ("http://specs.openid.net/auth/2.0/server", (ident, OPIdent)) - -- claimed identifiers - , ("http://specs.openid.net/auth/2.0/signon", (localId, ClaimedIdent)) - , ("http://openid.net/signon/1.0" , (localId, ClaimedIdent)) - , ("http://openid.net/signon/1.1" , (localId, ClaimedIdent)) - ] - uri <- listToMaybe $ serviceURIs svc - return (Provider uri, lid, itype) - - --- HTML-Based Discovery -------------------------------------------------------- - --- | 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 :: (MonadResource m, MonadBaseControl IO m) => Identifier -> Manager -> m (Maybe Discovery) -discoverHTML ident'@(Identifier ident) manager = do - req <- liftIO $ parseUrl $ 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 - where - isOpenId (rel, _x) = "openid" `T.isPrefixOf` rel - resolve1 ls = do - server <- lookup "openid.server" ls - let delegate = lookup "openid.delegate" ls - return $ Discovery1 server delegate - resolve2 ls = do - prov <- lookup "openid2.provider" ls - let lid = maybe ident Identifier $ lookup "openid2.local_id" ls - -- 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) = (,) <$> lookup "rel" as <*> lookup "href" as -linkTag _x = Nothing diff --git a/authenticate/OpenId2/Normalization.hs b/authenticate/OpenId2/Normalization.hs deleted file mode 100644 index 9534a18a..00000000 --- a/authenticate/OpenId2/Normalization.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Normalization --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -module OpenId2.Normalization - ( normalize - ) where - --- Friends -import OpenId2.Types - --- Libraries -import Control.Applicative -import Control.Monad -import Data.List -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 :: MonadIO m => Text -> m Identifier -normalize ident = - case normalizeIdentifier $ Identifier ident of - Just i -> return i - Nothing -> liftIO $ throwIO $ NormalizationException $ unpack ident - --- | Normalize an identifier, discarding XRIs. -normalizeIdentifier :: Identifier -> Maybe Identifier -normalizeIdentifier = normalizeIdentifier' (const Nothing) - - --- | Normalize the user supplied identifier, using a supplied function to --- normalize an XRI. -normalizeIdentifier' :: (String -> Maybe String) -> Identifier - -> Maybe Identifier -normalizeIdentifier' xri (Identifier str') - | null str = Nothing - | "xri://" `isPrefixOf` str = (Identifier . pack) `fmap` xri str - | head str `elem` "=@+$!" = (Identifier . pack) `fmap` xri str - | otherwise = fmt `fmap` (url >>= norm) - where - str = unpack str' - url = parseURI str <|> parseURI ("http://" ++ str) - - norm uri = validScheme >> return u - where - scheme' = uriScheme uri - validScheme = guard (scheme' == "http:" || scheme' == "https:") - u = uri { uriFragment = "", uriPath = path' } - path' | null (uriPath uri) = "/" - | otherwise = uriPath uri - - fmt u = Identifier - $ pack - $ normalizePathSegments - $ normalizeEscape - $ normalizeCase - $ uriToString (const "") u [] diff --git a/authenticate/OpenId2/Types.hs b/authenticate/OpenId2/Types.hs deleted file mode 100644 index cb524c1b..00000000 --- a/authenticate/OpenId2/Types.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Types --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -module OpenId2.Types ( - Provider (..) - , Identifier (..) - , IdentType (..) - , AuthenticateException (..) - ) where - --- Libraries -import Data.Data (Data) -import Data.Typeable (Typeable) -import Web.Authenticate.Internal -import Data.Text (Text) - --- | An OpenID provider. -newtype Provider = Provider { providerURI :: Text } deriving (Eq,Show) - --- | A valid OpenID identifier. -newtype Identifier = Identifier { identifier :: Text } - deriving (Eq, Ord, Show, Read, Data, Typeable) - -data IdentType = OPIdent | ClaimedIdent - deriving (Eq, Ord, Show, Read, Data, Typeable) diff --git a/authenticate/OpenId2/XRDS.hs b/authenticate/OpenId2/XRDS.hs deleted file mode 100644 index 96771ff5..00000000 --- a/authenticate/OpenId2/XRDS.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- | --- Module : Text.XRDS --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -module OpenId2.XRDS ( - -- * Types - XRDS - , Service(..) - - -- * Parsing - , parseXRDS - ) where - --- Libraries -import Control.Monad ((>=>)) -import Data.Maybe (listToMaybe) -import Text.XML (parseLBS, def) -import Text.XML.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute) -import qualified Data.ByteString.Lazy as L -import Data.Text (Text) -import qualified Data.Text.Read - --- Types ----------------------------------------------------------------------- - -type XRDS = [XRD] - -type XRD = [Service] - -data Service = Service - { serviceTypes :: [Text] - , serviceMediaTypes :: [Text] - , serviceURIs :: [Text] - , serviceLocalIDs :: [Text] - , servicePriority :: Maybe Int - } deriving Show - -parseXRDS :: L.ByteString -> Maybe XRDS -parseXRDS str = - either - (const Nothing) - (Just . parseXRDS' . fromDocument) - (parseLBS def str) - -parseXRDS' :: Cursor -> [[Service]] -parseXRDS' = element "{xri://$xrds}XRDS" &/ - element "{xri://$xrd*($v*2.0)}XRD" &| - parseXRD - -parseXRD :: Cursor -> [Service] -parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService - -parseService :: Cursor -> [Service] -parseService c = - if null types then [] else [Service - { serviceTypes = types - , serviceMediaTypes = mtypes - , serviceURIs = uris - , serviceLocalIDs = localids - , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe - }] - where - types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content - mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content - uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content - localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content - readMaybe t = - case Data.Text.Read.signed Data.Text.Read.decimal t of - Right (i, "") -> Just i - _ -> Nothing diff --git a/authenticate/Setup.lhs b/authenticate/Setup.lhs deleted file mode 100755 index 06e2708f..00000000 --- a/authenticate/Setup.lhs +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff --git a/authenticate/Web/Authenticate/BrowserId.hs b/authenticate/Web/Authenticate/BrowserId.hs deleted file mode 100644 index 17ed0531..00000000 --- a/authenticate/Web/Authenticate/BrowserId.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -module Web.Authenticate.BrowserId - ( browserIdJs - , checkAssertion - ) where - -import Data.Text (Text) -import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, Manager, method, urlEncodedBody) -import Data.Aeson (json, Value (Object, String)) -import Data.Attoparsec.Lazy (parse, maybeResult) -import qualified Data.HashMap.Lazy as Map -import Data.Text.Encoding (encodeUtf8) -import Control.Monad.IO.Class (liftIO) -import Data.Conduit (MonadBaseControl, MonadResource) - --- | Location of the Javascript file hosted by browserid.org -browserIdJs :: Text -browserIdJs = "https://login.persona.org/include.js" - -checkAssertion :: (MonadResource m, MonadBaseControl IO m) - => Text -- ^ audience - -> Text -- ^ assertion - -> Manager - -> m (Maybe Text) -checkAssertion audience assertion manager = do - req' <- liftIO $ parseUrl "https://verifier.login.persona.org/verify" - let req = urlEncodedBody - [ ("audience", encodeUtf8 audience) - , ("assertion", encodeUtf8 assertion) - ] req' { method = "POST" } - res <- httpLbs req manager - let lbs = responseBody res - return $ maybeResult (parse json lbs) >>= getEmail - where - getEmail (Object o) = - case (Map.lookup "status" o, Map.lookup "email" o) of - (Just (String "okay"), Just (String e)) -> Just e - _ -> Nothing - getEmail _ = Nothing diff --git a/authenticate/Web/Authenticate/Internal.hs b/authenticate/Web/Authenticate/Internal.hs deleted file mode 100644 index 1cf83b10..00000000 --- a/authenticate/Web/Authenticate/Internal.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Web.Authenticate.Internal - ( AuthenticateException (..) - ) where - -import Data.Typeable (Typeable) -import Control.Exception (Exception) - -data AuthenticateException = - RpxnowException String - | NormalizationException String - | DiscoveryException String - | AuthenticationException String - deriving (Show, Typeable) -instance Exception AuthenticateException diff --git a/authenticate/Web/Authenticate/OpenId.hs b/authenticate/Web/Authenticate/OpenId.hs deleted file mode 100644 index a31d3d29..00000000 --- a/authenticate/Web/Authenticate/OpenId.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -module Web.Authenticate.OpenId - ( -- * 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 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.Conduit - ( parseUrl, urlEncodedBody, responseBody, httpLbs - , Manager - ) -import Control.Arrow ((***), second) -import Data.List (unfoldr) -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack, unpack) -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Blaze.ByteString.Builder (toByteString) -import Network.HTTP.Types (renderQueryText) -import Control.Exception (throwIO) -import Data.Conduit (MonadBaseControl, MonadResource) - -getForwardUrl - :: (MonadResource m, MonadBaseControl IO 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 manager = do - let realm = fromMaybe complete mrealm - claimed <- normalize 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 (identifier claimed) id mdelegate) - : ("openid.return_to", complete) - : ("openid.realm", realm) - : ("openid.trust_root", complete) - : params - Discovery2 (Provider p) (Identifier i) itype -> do - let (claimed', identity') = - case itype of - 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", claimed') - : ("openid.identity", identity') - : ("openid.return_to", complete) - : ("openid.realm", realm) - : params - -authenticate - :: (MonadBaseControl IO m, MonadResource m, MonadIO m) - => [(Text, Text)] - -> Manager - -> m (Identifier, [(Text, Text)]) -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 - :: (MonadBaseControl IO m, MonadResource m, MonadIO m) - => [(Text, Text)] - -> Manager - -> m OpenIdResponse -authenticateClaimed params manager = do - unless (lookup "openid.mode" params == Just "id_res") - $ liftIO $ throwIO $ case lookup "openid.mode" params of - Nothing -> AuthenticationException "openid.mode was not found in the params." - (Just m) - | m == "error" -> - case lookup "openid.error" params of - Nothing -> AuthenticationException "An error occurred, but no error message was provided." - (Just e) -> AuthenticationException $ unpack e - | otherwise -> AuthenticationException $ "mode is " ++ unpack m ++ " but we were expecting id_res." - ident <- case lookup "openid.identity" params of - Just i -> return i - Nothing -> - 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' <- liftIO $ parseUrl $ unpack $ endpoint discOP - let req = urlEncodedBody params' 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 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)] -parseDirectResponse = - map (pack *** pack) . unfoldr step . unpack - where - step [] = Nothing - step str = case split (== '\n') str of - (ps,rest) -> Just (split (== ':') ps,rest) - -split :: (a -> Bool) -> [a] -> ([a],[a]) -split p as = case break p as of - (xs,_:ys) -> (xs,ys) - pair -> pair diff --git a/authenticate/Web/Authenticate/OpenId/Providers.hs b/authenticate/Web/Authenticate/OpenId/Providers.hs deleted file mode 100644 index e5673162..00000000 --- a/authenticate/Web/Authenticate/OpenId/Providers.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | OpenIDs for a number of common OPs. When a function takes a 'String' --- parameter, that 'String' is the username. -module Web.Authenticate.OpenId.Providers - ( google - , yahoo - , livejournal - , myspace - , wordpress - , blogger - , verisign - , typepad - , myopenid - , claimid - ) where - -google :: String -google = "https://www.google.com/accounts/o8/id" - -yahoo :: String -yahoo = "http://me.yahoo.com/" - -livejournal :: String -> String -livejournal u = concat ["http://", u, ".livejournal.com/"] - -myspace :: String -> String -myspace = (++) "http://www.myspace.com/" - -wordpress :: String -> String -wordpress u = concat ["http://", u, ".wordpress.com/"] - -blogger :: String -> String -blogger u = concat ["http://", u, ".blogger.com/"] - -verisign :: String -> String -verisign u = concat ["http://", u, ".pip.verisignlabs.com/"] - -typepad :: String -> String -typepad u = concat ["http://", u, ".typepad.com/"] - -myopenid :: String -> String -myopenid u = concat ["http://", u, ".myopenid.com/"] - -claimid :: String -> String -claimid = (++) "http://claimid.com/" diff --git a/authenticate/Web/Authenticate/Rpxnow.hs b/authenticate/Web/Authenticate/Rpxnow.hs deleted file mode 100644 index d9fd4063..00000000 --- a/authenticate/Web/Authenticate/Rpxnow.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} ---------------------------------------------------------- --- --- Module : Web.Authenticate.Rpxnow --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Unstable --- Portability : portable --- --- Facilitates authentication with "http://rpxnow.com/". --- ---------------------------------------------------------- -module Web.Authenticate.Rpxnow - ( Identifier (..) - , authenticate - , AuthenticateException (..) - ) where - -import Data.Aeson -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 Web.Authenticate.Internal -import Data.Data (Data) -import Data.Typeable (Typeable) -import Data.Attoparsec.Lazy (parse) -import qualified Data.Attoparsec.Lazy as AT -import Data.Text (Text) -import qualified Data.Aeson.Types -import qualified Data.HashMap.Lazy as Map -import Control.Applicative ((<$>), (<*>)) -import Control.Exception (throwIO) -import Data.Conduit (MonadBaseControl, MonadResource) - --- | Information received from Rpxnow after a valid login. -data Identifier = Identifier - { identifier :: Text - , extraData :: [(Text, Text)] - } - deriving (Eq, Ord, Read, Show, Data, Typeable) - --- | Attempt to log a user in. -authenticate :: (MonadResource m, MonadBaseControl IO m) - => String -- ^ API key given by RPXNOW. - -> String -- ^ Token passed by client. - -> Manager - -> m Identifier -authenticate apiKey token manager = do - let body = L.fromChunks - [ "apiKey=" - , S.pack apiKey - , "&token=" - , S.pack token - ] - req' <- liftIO $ parseUrl "https://rpxnow.com" - let req = - req' - { method = "POST" - , path = "api/v2/auth_info" - , requestHeaders = - [ ("Content-Type", "application/x-www-form-urlencoded") - ] - , requestBody = RequestBodyLBS body - } - res <- httpLbs req manager - let b = responseBody res - o <- unResult $ parse json b - --m <- fromMapping o - let mstat = flip Data.Aeson.Types.parse o $ \v -> - case v of - Object m -> m .: "stat" - _ -> mzero - case mstat of - Success "ok" -> return () - Success stat -> liftIO $ throwIO $ RpxnowException $ - "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b - _ -> liftIO $ throwIO $ RpxnowException "Now stat value found on Rpxnow response" - case Data.Aeson.Types.parse parseProfile o of - Success x -> return x - Error e -> liftIO $ throwIO $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e - -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 - profile <- m .: "profile" - Identifier - <$> (profile .: "identifier") - <*> return (mapMaybe go (Map.toList profile)) - where - go ("identifier", _) = Nothing - go (k, String v) = Just (k, v) - go _ = Nothing -parseProfile _ = mzero diff --git a/authenticate/authenticate.cabal b/authenticate/authenticate.cabal deleted file mode 100644 index d96fbeba..00000000 --- a/authenticate/authenticate.cabal +++ /dev/null @@ -1,48 +0,0 @@ -name: authenticate -version: 1.3.2.6 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman, Hiromi Ishii, Arash Rouhani -maintainer: Michael Snoyman -synopsis: Authentication methods for Haskell web applications. -description: - Focus is on third-party authentication methods, such as OpenID and BrowserID. - . - Note: Facebook support is now provided by the fb package: . -category: Web -stability: Stable -cabal-version: >= 1.6 -build-type: Simple -homepage: http://github.com/yesodweb/authenticate - -library - build-depends: base >= 4 && < 5 - , aeson >= 0.5 - , http-conduit >= 1.5 - , tagsoup >= 0.12 - , transformers >= 0.1 - , bytestring >= 0.9 - , network - , case-insensitive >= 0.2 - , text - , http-types >= 0.6 - , xml-conduit >= 1.0 - , blaze-builder - , attoparsec - , containers - , unordered-containers - , conduit >= 0.5 - exposed-modules: Web.Authenticate.Rpxnow, - Web.Authenticate.OpenId, - Web.Authenticate.BrowserId, - Web.Authenticate.OpenId.Providers - other-modules: Web.Authenticate.Internal, - OpenId2.Discovery, - OpenId2.Normalization, - OpenId2.Types, - OpenId2.XRDS - ghc-options: -Wall - -source-repository head - type: git - location: git://github.com/yesodweb/authenticate.git diff --git a/authenticate/browserid.hs b/authenticate/browserid.hs deleted file mode 100644 index d83133ad..00000000 --- a/authenticate/browserid.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} -import Yesod -import Web.Authenticate.BrowserId -import Data.Maybe (fromMaybe) -import Network.HTTP.Conduit -import Data.Text (Text) - -data BID = BID -mkYesod "BID" [parseRoutes| -/ RootR GET -/complete/#Text CompleteR GET -|] - -instance Yesod BID where approot = ApprootStatic "http://localhost:3000" - -getRootR = defaultLayout $ do - addScriptRemote browserIdJs - addJulius [julius| -function bidClick() { - navigator.id.getVerifiedEmail(function(assertion) { - if (assertion) { - document.location = "/complete/" + assertion; - } else { - alert("Invalid BrowserId login"); - } - }); -} -|] - addHamlet [hamlet| -

- - -|] - -getCompleteR assertion = do - memail <- withManager $ checkAssertion "localhost:3000" assertion - defaultLayout $ addHamlet [hamlet| -

You tried to log in, let's see if it worked. -$maybe email <- memail -

Yes it did! You are: #{email} -$nothing -

Nope, sorry -|] - -main = warp 3000 BID diff --git a/authenticate/openid2.hs b/authenticate/openid2.hs deleted file mode 100644 index 7e3c2e22..00000000 --- a/authenticate/openid2.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} -import Yesod.Core -import Web.Authenticate.OpenId -import qualified Web.Authenticate.OpenId.Providers as P -import Network.HTTP.Conduit -import Yesod.Form -import Network.Wai.Handler.Warp (run) -import Text.Lucius (lucius) - -data OID = OID -mkYesod "OID" [parseRoutes| -/ RootR GET -/forward ForwardR GET -/complete CompleteR GET -|] - -instance Yesod OID where - approot = ApprootStatic "http://localhost:3000" - -getRootR :: Handler RepHtml -getRootR = defaultLayout [whamlet| -

- OpenId: # - - - - - -|] - -instance RenderMessage OID FormMessage where - renderMessage _ _ = defaultFormMessage - -getForwardR :: Handler () -getForwardR = do - openid <- runInputGet $ ireq textField "openid_identifier" - render <- getUrlRender - url <- withManager $ getForwardUrl openid (render CompleteR) Nothing [] - redirect url - -getCompleteR :: Handler RepHtml -getCompleteR = do - params <- reqGetParams `fmap` getRequest - oir <- withManager $ authenticateClaimed params - defaultLayout $ do - toWidget [lucius| -table { - border-collapse: collapse; -} -th, td { - border: 1px solid #666; - padding: 5px; - vertical-align: top; -} -th { - text-align: right; -} -|] - [whamlet| -

Successfully logged in. - - - - -
OP Local - #{identifier $ oirOpLocal oir} -
Claimed - - $maybe c <- oirClaimed oir - \#{identifier c} - $nothing - none -
Params - - - $forall (k, v) <- oirParams oir - - -
#{k} - #{v} -
GET params - - - $forall (k, v) <- params - -
#{k} - #{v} -|] - -main :: IO () -main = toWaiApp OID >>= run 3000 diff --git a/authenticate/rpxnow.hs b/authenticate/rpxnow.hs deleted file mode 100644 index e37d5580..00000000 --- a/authenticate/rpxnow.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} -import Yesod -import Web.Authenticate.Rpxnow -import Data.Maybe (fromMaybe) -import qualified Data.Aeson as A -import qualified Data.Vector as V -import qualified Data.Map as M -import Data.Text (unpack) - -appName :: String -appName = "yesod-test" -apiKey = "c8043882f14387d7ad8dfc99a1a8dab2e028f690" -data RP = RP -type Handler = GHandler RP RP - -mkYesod "RP" [parseRoutes| -/ RootR GET -/complete CompleteR POST -|] - -instance Yesod RP where approot _ = "http://localhost:3000" - -getRootR :: Handler RepHtml -getRootR = defaultLayout [hamlet| -