Remove some old files
This commit is contained in:
Michael Snoyman
parent
d764464152
commit
66e9e203f8
3
.gitmodules
vendored
3
.gitmodules
vendored
@ -1,3 +0,0 @@
|
|||||||
[submodule "scripts"]
|
|
||||||
path = scripts
|
|
||||||
url = git://github.com/yesodweb/scripts.git
|
|
||||||
6
authenticate-oauth/.gitignore
vendored
6
authenticate-oauth/.gitignore
vendored
@ -1,6 +0,0 @@
|
|||||||
.DS_Store
|
|
||||||
*.hi
|
|
||||||
*.o
|
|
||||||
dist
|
|
||||||
*~
|
|
||||||
cabal-dev
|
|
||||||
@ -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.
|
|
||||||
@ -1,7 +0,0 @@
|
|||||||
#!/usr/bin/env runhaskell
|
|
||||||
|
|
||||||
> module Main where
|
|
||||||
> import Distribution.Simple
|
|
||||||
|
|
||||||
> main :: IO ()
|
|
||||||
> main = defaultMain
|
|
||||||
@ -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 }
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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.
|
|
||||||
@ -1,159 +0,0 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Network.OpenID.Discovery
|
|
||||||
-- Copyright : (c) Trevor Elliott, 2008
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Trevor Elliott <trevor@geekgateway.com>
|
|
||||||
-- 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
|
|
||||||
@ -1,69 +0,0 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Network.OpenID.Normalization
|
|
||||||
-- Copyright : (c) Trevor Elliott, 2008
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Trevor Elliott <trevor@geekgateway.com>
|
|
||||||
-- 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 []
|
|
||||||
@ -1,34 +0,0 @@
|
|||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Network.OpenID.Types
|
|
||||||
-- Copyright : (c) Trevor Elliott, 2008
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Trevor Elliott <trevor@geekgateway.com>
|
|
||||||
-- 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)
|
|
||||||
@ -1,77 +0,0 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- |
|
|
||||||
-- Module : Text.XRDS
|
|
||||||
-- Copyright : (c) Trevor Elliott, 2008
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Trevor Elliott <trevor@geekgateway.com>
|
|
||||||
-- 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
|
|
||||||
@ -1,7 +0,0 @@
|
|||||||
#!/usr/bin/env runhaskell
|
|
||||||
|
|
||||||
> module Main where
|
|
||||||
> import Distribution.Simple
|
|
||||||
|
|
||||||
> main :: IO ()
|
|
||||||
> main = defaultMain
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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
|
|
||||||
@ -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/"
|
|
||||||
@ -1,103 +0,0 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
|
||||||
---------------------------------------------------------
|
|
||||||
--
|
|
||||||
-- Module : Web.Authenticate.Rpxnow
|
|
||||||
-- Copyright : Michael Snoyman
|
|
||||||
-- License : BSD3
|
|
||||||
--
|
|
||||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
||||||
-- 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
|
|
||||||
@ -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 <michael@snoyman.com>
|
|
||||||
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: <http://hackage.haskell.org/package/fb>.
|
|
||||||
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
|
|
||||||
@ -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|
|
|
||||||
<p>
|
|
||||||
<a href="javascript:bidClick();">
|
|
||||||
<img src="https://browserid.org/i/sign_in_red.png">
|
|
||||||
|]
|
|
||||||
|
|
||||||
getCompleteR assertion = do
|
|
||||||
memail <- withManager $ checkAssertion "localhost:3000" assertion
|
|
||||||
defaultLayout $ addHamlet [hamlet|
|
|
||||||
<p>You tried to log in, let's see if it worked.
|
|
||||||
$maybe email <- memail
|
|
||||||
<p>Yes it did! You are: #{email}
|
|
||||||
$nothing
|
|
||||||
<p>Nope, sorry
|
|
||||||
|]
|
|
||||||
|
|
||||||
main = warp 3000 BID
|
|
||||||
@ -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|
|
|
||||||
<form action="@{ForwardR}">
|
|
||||||
OpenId: #
|
|
||||||
<input type="text" name="openid_identifier" value="http://">
|
|
||||||
<input type="submit">
|
|
||||||
<form action="@{ForwardR}">
|
|
||||||
<input type="hidden" name="openid_identifier" value=#{P.google}>
|
|
||||||
<input type="submit" value=Google>
|
|
||||||
|]
|
|
||||||
|
|
||||||
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|
|
|
||||||
<p>Successfully logged in.
|
|
||||||
<table>
|
|
||||||
<tr>
|
|
||||||
<th>OP Local
|
|
||||||
<td>#{identifier $ oirOpLocal oir}
|
|
||||||
<tr>
|
|
||||||
<th>Claimed
|
|
||||||
<td>
|
|
||||||
$maybe c <- oirClaimed oir
|
|
||||||
\#{identifier c}
|
|
||||||
$nothing
|
|
||||||
<i>none
|
|
||||||
<tr>
|
|
||||||
<th>Params
|
|
||||||
<td>
|
|
||||||
<table>
|
|
||||||
$forall (k, v) <- oirParams oir
|
|
||||||
<tr>
|
|
||||||
<th>#{k}
|
|
||||||
<td>#{v}
|
|
||||||
<tr>
|
|
||||||
<th>GET params
|
|
||||||
<td>
|
|
||||||
<table>
|
|
||||||
$forall (k, v) <- params
|
|
||||||
<tr>
|
|
||||||
<th>#{k}
|
|
||||||
<td>#{v}
|
|
||||||
|]
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = toWaiApp OID >>= run 3000
|
|
||||||
@ -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|
|
|
||||||
<iframe src="http://#{appName}.rpxnow.com/openid/embed?token_url=@{CompleteR}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
|
|
||||||
|]
|
|
||||||
|
|
||||||
postCompleteR :: Handler RepHtml
|
|
||||||
postCompleteR = do
|
|
||||||
Just token <- lookupPostParam "token"
|
|
||||||
Identifier ident extra <- liftIO $ authenticate apiKey $ unpack token
|
|
||||||
defaultLayout [hamlet|
|
|
||||||
<h1>Ident: #{ident}
|
|
||||||
<h2>Extra: #{show $ extra}
|
|
||||||
|]
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = warpDebug 3000 RP
|
|
||||||
@ -1,15 +0,0 @@
|
|||||||
#!/bin/bash
|
|
||||||
|
|
||||||
pkgs=( ./yesod-routes
|
|
||||||
./yesod-core
|
|
||||||
./yesod-json
|
|
||||||
./cryptohash-conduit
|
|
||||||
./authenticate/authenticate
|
|
||||||
./yesod-static
|
|
||||||
./yesod-persistent
|
|
||||||
./yesod-newsfeed
|
|
||||||
./yesod-form
|
|
||||||
./yesod-auth
|
|
||||||
./yesod-sitemap
|
|
||||||
./yesod-default
|
|
||||||
./yesod )
|
|
||||||
1
scripts
1
scripts
@ -1 +0,0 @@
|
|||||||
Subproject commit 9902ff808afbcb417c6ad125941343878e3afe11
|
|
||||||
@ -9,6 +9,5 @@
|
|||||||
./yesod-test
|
./yesod-test
|
||||||
./yesod-bin
|
./yesod-bin
|
||||||
./yesod
|
./yesod
|
||||||
./authenticate
|
|
||||||
./yesod-eventsource
|
./yesod-eventsource
|
||||||
./yesod-websockets
|
./yesod-websockets
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user