Merge branch 'oauth-fix-deps' of https://github.com/yesodweb/authenticate
Conflicts: .gitignore .travis.yml sources.txt
This commit is contained in:
Michael Litchard
commit
2081d810b9
3
.gitignore
vendored
3
.gitignore
vendored
@ -12,3 +12,6 @@ cabal.sandbox.config
|
||||
/vendor/
|
||||
/.shelly/
|
||||
/tarballs/
|
||||
*.swp
|
||||
dist
|
||||
client_session_key.aes
|
||||
|
||||
@ -9,3 +9,7 @@ script:
|
||||
- echo Done
|
||||
- cabal-meta install --enable-tests
|
||||
- mega-sdist --test
|
||||
- cabal install mega-sdist hspec cabal-meta cabal-src
|
||||
- cabal-meta install --force-reinstalls
|
||||
|
||||
script: mega-sdist --test
|
||||
|
||||
15
README
Normal file
15
README
Normal file
@ -0,0 +1,15 @@
|
||||
Authentication methods for Haskell web applications.
|
||||
|
||||
Note for Rpxnow:
|
||||
By default on some (all?) installs wget does not come with root certificates
|
||||
for SSL. If this is the case then Web.Authenticate.Rpxnow.authenticate will
|
||||
fail as wget cannot establish a secure connection to rpxnow's servers.
|
||||
|
||||
A simple *nix solution, if potentially insecure (man in the middle attacks as
|
||||
you are downloading the certs) is to grab a copy of the certs extracted from
|
||||
those that come with firefox, hosted by CURL at
|
||||
http://curl.haxx.se/ca/cacert.pem , put them somewhere (for ex,
|
||||
~/.wget/cacert.pem) and then edit your ~/.wgetrc to include:
|
||||
ca_certificate=~/.wget/cacert.pem
|
||||
|
||||
This should fix the problem.
|
||||
6
authenticate-oauth/.gitignore
vendored
Normal file
6
authenticate-oauth/.gitignore
vendored
Normal file
@ -0,0 +1,6 @@
|
||||
.DS_Store
|
||||
*.hi
|
||||
*.o
|
||||
dist
|
||||
*~
|
||||
cabal-dev
|
||||
25
authenticate-oauth/LICENSE
Normal file
25
authenticate-oauth/LICENSE
Normal file
@ -0,0 +1,25 @@
|
||||
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.
|
||||
7
authenticate-oauth/Setup.lhs
Executable file
7
authenticate-oauth/Setup.lhs
Executable file
@ -0,0 +1,7 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
|
||||
> module Main where
|
||||
> import Distribution.Simple
|
||||
|
||||
> main :: IO ()
|
||||
> main = defaultMain
|
||||
455
authenticate-oauth/Web/Authenticate/OAuth.hs
Normal file
455
authenticate-oauth/Web/Authenticate/OAuth.hs
Normal file
@ -0,0 +1,455 @@
|
||||
{-# 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 }
|
||||
95
authenticate-oauth/Web/Authenticate/OAuth/IO.hs
Normal file
95
authenticate-oauth/Web/Authenticate/OAuth/IO.hs
Normal file
@ -0,0 +1,95 @@
|
||||
{-# 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
|
||||
39
authenticate-oauth/authenticate-oauth.cabal
Normal file
39
authenticate-oauth/authenticate-oauth.cabal
Normal file
@ -0,0 +1,39 @@
|
||||
|
||||
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
|
||||
25
authenticate/LICENSE
Normal file
25
authenticate/LICENSE
Normal file
@ -0,0 +1,25 @@
|
||||
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.
|
||||
159
authenticate/OpenId2/Discovery.hs
Normal file
159
authenticate/OpenId2/Discovery.hs
Normal file
@ -0,0 +1,159 @@
|
||||
{-# 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
|
||||
69
authenticate/OpenId2/Normalization.hs
Normal file
69
authenticate/OpenId2/Normalization.hs
Normal file
@ -0,0 +1,69 @@
|
||||
{-# 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 []
|
||||
34
authenticate/OpenId2/Types.hs
Normal file
34
authenticate/OpenId2/Types.hs
Normal file
@ -0,0 +1,34 @@
|
||||
{-# 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)
|
||||
77
authenticate/OpenId2/XRDS.hs
Normal file
77
authenticate/OpenId2/XRDS.hs
Normal file
@ -0,0 +1,77 @@
|
||||
{-# 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
|
||||
7
authenticate/Setup.lhs
Executable file
7
authenticate/Setup.lhs
Executable file
@ -0,0 +1,7 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
|
||||
> module Main where
|
||||
> import Distribution.Simple
|
||||
|
||||
> main :: IO ()
|
||||
> main = defaultMain
|
||||
40
authenticate/Web/Authenticate/BrowserId.hs
Normal file
40
authenticate/Web/Authenticate/BrowserId.hs
Normal file
@ -0,0 +1,40 @@
|
||||
{-# 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
|
||||
15
authenticate/Web/Authenticate/Internal.hs
Normal file
15
authenticate/Web/Authenticate/Internal.hs
Normal file
@ -0,0 +1,15 @@
|
||||
{-# 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
|
||||
164
authenticate/Web/Authenticate/OpenId.hs
Normal file
164
authenticate/Web/Authenticate/OpenId.hs
Normal file
@ -0,0 +1,164 @@
|
||||
{-# 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
|
||||
44
authenticate/Web/Authenticate/OpenId/Providers.hs
Normal file
44
authenticate/Web/Authenticate/OpenId/Providers.hs
Normal file
@ -0,0 +1,44 @@
|
||||
-- | 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/"
|
||||
103
authenticate/Web/Authenticate/Rpxnow.hs
Normal file
103
authenticate/Web/Authenticate/Rpxnow.hs
Normal file
@ -0,0 +1,103 @@
|
||||
{-# 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
|
||||
48
authenticate/authenticate.cabal
Normal file
48
authenticate/authenticate.cabal
Normal file
@ -0,0 +1,48 @@
|
||||
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
|
||||
45
authenticate/browserid.hs
Normal file
45
authenticate/browserid.hs
Normal file
@ -0,0 +1,45 @@
|
||||
{-# 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
|
||||
91
authenticate/openid2.hs
Normal file
91
authenticate/openid2.hs
Normal file
@ -0,0 +1,91 @@
|
||||
{-# 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
|
||||
38
authenticate/rpxnow.hs
Normal file
38
authenticate/rpxnow.hs
Normal file
@ -0,0 +1,38 @@
|
||||
{-# 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
|
||||
@ -9,3 +9,4 @@
|
||||
./yesod-test
|
||||
./yesod-bin
|
||||
./yesod
|
||||
./authenticate
|
||||
|
||||
Loading…
Reference in New Issue
Block a user