haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'oauth-fix-deps' of https://github.com/yesodweb/authenticate

Browse Source 
Conflicts:
	.gitignore
	.travis.yml
	sources.txt
This commit is contained in:
Michael Litchard 2014-02-22 06:45:39 -08:00
commit 2081d810b9
25 changed files with 1609 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -12,3 +12,6 @@ cabal.sandbox.config
/vendor/ /vendor/
/.shelly/ /.shelly/
/tarballs/ /tarballs/
*.swp
dist
client_session_key.aes

4
.travis.yml
View File

@ -9,3 +9,7 @@ script:
- echo Done - echo Done
- cabal-meta install --enable-tests - cabal-meta install --enable-tests
- mega-sdist --test - 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
View 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
View File

@ -0,0 +1,6 @@
.DS_Store
*.hi
*.o
dist
*~
cabal-dev

25
authenticate-oauth/LICENSE Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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

1
sources.txt
View File

@ -9,3 +9,4 @@
./yesod-test ./yesod-test
./yesod-bin ./yesod-bin
./yesod ./yesod
./authenticate