diff --git a/.gitignore b/.gitignore index 00767768..205ace6b 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,6 @@ cabal.sandbox.config /vendor/ /.shelly/ /tarballs/ +*.swp +dist +client_session_key.aes diff --git a/.travis.yml b/.travis.yml index 3958d30b..e249b05e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -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 diff --git a/README b/README new file mode 100644 index 00000000..c2ba6ace --- /dev/null +++ b/README @@ -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. diff --git a/authenticate-oauth/.gitignore b/authenticate-oauth/.gitignore new file mode 100644 index 00000000..0d82556e --- /dev/null +++ b/authenticate-oauth/.gitignore @@ -0,0 +1,6 @@ +.DS_Store +*.hi +*.o +dist +*~ +cabal-dev diff --git a/authenticate-oauth/LICENSE b/authenticate-oauth/LICENSE new file mode 100644 index 00000000..11dc17a1 --- /dev/null +++ b/authenticate-oauth/LICENSE @@ -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. diff --git a/authenticate-oauth/Setup.lhs b/authenticate-oauth/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/authenticate-oauth/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/authenticate-oauth/Web/Authenticate/OAuth.hs b/authenticate-oauth/Web/Authenticate/OAuth.hs new file mode 100644 index 00000000..e7dc6dbe --- /dev/null +++ b/authenticate-oauth/Web/Authenticate/OAuth.hs @@ -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 } diff --git a/authenticate-oauth/Web/Authenticate/OAuth/IO.hs b/authenticate-oauth/Web/Authenticate/OAuth/IO.hs new file mode 100644 index 00000000..d00a537f --- /dev/null +++ b/authenticate-oauth/Web/Authenticate/OAuth/IO.hs @@ -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 diff --git a/authenticate-oauth/authenticate-oauth.cabal b/authenticate-oauth/authenticate-oauth.cabal new file mode 100644 index 00000000..ea4db124 --- /dev/null +++ b/authenticate-oauth/authenticate-oauth.cabal @@ -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 diff --git a/authenticate/LICENSE b/authenticate/LICENSE new file mode 100644 index 00000000..11dc17a1 --- /dev/null +++ b/authenticate/LICENSE @@ -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. diff --git a/authenticate/OpenId2/Discovery.hs b/authenticate/OpenId2/Discovery.hs new file mode 100644 index 00000000..8cdd66fb --- /dev/null +++ b/authenticate/OpenId2/Discovery.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Discovery +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Discovery ( + -- * Discovery + discover + , Discovery (..) + ) where + +-- Friends +import OpenId2.Types +import OpenId2.XRDS + +-- Libraries +import Data.Char +import Data.Maybe +import Network.HTTP.Conduit +import qualified Data.ByteString.Char8 as S8 +import Control.Arrow (first) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad (mplus, liftM) +import qualified Data.CaseInsensitive as CI +import Data.Text (Text, unpack) +import Data.Text.Lazy (toStrict) +import qualified Data.Text as T +import Data.Text.Lazy.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Text.HTML.TagSoup (parseTags, Tag (TagOpen)) +import Control.Applicative ((<$>), (<*>)) +import Network.HTTP.Types (status200) +import Control.Exception (throwIO) +import Data.Conduit (MonadBaseControl, MonadResource) + +data Discovery = Discovery1 Text (Maybe Text) + | Discovery2 Provider Identifier IdentType + deriving Show + +-- | Attempt to resolve an OpenID endpoint, and user identifier. +discover :: (MonadBaseControl IO m, MonadIO m, MonadResource m) => Identifier -> Manager -> m Discovery +discover ident@(Identifier i) manager = do + res1 <- discoverYADIS ident Nothing 10 manager + case res1 of + Just (x, y, z) -> return $ Discovery2 x y z + Nothing -> do + res2 <- discoverHTML ident manager + case res2 of + Just x -> return x + Nothing -> liftIO $ throwIO $ DiscoveryException $ unpack i + +-- YADIS-Based Discovery ------------------------------------------------------- + +-- | Attempt a YADIS based discovery, given a valid identifier. The result is +-- an OpenID endpoint, and the actual identifier for the user. +discoverYADIS :: (MonadResource m, MonadBaseControl IO m) + => Identifier + -> Maybe String + -> Int -- ^ remaining redirects + -> Manager + -> m (Maybe (Provider, Identifier, IdentType)) +discoverYADIS _ _ 0 _ = liftIO $ throwIO $ TooManyRedirects +#if MIN_VERSION_http_conduit(1,6,0) + [] +#endif +discoverYADIS ident mb_loc redirects manager = do + let uri = fromMaybe (unpack $ identifier ident) mb_loc + req <- liftIO $ parseUrl uri + res <- httpLbs req +#if MIN_VERSION_http_conduit(1, 9, 0) + { checkStatus = \_ _ _ -> Nothing +#else + { checkStatus = \_ _ -> Nothing +#endif + } manager + let mloc = fmap S8.unpack + $ lookup "x-xrds-location" + $ map (first $ map toLower . S8.unpack . CI.original) + $ responseHeaders res + let mloc' = if mloc == mb_loc then Nothing else mloc + if responseStatus res == status200 + then + case mloc' of + Just loc -> discoverYADIS ident (Just loc) (redirects - 1) manager + Nothing -> do + let mdoc = parseXRDS $ responseBody res + case mdoc of + Just doc -> return $ parseYADIS ident doc + Nothing -> return Nothing + else return Nothing + + +-- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml +-- document. +parseYADIS :: Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType) +parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat + where + isOpenId svc = do + let tys = serviceTypes svc + localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc + f (x,y) | x `elem` tys = Just y + | otherwise = Nothing + (lid, itype) <- listToMaybe $ mapMaybe f + [ ("http://specs.openid.net/auth/2.0/server", (ident, OPIdent)) + -- claimed identifiers + , ("http://specs.openid.net/auth/2.0/signon", (localId, ClaimedIdent)) + , ("http://openid.net/signon/1.0" , (localId, ClaimedIdent)) + , ("http://openid.net/signon/1.1" , (localId, ClaimedIdent)) + ] + uri <- listToMaybe $ serviceURIs svc + return (Provider uri, lid, itype) + + +-- HTML-Based Discovery -------------------------------------------------------- + +-- | Attempt to discover an OpenID endpoint, from an HTML document. The result +-- will be an endpoint on success, and the actual identifier of the user. +discoverHTML :: (MonadResource m, MonadBaseControl IO m) => Identifier -> Manager -> m (Maybe Discovery) +discoverHTML ident'@(Identifier ident) manager = do + req <- liftIO $ parseUrl $ unpack ident + lbs <- liftM responseBody $ httpLbs req manager + return $ parseHTML ident' . toStrict . decodeUtf8With lenientDecode $ lbs + +-- | Parse out an OpenID endpoint and an actual identifier from an HTML +-- document. +parseHTML :: Identifier -> Text -> Maybe Discovery +parseHTML ident = resolve + . filter isOpenId + . mapMaybe linkTag + . parseTags + where + isOpenId (rel, _x) = "openid" `T.isPrefixOf` rel + resolve1 ls = do + server <- lookup "openid.server" ls + let delegate = lookup "openid.delegate" ls + return $ Discovery1 server delegate + resolve2 ls = do + prov <- lookup "openid2.provider" ls + let lid = maybe ident Identifier $ lookup "openid2.local_id" ls + -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only + -- result in a claimed identifier. + return $ Discovery2 (Provider prov) lid ClaimedIdent + resolve ls = resolve2 ls `mplus` resolve1 ls + + +-- | Filter out link tags from a list of html tags. +linkTag :: Tag Text -> Maybe (Text, Text) +linkTag (TagOpen "link" as) = (,) <$> lookup "rel" as <*> lookup "href" as +linkTag _x = Nothing diff --git a/authenticate/OpenId2/Normalization.hs b/authenticate/OpenId2/Normalization.hs new file mode 100644 index 00000000..9534a18a --- /dev/null +++ b/authenticate/OpenId2/Normalization.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE FlexibleContexts #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Normalization +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Normalization + ( normalize + ) where + +-- Friends +import OpenId2.Types + +-- Libraries +import Control.Applicative +import Control.Monad +import Data.List +import Network.URI + ( uriToString, normalizeCase, normalizeEscape + , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment + ) +import Data.Text (Text, pack, unpack) +import Control.Monad.IO.Class +import Control.Exception (throwIO) + +normalize :: MonadIO m => Text -> m Identifier +normalize ident = + case normalizeIdentifier $ Identifier ident of + Just i -> return i + Nothing -> liftIO $ throwIO $ NormalizationException $ unpack ident + +-- | Normalize an identifier, discarding XRIs. +normalizeIdentifier :: Identifier -> Maybe Identifier +normalizeIdentifier = normalizeIdentifier' (const Nothing) + + +-- | Normalize the user supplied identifier, using a supplied function to +-- normalize an XRI. +normalizeIdentifier' :: (String -> Maybe String) -> Identifier + -> Maybe Identifier +normalizeIdentifier' xri (Identifier str') + | null str = Nothing + | "xri://" `isPrefixOf` str = (Identifier . pack) `fmap` xri str + | head str `elem` "=@+$!" = (Identifier . pack) `fmap` xri str + | otherwise = fmt `fmap` (url >>= norm) + where + str = unpack str' + url = parseURI str <|> parseURI ("http://" ++ str) + + norm uri = validScheme >> return u + where + scheme' = uriScheme uri + validScheme = guard (scheme' == "http:" || scheme' == "https:") + u = uri { uriFragment = "", uriPath = path' } + path' | null (uriPath uri) = "/" + | otherwise = uriPath uri + + fmt u = Identifier + $ pack + $ normalizePathSegments + $ normalizeEscape + $ normalizeCase + $ uriToString (const "") u [] diff --git a/authenticate/OpenId2/Types.hs b/authenticate/OpenId2/Types.hs new file mode 100644 index 00000000..cb524c1b --- /dev/null +++ b/authenticate/OpenId2/Types.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Types +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Types ( + Provider (..) + , Identifier (..) + , IdentType (..) + , AuthenticateException (..) + ) where + +-- Libraries +import Data.Data (Data) +import Data.Typeable (Typeable) +import Web.Authenticate.Internal +import Data.Text (Text) + +-- | An OpenID provider. +newtype Provider = Provider { providerURI :: Text } deriving (Eq,Show) + +-- | A valid OpenID identifier. +newtype Identifier = Identifier { identifier :: Text } + deriving (Eq, Ord, Show, Read, Data, Typeable) + +data IdentType = OPIdent | ClaimedIdent + deriving (Eq, Ord, Show, Read, Data, Typeable) diff --git a/authenticate/OpenId2/XRDS.hs b/authenticate/OpenId2/XRDS.hs new file mode 100644 index 00000000..96771ff5 --- /dev/null +++ b/authenticate/OpenId2/XRDS.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Text.XRDS +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.XRDS ( + -- * Types + XRDS + , Service(..) + + -- * Parsing + , parseXRDS + ) where + +-- Libraries +import Control.Monad ((>=>)) +import Data.Maybe (listToMaybe) +import Text.XML (parseLBS, def) +import Text.XML.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute) +import qualified Data.ByteString.Lazy as L +import Data.Text (Text) +import qualified Data.Text.Read + +-- Types ----------------------------------------------------------------------- + +type XRDS = [XRD] + +type XRD = [Service] + +data Service = Service + { serviceTypes :: [Text] + , serviceMediaTypes :: [Text] + , serviceURIs :: [Text] + , serviceLocalIDs :: [Text] + , servicePriority :: Maybe Int + } deriving Show + +parseXRDS :: L.ByteString -> Maybe XRDS +parseXRDS str = + either + (const Nothing) + (Just . parseXRDS' . fromDocument) + (parseLBS def str) + +parseXRDS' :: Cursor -> [[Service]] +parseXRDS' = element "{xri://$xrds}XRDS" &/ + element "{xri://$xrd*($v*2.0)}XRD" &| + parseXRD + +parseXRD :: Cursor -> [Service] +parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService + +parseService :: Cursor -> [Service] +parseService c = + if null types then [] else [Service + { serviceTypes = types + , serviceMediaTypes = mtypes + , serviceURIs = uris + , serviceLocalIDs = localids + , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe + }] + where + types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content + mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content + uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content + localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content + readMaybe t = + case Data.Text.Read.signed Data.Text.Read.decimal t of + Right (i, "") -> Just i + _ -> Nothing diff --git a/authenticate/Setup.lhs b/authenticate/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/authenticate/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/authenticate/Web/Authenticate/BrowserId.hs b/authenticate/Web/Authenticate/BrowserId.hs new file mode 100644 index 00000000..17ed0531 --- /dev/null +++ b/authenticate/Web/Authenticate/BrowserId.hs @@ -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 diff --git a/authenticate/Web/Authenticate/Internal.hs b/authenticate/Web/Authenticate/Internal.hs new file mode 100644 index 00000000..1cf83b10 --- /dev/null +++ b/authenticate/Web/Authenticate/Internal.hs @@ -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 diff --git a/authenticate/Web/Authenticate/OpenId.hs b/authenticate/Web/Authenticate/OpenId.hs new file mode 100644 index 00000000..a31d3d29 --- /dev/null +++ b/authenticate/Web/Authenticate/OpenId.hs @@ -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 diff --git a/authenticate/Web/Authenticate/OpenId/Providers.hs b/authenticate/Web/Authenticate/OpenId/Providers.hs new file mode 100644 index 00000000..e5673162 --- /dev/null +++ b/authenticate/Web/Authenticate/OpenId/Providers.hs @@ -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/" diff --git a/authenticate/Web/Authenticate/Rpxnow.hs b/authenticate/Web/Authenticate/Rpxnow.hs new file mode 100644 index 00000000..d9fd4063 --- /dev/null +++ b/authenticate/Web/Authenticate/Rpxnow.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +--------------------------------------------------------- +-- +-- Module : Web.Authenticate.Rpxnow +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Facilitates authentication with "http://rpxnow.com/". +-- +--------------------------------------------------------- +module Web.Authenticate.Rpxnow + ( Identifier (..) + , authenticate + , AuthenticateException (..) + ) where + +import Data.Aeson +import Network.HTTP.Conduit +import Control.Monad.IO.Class +import Data.Maybe +import Control.Monad +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Web.Authenticate.Internal +import Data.Data (Data) +import Data.Typeable (Typeable) +import Data.Attoparsec.Lazy (parse) +import qualified Data.Attoparsec.Lazy as AT +import Data.Text (Text) +import qualified Data.Aeson.Types +import qualified Data.HashMap.Lazy as Map +import Control.Applicative ((<$>), (<*>)) +import Control.Exception (throwIO) +import Data.Conduit (MonadBaseControl, MonadResource) + +-- | Information received from Rpxnow after a valid login. +data Identifier = Identifier + { identifier :: Text + , extraData :: [(Text, Text)] + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +-- | Attempt to log a user in. +authenticate :: (MonadResource m, MonadBaseControl IO m) + => String -- ^ API key given by RPXNOW. + -> String -- ^ Token passed by client. + -> Manager + -> m Identifier +authenticate apiKey token manager = do + let body = L.fromChunks + [ "apiKey=" + , S.pack apiKey + , "&token=" + , S.pack token + ] + req' <- liftIO $ parseUrl "https://rpxnow.com" + let req = + req' + { method = "POST" + , path = "api/v2/auth_info" + , requestHeaders = + [ ("Content-Type", "application/x-www-form-urlencoded") + ] + , requestBody = RequestBodyLBS body + } + res <- httpLbs req manager + let b = responseBody res + o <- unResult $ parse json b + --m <- fromMapping o + let mstat = flip Data.Aeson.Types.parse o $ \v -> + case v of + Object m -> m .: "stat" + _ -> mzero + case mstat of + Success "ok" -> return () + Success stat -> liftIO $ throwIO $ RpxnowException $ + "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b + _ -> liftIO $ throwIO $ RpxnowException "Now stat value found on Rpxnow response" + case Data.Aeson.Types.parse parseProfile o of + Success x -> return x + Error e -> liftIO $ throwIO $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e + +unResult :: MonadIO m => AT.Result a -> m a +unResult = either (liftIO . throwIO . RpxnowException) return . AT.eitherResult + +parseProfile :: Value -> Data.Aeson.Types.Parser Identifier +parseProfile (Object m) = do + profile <- m .: "profile" + Identifier + <$> (profile .: "identifier") + <*> return (mapMaybe go (Map.toList profile)) + where + go ("identifier", _) = Nothing + go (k, String v) = Just (k, v) + go _ = Nothing +parseProfile _ = mzero diff --git a/authenticate/authenticate.cabal b/authenticate/authenticate.cabal new file mode 100644 index 00000000..d96fbeba --- /dev/null +++ b/authenticate/authenticate.cabal @@ -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 +synopsis: Authentication methods for Haskell web applications. +description: + Focus is on third-party authentication methods, such as OpenID and BrowserID. + . + Note: Facebook support is now provided by the fb package: . +category: Web +stability: Stable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://github.com/yesodweb/authenticate + +library + build-depends: base >= 4 && < 5 + , aeson >= 0.5 + , http-conduit >= 1.5 + , tagsoup >= 0.12 + , transformers >= 0.1 + , bytestring >= 0.9 + , network + , case-insensitive >= 0.2 + , text + , http-types >= 0.6 + , xml-conduit >= 1.0 + , blaze-builder + , attoparsec + , containers + , unordered-containers + , conduit >= 0.5 + exposed-modules: Web.Authenticate.Rpxnow, + Web.Authenticate.OpenId, + Web.Authenticate.BrowserId, + Web.Authenticate.OpenId.Providers + other-modules: Web.Authenticate.Internal, + OpenId2.Discovery, + OpenId2.Normalization, + OpenId2.Types, + OpenId2.XRDS + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/yesodweb/authenticate.git diff --git a/authenticate/browserid.hs b/authenticate/browserid.hs new file mode 100644 index 00000000..d83133ad --- /dev/null +++ b/authenticate/browserid.hs @@ -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| +

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

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

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

Nope, sorry +|] + +main = warp 3000 BID diff --git a/authenticate/openid2.hs b/authenticate/openid2.hs new file mode 100644 index 00000000..7e3c2e22 --- /dev/null +++ b/authenticate/openid2.hs @@ -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| +

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

Successfully logged in. + + + + +
OP Local + #{identifier $ oirOpLocal oir} +
Claimed + + $maybe c <- oirClaimed oir + \#{identifier c} + $nothing + none +
Params + + + $forall (k, v) <- oirParams oir + + +
#{k} + #{v} +
GET params + + + $forall (k, v) <- params + +
#{k} + #{v} +|] + +main :: IO () +main = toWaiApp OID >>= run 3000 diff --git a/authenticate/rpxnow.hs b/authenticate/rpxnow.hs new file mode 100644 index 00000000..e37d5580 --- /dev/null +++ b/authenticate/rpxnow.hs @@ -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| +