From 3ef8cc642d40e2b497804c9fd5b6c1909cce84c7 Mon Sep 17 00:00:00 2001 From: Snoyman Date: Fri, 8 May 2009 06:39:35 +0300 Subject: [PATCH 001/182] initial commit --- README | 1 + 1 file changed, 1 insertion(+) create mode 100644 README diff --git a/README b/README new file mode 100644 index 00000000..c953cbb8 --- /dev/null +++ b/README @@ -0,0 +1 @@ +Authentication methods for Haskell web applications. From 082e3241c7803e23dbff7f0c3d8f76e5947226a1 Mon Sep 17 00:00:00 2001 From: Snoyman Date: Fri, 8 May 2009 09:08:46 +0300 Subject: [PATCH 002/182] Rpxnow module written. --- .gitignore | 2 ++ LICENSE | 25 ++++++++++++++ Setup.lhs | 7 ++++ Web/Authenticate/Rpxnow.hs | 71 ++++++++++++++++++++++++++++++++++++++ authenticate.cabal | 18 ++++++++++ 5 files changed, 123 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100755 Setup.lhs create mode 100644 Web/Authenticate/Rpxnow.hs create mode 100644 authenticate.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..019dac95 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*.swp +dist diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..11dc17a1 --- /dev/null +++ b/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/Setup.lhs b/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs new file mode 100644 index 00000000..60d57be8 --- /dev/null +++ b/Web/Authenticate/Rpxnow.hs @@ -0,0 +1,71 @@ +--------------------------------------------------------- +-- | +-- 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 + ) where + +import Text.JSON +import Network.HTTP.Wget +import Data.Maybe (isJust, fromJust) + +-- | Information received from Rpxnow after a valid login. +data Identifier = Identifier + { identifier :: String + , extraData :: [(String, String)] + } + +-- | Attempt to log a user in. +authenticate :: Monad m + => String -- ^ API key given by RPXNOW. + -> String -- ^ Token passed by client. + -> IO (m Identifier) +authenticate apiKey token = do + body <- wget + "https://rpxnow.com/api/v2/auth_info" + [] + [ ("apiKey", apiKey) + , ("token", token) + ] + case body of + Left s -> return $ fail $ "Unable to connect to rpxnow: " ++ s + Right b -> + case decode b >>= getObject of + Error s -> return $ fail $ "Not a valid JSON response: " ++ s + Ok o -> + case valFromObj "stat" o of + Error _ -> return $ fail "Missing 'stat' field" + Ok "ok" -> return $ parseProfile o + Ok stat -> return $ fail $ "Login not accepted: " ++ stat + +parseProfile :: Monad m => JSObject JSValue -> m Identifier +parseProfile v = do + profile <- resultToMonad $ valFromObj "profile" v >>= getObject + ident <- resultToMonad $ valFromObj "identifier" profile + let pairs = fromJSObject profile + pairs' = filter (\(k, _) -> k /= "identifier") pairs + pairs'' = map fromJust . filter isJust . map takeString $ pairs' + return $ Identifier ident pairs'' + +takeString :: (String, JSValue) -> Maybe (String, String) +takeString (k, JSString v) = Just (k, fromJSString v) +takeString _ = Nothing + +getObject :: Monad m => JSValue -> m (JSObject JSValue) +getObject (JSObject o) = return o +getObject _ = fail "Not an object" + +resultToMonad :: Monad m => Result a -> m a +resultToMonad (Ok x) = return x +resultToMonad (Error s) = fail s diff --git a/authenticate.cabal b/authenticate.cabal new file mode 100644 index 00000000..547f2697 --- /dev/null +++ b/authenticate.cabal @@ -0,0 +1,18 @@ +name: authenticate +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: Authentication methods for Haskell web applications. +description: Focus is on remote authentication methods, such as OpenID, + rpxnow and Google. +category: Web +stability: unstable +cabal-version: >= 1.2 +build-type: Simple + +library + build-depends: base, json, http-wget + exposed-modules: Web.Authenticate.Rpxnow + ghc-options: -Wall From d920705bdec811285c342e6316922e5ee2b194fb Mon Sep 17 00:00:00 2001 From: Snoyman Date: Fri, 8 May 2009 10:29:35 +0300 Subject: [PATCH 003/182] Added openid authentication --- Web/Authenticate/OpenId.hs | 147 +++++++++++++++++++++++++++++++++++++ Web/Authenticate/Rpxnow.hs | 2 +- authenticate.cabal | 7 +- 3 files changed, 152 insertions(+), 4 deletions(-) create mode 100644 Web/Authenticate/OpenId.hs diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs new file mode 100644 index 00000000..367a8e51 --- /dev/null +++ b/Web/Authenticate/OpenId.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE FlexibleInstances #-} +--------------------------------------------------------- +-- | +-- Module : Web.Authenticate.OpenId +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Provides functionality for being an OpenId consumer. +-- +--------------------------------------------------------- +module Web.Authenticate.OpenId + ( Identifier (..) + , getForwardUrl + , authenticate + ) where + +import Data.Maybe (fromMaybe, fromJust) +import Network.HTTP.Wget +import Text.HTML.TagSoup +import Numeric (showHex) + +-- | An openid identifier (ie, a URL). +data Identifier = Identifier { identifier :: String } + +instance Monad (Either String) where + return = Right + fail = Left + (Left s) >>= _ = Left s + (Right x) >>= f = f x + +-- | Returns a URL to forward the user to in order to login. +getForwardUrl :: Monad m + => String -- ^ The openid the user provided. + -> String -- ^ The URL for this application\'s complete page. + -> IO (m String) -- ^ URL to send the user to. +getForwardUrl openid complete = do + bodyIdent' <- wget openid [] [] + case bodyIdent' of + Left s -> return $ fail s + Right bodyIdent -> do + server <- getOpenIdVar "server" bodyIdent + let delegate = fromMaybe openid $ getOpenIdVar "delegate" bodyIdent + return $ return $ constructUrl server + [ ("openid.mode", "checkid_setup") + , ("openid.identity", delegate) + , ("openid.return_to", complete) + ] + +getOpenIdVar :: Monad m => String -> String -> m String +getOpenIdVar var content = do + let tags = parseTags content + let secs = sections (~== ("")) tags + secs' <- mhead secs + secs'' <- mhead secs' + return $ fromAttrib "href" secs'' + where + mhead [] = fail $ "Variable not found: openid." ++ var + mhead (x:_) = return x + +constructUrl :: String -> [(String, String)] -> String +constructUrl url [] = url +constructUrl url args = url ++ "?" ++ queryString args + where + queryString [] = error "queryString with empty args cannot happen" + queryString [first] = onePair first + queryString (first:rest) = onePair first ++ "&" ++ queryString rest + onePair (x, y) = urlEncode x ++ "=" ++ urlEncode y + +-- | Handle a redirect from an OpenID provider and check that the user +-- logged in properly. If it was successfully, 'return's the openid. +-- Otherwise, 'fail's an explanation. +authenticate :: Monad m => [(String, String)] -> IO (m Identifier) +authenticate req = do -- FIXME check openid.mode == id_res (not cancel) + authUrl' <- getAuthUrl req + case authUrl' of + Nothing -> return $ fail "Invalid parameters" + Just authUrl -> do + content' <- wget authUrl [] [] + case content' of + Left s -> return $ fail s + Right content -> do + let isValid = contains "is_valid:true" content + if isValid + then return $ + return $ Identifier + (fromJust $ lookup "openid.identity" req) + else return $ fail content + +getAuthUrl :: [(String, String)] -> IO (Maybe String) +getAuthUrl req = do + let identity' = lookup "openid.identity" req + case identity' of + Nothing -> return Nothing + Just identity -> do + idContent <- wget identity [] [] + case idContent of + Nothing -> return Nothing + Just x -> return $ helper x + where + helper :: String -> Maybe String + helper idContent = do + server <- getOpenIdVar "server" idContent + dargs <- mapM makeArg [ + "assoc_handle", + "sig", + "signed", + "identity", + "return_to" + ] + let sargs = [("openid.mode", "check_authentication")] + return $ constructUrl server $ dargs ++ sargs + makeArg :: String -> Maybe (String, String) + makeArg s = do + let k = "openid." ++ s + v <- lookup k req + return (k, v) + +contains :: String -> String -> Bool +contains [] _ = True +contains _ [] = False +contains needle haystack = + begins needle haystack || + (contains needle $ tail haystack) + +begins :: String -> String -> Bool +begins [] _ = True +begins _ [] = False +begins (x:xs) (y:ys) = x == y && begins xs ys + +urlEncode :: String -> String +urlEncode = concatMap urlEncodeChar + +urlEncodeChar :: Char -> String +urlEncodeChar x + | safeChar (fromEnum x) = return x + | otherwise = '%' : showHex (fromEnum x) "" + +safeChar :: Int -> Bool +safeChar x + | x >= fromEnum 'a' && x <= fromEnum 'z' = True + | x >= fromEnum 'A' && x <= fromEnum 'Z' = True + | x >= fromEnum '0' && x <= fromEnum '9' = True + | otherwise = False diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index 60d57be8..d7f8d279 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -1,5 +1,5 @@ --------------------------------------------------------- --- | +-- -- Module : Web.Authenticate.Rpxnow -- Copyright : Michael Snoyman -- License : BSD3 diff --git a/authenticate.cabal b/authenticate.cabal index 547f2697..0c918014 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -13,6 +13,7 @@ cabal-version: >= 1.2 build-type: Simple library - build-depends: base, json, http-wget - exposed-modules: Web.Authenticate.Rpxnow - ghc-options: -Wall + build-depends: base, json, http-wget, tagsoup + exposed-modules: Web.Authenticate.Rpxnow, + Web.Authenticate.OpenId + ghc-options: -Wall -fno-warn-orphans From c856808955e4cffaf7e3c3e2fa1303e0c3b32c8f Mon Sep 17 00:00:00 2001 From: Snoyman Date: Fri, 8 May 2009 13:21:01 +0300 Subject: [PATCH 004/182] Added link to github page in cabal file --- authenticate.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/authenticate.cabal b/authenticate.cabal index 0c918014..fb15e7d0 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -11,6 +11,7 @@ category: Web stability: unstable cabal-version: >= 1.2 build-type: Simple +homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base, json, http-wget, tagsoup From 1f3d9e8791d6ca3386ab3703ca1f41d1512db95c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 1 Jun 2009 23:24:28 +0300 Subject: [PATCH 005/182] Removed the (Either String) monad instance for better interop with mtl --- Web/Authenticate/OpenId.hs | 19 ++++++++++--------- authenticate.cabal | 2 +- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 367a8e51..e1141032 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -26,11 +26,12 @@ import Numeric (showHex) -- | An openid identifier (ie, a URL). data Identifier = Identifier { identifier :: String } -instance Monad (Either String) where - return = Right - fail = Left - (Left s) >>= _ = Left s - (Right x) >>= f = f x +data Error v = Error String | Ok v +instance Monad Error where + return = Ok + Error s >>= _ = Error s + Ok v >>= f = f v + fail s = Error s -- | Returns a URL to forward the user to in order to login. getForwardUrl :: Monad m @@ -40,8 +41,8 @@ getForwardUrl :: Monad m getForwardUrl openid complete = do bodyIdent' <- wget openid [] [] case bodyIdent' of - Left s -> return $ fail s - Right bodyIdent -> do + Error s -> return $ fail s + Ok bodyIdent -> do server <- getOpenIdVar "server" bodyIdent let delegate = fromMaybe openid $ getOpenIdVar "delegate" bodyIdent return $ return $ constructUrl server @@ -81,8 +82,8 @@ authenticate req = do -- FIXME check openid.mode == id_res (not cancel) Just authUrl -> do content' <- wget authUrl [] [] case content' of - Left s -> return $ fail s - Right content -> do + Error s -> return $ fail s + Ok content -> do let isValid = contains "is_valid:true" content if isValid then return $ diff --git a/authenticate.cabal b/authenticate.cabal index fb15e7d0..6b7a2576 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.0.0 +version: 0.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From 1b55ea26eed0b2d0aa47f5a0527a0629468c827b Mon Sep 17 00:00:00 2001 From: dbpatterson Date: Sun, 12 Jul 2009 17:21:55 -0400 Subject: [PATCH 006/182] troubleshooting info for Rpxnow --- README | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/README b/README index c953cbb8..219baebf 100644 --- a/README +++ b/README @@ -1 +1,10 @@ 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. \ No newline at end of file From edd163da3372daa14f211bc47cc4bf1c6a51c7e7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 14 Jul 2009 20:52:09 +0300 Subject: [PATCH 007/182] Formatted README a bit --- README | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/README b/README index 219baebf..c2ba6ace 100644 --- a/README +++ b/README @@ -1,10 +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. +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: +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. \ No newline at end of file +This should fix the problem. From 9fe332dc33765062fdaf6e43bdaaa1e8e5ceea0c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 21 Oct 2009 00:58:34 +0200 Subject: [PATCH 008/182] Switch to MonadAttempt for error handling --- Web/Authenticate/OpenId.hs | 81 ++++++++++++++++++-------------------- Web/Authenticate/Rpxnow.hs | 30 +++++++------- authenticate.cabal | 10 ++++- 3 files changed, 62 insertions(+), 59 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index e1141032..a99acc2f 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- | -- Module : Web.Authenticate.OpenId @@ -18,10 +19,15 @@ module Web.Authenticate.OpenId , authenticate ) where -import Data.Maybe (fromMaybe, fromJust) import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex) +import Control.Monad.Trans +import Control.Monad.Attempt.Class +import qualified Data.Attempt.Helper as A +import Data.Generics +import Data.Attempt +import Control.Exception -- | An openid identifier (ie, a URL). data Identifier = Identifier { identifier :: String } @@ -34,24 +40,22 @@ instance Monad Error where fail s = Error s -- | Returns a URL to forward the user to in order to login. -getForwardUrl :: Monad m +getForwardUrl :: (MonadIO m, MonadAttempt m) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. - -> IO (m String) -- ^ URL to send the user to. + -> m String -- ^ URL to send the user to. getForwardUrl openid complete = do - bodyIdent' <- wget openid [] [] - case bodyIdent' of - Error s -> return $ fail s - Ok bodyIdent -> do - server <- getOpenIdVar "server" bodyIdent - let delegate = fromMaybe openid $ getOpenIdVar "delegate" bodyIdent - return $ return $ constructUrl server - [ ("openid.mode", "checkid_setup") - , ("openid.identity", delegate) - , ("openid.return_to", complete) - ] + bodyIdent <- wget openid [] [] + server <- getOpenIdVar "server" bodyIdent + let delegate = attempt (const openid) id + $ getOpenIdVar "delegate" bodyIdent + return $ constructUrl server + [ ("openid.mode", "checkid_setup") + , ("openid.identity", delegate) + , ("openid.return_to", complete) + ] -getOpenIdVar :: Monad m => String -> String -> m String +getOpenIdVar :: MonadAttempt m => String -> String -> m String getOpenIdVar var content = do let tags = parseTags content let secs = sections (~== ("")) tags @@ -74,35 +78,28 @@ constructUrl url args = url ++ "?" ++ queryString args -- | Handle a redirect from an OpenID provider and check that the user -- logged in properly. If it was successfully, 'return's the openid. -- Otherwise, 'fail's an explanation. -authenticate :: Monad m => [(String, String)] -> IO (m Identifier) +authenticate :: (MonadIO m, MonadAttempt m) + => [(String, String)] + -> m Identifier authenticate req = do -- FIXME check openid.mode == id_res (not cancel) - authUrl' <- getAuthUrl req - case authUrl' of - Nothing -> return $ fail "Invalid parameters" - Just authUrl -> do - content' <- wget authUrl [] [] - case content' of - Error s -> return $ fail s - Ok content -> do - let isValid = contains "is_valid:true" content - if isValid - then return $ - return $ Identifier - (fromJust $ lookup "openid.identity" req) - else return $ fail content + authUrl <- getAuthUrl req + content <- wget authUrl [] [] + let isValid = contains "is_valid:true" content + if isValid + then A.lookup "openid.identity" req >>= return . Identifier + else failure $ AuthenticateError content -getAuthUrl :: [(String, String)] -> IO (Maybe String) +newtype AuthenticateError = AuthenticateError String + deriving (Show, Typeable) +instance Exception AuthenticateError + +getAuthUrl :: (MonadIO m, MonadAttempt m) => [(String, String)] -> m String getAuthUrl req = do - let identity' = lookup "openid.identity" req - case identity' of - Nothing -> return Nothing - Just identity -> do - idContent <- wget identity [] [] - case idContent of - Nothing -> return Nothing - Just x -> return $ helper x + identity <- A.lookup "openid.identity" req + idContent <- wget identity [] [] + helper idContent where - helper :: String -> Maybe String + helper :: MonadAttempt m => String -> m String helper idContent = do server <- getOpenIdVar "server" idContent dargs <- mapM makeArg [ @@ -114,10 +111,10 @@ getAuthUrl req = do ] let sargs = [("openid.mode", "check_authentication")] return $ constructUrl server $ dargs ++ sargs - makeArg :: String -> Maybe (String, String) + makeArg :: MonadAttempt m => String -> m (String, String) makeArg s = do let k = "openid." ++ s - v <- lookup k req + v <- A.lookup k req return (k, v) contains :: String -> String -> Bool diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index d7f8d279..c6449d9d 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -16,9 +16,11 @@ module Web.Authenticate.Rpxnow , authenticate ) where -import Text.JSON +import Text.JSON -- FIXME use Data.Object.JSON import Network.HTTP.Wget import Data.Maybe (isJust, fromJust) +import Control.Monad.Trans +import Control.Monad.Attempt.Class -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -27,29 +29,27 @@ data Identifier = Identifier } -- | Attempt to log a user in. -authenticate :: Monad m +authenticate :: (MonadIO m, MonadAttempt m) => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client. - -> IO (m Identifier) + -> m Identifier authenticate apiKey token = do - body <- wget + b <- wget "https://rpxnow.com/api/v2/auth_info" [] [ ("apiKey", apiKey) , ("token", token) ] - case body of - Left s -> return $ fail $ "Unable to connect to rpxnow: " ++ s - Right b -> - case decode b >>= getObject of - Error s -> return $ fail $ "Not a valid JSON response: " ++ s - Ok o -> - case valFromObj "stat" o of - Error _ -> return $ fail "Missing 'stat' field" - Ok "ok" -> return $ parseProfile o - Ok stat -> return $ fail $ "Login not accepted: " ++ stat + case decode b >>= getObject of + Error s -> failureString $ "Not a valid JSON response: " ++ s + Ok o -> + case valFromObj "stat" o of + Error _ -> failureString "Missing 'stat' field" + Ok "ok" -> parseProfile o + Ok stat -> failureString $ "Login not accepted: " ++ stat + ++ "\n" ++ b -parseProfile :: Monad m => JSObject JSValue -> m Identifier +parseProfile :: MonadAttempt m => JSObject JSValue -> m Identifier parseProfile v = do profile <- resultToMonad $ valFromObj "profile" v >>= getObject ident <- resultToMonad $ valFromObj "identifier" profile diff --git a/authenticate.cabal b/authenticate.cabal index 6b7a2576..dfffc280 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.0.1 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -14,7 +14,13 @@ build-type: Simple homepage: http://github.com/snoyberg/authenticate/tree/master library - build-depends: base, json, http-wget, tagsoup + build-depends: base >= 4 && < 5, + json, + http-wget >= 0.2.0, + tagsoup, + attempt, + transformers >= 0.1.4.0, + syb exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId ghc-options: -Wall -fno-warn-orphans From e60354ebe1609d8e09e6874f7bf7556ef05a2d2c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 25 Oct 2009 22:58:20 +0200 Subject: [PATCH 009/182] data -> newtype for Identifier --- Web/Authenticate/OpenId.hs | 6 +++--- authenticate.cabal | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index a99acc2f..d2e87e3d 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -23,14 +23,14 @@ import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex) import Control.Monad.Trans -import Control.Monad.Attempt.Class import qualified Data.Attempt.Helper as A import Data.Generics import Data.Attempt import Control.Exception -- | An openid identifier (ie, a URL). -data Identifier = Identifier { identifier :: String } +newtype Identifier = Identifier { identifier :: String } + deriving (Eq, Show) data Error v = Error String | Ok v instance Monad Error where @@ -77,7 +77,7 @@ constructUrl url args = url ++ "?" ++ queryString args -- | Handle a redirect from an OpenID provider and check that the user -- logged in properly. If it was successfully, 'return's the openid. --- Otherwise, 'fail's an explanation. +-- Otherwise, 'failure's an explanation. authenticate :: (MonadIO m, MonadAttempt m) => [(String, String)] -> m Identifier diff --git a/authenticate.cabal b/authenticate.cabal index dfffc280..b50a2c8c 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -8,7 +8,7 @@ synopsis: Authentication methods for Haskell web applications. description: Focus is on remote authentication methods, such as OpenID, rpxnow and Google. category: Web -stability: unstable +stability: Stable cabal-version: >= 1.2 build-type: Simple homepage: http://github.com/snoyberg/authenticate/tree/master From 83d2d25d34b3ac1774ed66e08783a605456798f9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Nov 2009 15:13:36 +0200 Subject: [PATCH 010/182] Migration to control-monad-failure --- Web/Authenticate/OpenId.hs | 33 ++++++++++++++++++++------------- Web/Authenticate/Rpxnow.hs | 9 +++++---- authenticate.cabal | 7 ++++--- 3 files changed, 29 insertions(+), 20 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index d2e87e3d..754b4751 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- | -- Module : Web.Authenticate.OpenId @@ -23,9 +24,9 @@ import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex) import Control.Monad.Trans -import qualified Data.Attempt.Helper as A +import qualified Safe.Failure as A import Data.Generics -import Data.Attempt +import Control.Monad.Failure import Control.Exception -- | An openid identifier (ie, a URL). @@ -40,14 +41,14 @@ instance Monad Error where fail s = Error s -- | Returns a URL to forward the user to in order to login. -getForwardUrl :: (MonadIO m, MonadAttempt m) +getForwardUrl :: (MonadIO m, MonadFailure WgetException m) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. getForwardUrl openid complete = do bodyIdent <- wget openid [] [] server <- getOpenIdVar "server" bodyIdent - let delegate = attempt (const openid) id + let delegate = maybe openid id $ getOpenIdVar "delegate" bodyIdent return $ constructUrl server [ ("openid.mode", "checkid_setup") @@ -55,7 +56,7 @@ getForwardUrl openid complete = do , ("openid.return_to", complete) ] -getOpenIdVar :: MonadAttempt m => String -> String -> m String +getOpenIdVar :: Monad m => String -> String -> m String getOpenIdVar var content = do let tags = parseTags content let secs = sections (~== ("")) tags @@ -63,7 +64,7 @@ getOpenIdVar var content = do secs'' <- mhead secs' return $ fromAttrib "href" secs'' where - mhead [] = fail $ "Variable not found: openid." ++ var + mhead [] = fail $ "Variable not found: openid." ++ var -- FIXME mhead (x:_) = return x constructUrl :: String -> [(String, String)] -> String @@ -78,7 +79,9 @@ constructUrl url args = url ++ "?" ++ queryString args -- | Handle a redirect from an OpenID provider and check that the user -- logged in properly. If it was successfully, 'return's the openid. -- Otherwise, 'failure's an explanation. -authenticate :: (MonadIO m, MonadAttempt m) +authenticate :: (MonadIO m, MonadFailure WgetException m, + MonadFailure (A.LookupFailure String) m, + MonadFailure AuthenticateException m) => [(String, String)] -> m Identifier authenticate req = do -- FIXME check openid.mode == id_res (not cancel) @@ -87,19 +90,22 @@ authenticate req = do -- FIXME check openid.mode == id_res (not cancel) let isValid = contains "is_valid:true" content if isValid then A.lookup "openid.identity" req >>= return . Identifier - else failure $ AuthenticateError content + else failure $ AuthenticateException content -newtype AuthenticateError = AuthenticateError String +newtype AuthenticateException = AuthenticateException String deriving (Show, Typeable) -instance Exception AuthenticateError +instance Exception AuthenticateException -getAuthUrl :: (MonadIO m, MonadAttempt m) => [(String, String)] -> m String +getAuthUrl :: (MonadIO m, MonadFailure (A.LookupFailure String) m, + MonadFailure WgetException m) + => [(String, String)] -> m String getAuthUrl req = do identity <- A.lookup "openid.identity" req idContent <- wget identity [] [] helper idContent where - helper :: MonadAttempt m => String -> m String + helper :: MonadFailure (A.LookupFailure String) m + => String -> m String helper idContent = do server <- getOpenIdVar "server" idContent dargs <- mapM makeArg [ @@ -111,7 +117,8 @@ getAuthUrl req = do ] let sargs = [("openid.mode", "check_authentication")] return $ constructUrl server $ dargs ++ sargs - makeArg :: MonadAttempt m => String -> m (String, String) + makeArg :: MonadFailure (A.LookupFailure String) m + => String -> m (String, String) makeArg s = do let k = "openid." ++ s v <- A.lookup k req diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index c6449d9d..337ec927 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow @@ -20,7 +21,7 @@ import Text.JSON -- FIXME use Data.Object.JSON import Network.HTTP.Wget import Data.Maybe (isJust, fromJust) import Control.Monad.Trans -import Control.Monad.Attempt.Class +import Control.Monad.Failure -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -29,7 +30,7 @@ data Identifier = Identifier } -- | Attempt to log a user in. -authenticate :: (MonadIO m, MonadAttempt m) +authenticate :: (MonadIO m, MonadFailure WgetException m, MonadFailure StringException m) => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client. -> m Identifier @@ -41,7 +42,7 @@ authenticate apiKey token = do , ("token", token) ] case decode b >>= getObject of - Error s -> failureString $ "Not a valid JSON response: " ++ s + Error s -> failureString $ "Not a valid JSON response: " ++ s -- FIXME Ok o -> case valFromObj "stat" o of Error _ -> failureString "Missing 'stat' field" @@ -49,7 +50,7 @@ authenticate apiKey token = do Ok stat -> failureString $ "Login not accepted: " ++ stat ++ "\n" ++ b -parseProfile :: MonadAttempt m => JSObject JSValue -> m Identifier +parseProfile :: Monad m => JSObject JSValue -> m Identifier parseProfile v = do profile <- resultToMonad $ valFromObj "profile" v >>= getObject ident <- resultToMonad $ valFromObj "identifier" profile diff --git a/authenticate.cabal b/authenticate.cabal index b50a2c8c..48f90f1f 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.2.0 +version: 0.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -16,9 +16,10 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, json, - http-wget >= 0.2.0, + http-wget >= 0.2.1, tagsoup, - attempt, + control-monad-failure, + safe-failure, transformers >= 0.1.4.0, syb exposed-modules: Web.Authenticate.Rpxnow, From cb7bdb6567ba1139a4d88a686d3af35d072832b0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 6 Dec 2009 00:43:24 +0200 Subject: [PATCH 011/182] c-m-f to failure --- Web/Authenticate/OpenId.hs | 2 +- Web/Authenticate/Rpxnow.hs | 2 +- authenticate.cabal | 14 +++++++------- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 754b4751..0f09bacc 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -26,7 +26,7 @@ import Numeric (showHex) import Control.Monad.Trans import qualified Safe.Failure as A import Data.Generics -import Control.Monad.Failure +import Control.Failure import Control.Exception -- | An openid identifier (ie, a URL). diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index 337ec927..472a8d9d 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -21,7 +21,7 @@ import Text.JSON -- FIXME use Data.Object.JSON import Network.HTTP.Wget import Data.Maybe (isJust, fromJust) import Control.Monad.Trans -import Control.Monad.Failure +import Control.Failure -- | Information received from Rpxnow after a valid login. data Identifier = Identifier diff --git a/authenticate.cabal b/authenticate.cabal index 48f90f1f..ad71ee3f 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.2.1 +version: 0.4.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -15,12 +15,12 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, - json, - http-wget >= 0.2.1, - tagsoup, - control-monad-failure, - safe-failure, - transformers >= 0.1.4.0, + json >= 0.4.3 && < 0.5, + http-wget >= 0.4.0 && < 0.5, + tagsoup >= 0.6 && < 0.7, + failure >= 0.0.0 && < 0.1, + safe-failure >= 0.4 && < 0.5, + transformers >= 0.1.4.0 && < 0.2, syb exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId From ad243856a2ff0be12e8908c2e88c256d854742d5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 9 Feb 2010 17:20:03 +0200 Subject: [PATCH 012/182] Allow tagsoup 0.8 --- Web/Authenticate/OpenId.hs | 2 +- authenticate.cabal | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 0f09bacc..651ff98c 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -26,7 +26,7 @@ import Numeric (showHex) import Control.Monad.Trans import qualified Safe.Failure as A import Data.Generics -import Control.Failure +import Control.Failure hiding (Error) import Control.Exception -- | An openid identifier (ie, a URL). diff --git a/authenticate.cabal b/authenticate.cabal index ad71ee3f..1bf9b560 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.4.0 +version: 0.4.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,7 +17,7 @@ library build-depends: base >= 4 && < 5, json >= 0.4.3 && < 0.5, http-wget >= 0.4.0 && < 0.5, - tagsoup >= 0.6 && < 0.7, + tagsoup >= 0.6 && < 0.9, failure >= 0.0.0 && < 0.1, safe-failure >= 0.4 && < 0.5, transformers >= 0.1.4.0 && < 0.2, From 59753521a214e649cac38bb9f41ca8787baf67ae Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 11 Apr 2010 13:20:04 -0700 Subject: [PATCH 013/182] transformers 0.2 --- Web/Authenticate/OpenId.hs | 2 +- Web/Authenticate/Rpxnow.hs | 2 +- authenticate.cabal | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 651ff98c..d5409f34 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -23,7 +23,7 @@ module Web.Authenticate.OpenId import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex) -import Control.Monad.Trans +import Control.Monad.IO.Class import qualified Safe.Failure as A import Data.Generics import Control.Failure hiding (Error) diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index 472a8d9d..f73d5071 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -20,7 +20,7 @@ module Web.Authenticate.Rpxnow import Text.JSON -- FIXME use Data.Object.JSON import Network.HTTP.Wget import Data.Maybe (isJust, fromJust) -import Control.Monad.Trans +import Control.Monad.IO.Class import Control.Failure -- | Information received from Rpxnow after a valid login. diff --git a/authenticate.cabal b/authenticate.cabal index 1bf9b560..cd94350a 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.4.0.1 +version: 0.6.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -16,11 +16,11 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, json >= 0.4.3 && < 0.5, - http-wget >= 0.4.0 && < 0.5, + http-wget >= 0.6 && < 0.7, tagsoup >= 0.6 && < 0.9, failure >= 0.0.0 && < 0.1, safe-failure >= 0.4 && < 0.5, - transformers >= 0.1.4.0 && < 0.2, + transformers >= 0.2 && < 0.3, syb exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId From 4590d4afad2cafc2dd5056121aaab0d4249dcbf8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 25 Apr 2010 11:12:56 -0700 Subject: [PATCH 014/182] Add back transformers 0.1 support --- Web/Authenticate/OpenId.hs | 7 ++++++- Web/Authenticate/Rpxnow.hs | 5 +++++ authenticate.cabal | 11 +++++++++-- 3 files changed, 20 insertions(+), 3 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index d5409f34..7e66ac7c 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- | -- Module : Web.Authenticate.OpenId @@ -23,8 +24,12 @@ module Web.Authenticate.OpenId import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex) -import Control.Monad.IO.Class import qualified Safe.Failure as A +#if TRANSFORMERS_02 +import Control.Monad.IO.Class +#else +import Control.Monad.Trans +#endif import Data.Generics import Control.Failure hiding (Error) import Control.Exception diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index f73d5071..e015329b 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow @@ -20,7 +21,11 @@ module Web.Authenticate.Rpxnow import Text.JSON -- FIXME use Data.Object.JSON import Network.HTTP.Wget import Data.Maybe (isJust, fromJust) +#if TRANSFORMERS_02 import Control.Monad.IO.Class +#else +import Control.Monad.Trans +#endif import Control.Failure -- | Information received from Rpxnow after a valid login. diff --git a/authenticate.cabal b/authenticate.cabal index cd94350a..11c698d6 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.0 +version: 0.6.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -13,6 +13,9 @@ cabal-version: >= 1.2 build-type: Simple homepage: http://github.com/snoyberg/authenticate/tree/master +flag transformers_02 + description: transformers = 0.2.* + library build-depends: base >= 4 && < 5, json >= 0.4.3 && < 0.5, @@ -20,8 +23,12 @@ library tagsoup >= 0.6 && < 0.9, failure >= 0.0.0 && < 0.1, safe-failure >= 0.4 && < 0.5, - transformers >= 0.2 && < 0.3, syb + if flag(transformers_02) + build-depends: transformers >= 0.2 && < 0.3 + CPP-OPTIONS: -DTRANSFORMERS_02 + else + build-depends: transformers >= 0.1 && < 0.2 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId ghc-options: -Wall -fno-warn-orphans From a8800d61d7b056c99f74415d4460d9597a06f67b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 9 May 2010 22:46:26 +0300 Subject: [PATCH 015/182] Bumped tagsoup --- authenticate.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/authenticate.cabal b/authenticate.cabal index 11c698d6..46dc1019 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.0.1 +version: 0.6.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -20,7 +20,7 @@ library build-depends: base >= 4 && < 5, json >= 0.4.3 && < 0.5, http-wget >= 0.6 && < 0.7, - tagsoup >= 0.6 && < 0.9, + tagsoup >= 0.6 && < 0.10, failure >= 0.0.0 && < 0.1, safe-failure >= 0.4 && < 0.5, syb From 4c00bd205804efb547e6ceace8fbe9af17d00d48 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 13 May 2010 23:33:38 +0300 Subject: [PATCH 016/182] Switch to data-object-json --- Web/Authenticate/OpenId.hs | 45 ++++++++++++---------- Web/Authenticate/Rpxnow.hs | 77 ++++++++++++++++++-------------------- authenticate.cabal | 19 +++------- 3 files changed, 69 insertions(+), 72 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 7e66ac7c..d9f0ff8e 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} --------------------------------------------------------- -- | -- Module : Web.Authenticate.OpenId @@ -19,20 +20,21 @@ module Web.Authenticate.OpenId ( Identifier (..) , getForwardUrl , authenticate + , AuthenticateException (..) ) where import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex) -import qualified Safe.Failure as A -#if TRANSFORMERS_02 -import Control.Monad.IO.Class +#if MIN_VERSION_transformers(0,2,0) +import "transformers" Control.Monad.IO.Class #else -import Control.Monad.Trans +import "transformers" Control.Monad.Trans #endif -import Data.Generics +import Data.Data import Control.Failure hiding (Error) import Control.Exception +import Control.Monad (liftM) -- | An openid identifier (ie, a URL). newtype Identifier = Identifier { identifier :: String } @@ -46,7 +48,7 @@ instance Monad Error where fail s = Error s -- | Returns a URL to forward the user to in order to login. -getForwardUrl :: (MonadIO m, MonadFailure WgetException m) +getForwardUrl :: (MonadIO m, Failure WgetException m) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. @@ -84,9 +86,8 @@ constructUrl url args = url ++ "?" ++ queryString args -- | Handle a redirect from an OpenID provider and check that the user -- logged in properly. If it was successfully, 'return's the openid. -- Otherwise, 'failure's an explanation. -authenticate :: (MonadIO m, MonadFailure WgetException m, - MonadFailure (A.LookupFailure String) m, - MonadFailure AuthenticateException m) +authenticate :: (MonadIO m, Failure WgetException m, + Failure AuthenticateException m) => [(String, String)] -> m Identifier authenticate req = do -- FIXME check openid.mode == id_res (not cancel) @@ -94,23 +95,31 @@ authenticate req = do -- FIXME check openid.mode == id_res (not cancel) content <- wget authUrl [] [] let isValid = contains "is_valid:true" content if isValid - then A.lookup "openid.identity" req >>= return . Identifier + then Identifier `liftM` alookup "openid.identity" req else failure $ AuthenticateException content -newtype AuthenticateException = AuthenticateException String +alookup :: (Failure AuthenticateException m, Monad m) + => String + -> [(String, String)] + -> m String +alookup k x = case lookup k x of + Just k -> return k + Nothing -> failure $ MissingOpenIdParameter k + +data AuthenticateException = AuthenticateException String + | MissingOpenIdParameter String deriving (Show, Typeable) instance Exception AuthenticateException -getAuthUrl :: (MonadIO m, MonadFailure (A.LookupFailure String) m, - MonadFailure WgetException m) +getAuthUrl :: (MonadIO m, + Failure AuthenticateException m, + Failure WgetException m) => [(String, String)] -> m String getAuthUrl req = do - identity <- A.lookup "openid.identity" req + identity <- alookup "openid.identity" req idContent <- wget identity [] [] helper idContent where - helper :: MonadFailure (A.LookupFailure String) m - => String -> m String helper idContent = do server <- getOpenIdVar "server" idContent dargs <- mapM makeArg [ @@ -122,11 +131,9 @@ getAuthUrl req = do ] let sargs = [("openid.mode", "check_authentication")] return $ constructUrl server $ dargs ++ sargs - makeArg :: MonadFailure (A.LookupFailure String) m - => String -> m (String, String) makeArg s = do let k = "openid." ++ s - v <- A.lookup k req + v <- alookup k req return (k, v) contains :: String -> String -> Bool diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index e015329b..d9698998 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow @@ -18,15 +19,19 @@ module Web.Authenticate.Rpxnow , authenticate ) where -import Text.JSON -- FIXME use Data.Object.JSON +import Data.Object +import Data.Object.Json import Network.HTTP.Wget -import Data.Maybe (isJust, fromJust) -#if TRANSFORMERS_02 -import Control.Monad.IO.Class +#if MIN_VERSION_transformers(0,2,0) +import "transformers" Control.Monad.IO.Class #else -import Control.Monad.Trans +import "transformers" Control.Monad.Trans #endif import Control.Failure +import Data.Maybe +import Web.Authenticate.OpenId (AuthenticateException (..)) +import Control.Monad +import Data.ByteString.Char8 (pack) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -35,43 +40,35 @@ data Identifier = Identifier } -- | Attempt to log a user in. -authenticate :: (MonadIO m, MonadFailure WgetException m, MonadFailure StringException m) +authenticate :: (MonadIO m, + Failure WgetException m, + Failure AuthenticateException m, + Failure ObjectExtractError m, + Failure JsonDecodeError m) => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client. -> m Identifier authenticate apiKey token = do - b <- wget - "https://rpxnow.com/api/v2/auth_info" - [] - [ ("apiKey", apiKey) - , ("token", token) - ] - case decode b >>= getObject of - Error s -> failureString $ "Not a valid JSON response: " ++ s -- FIXME - Ok o -> - case valFromObj "stat" o of - Error _ -> failureString "Missing 'stat' field" - Ok "ok" -> parseProfile o - Ok stat -> failureString $ "Login not accepted: " ++ stat - ++ "\n" ++ b + b <- wget "https://rpxnow.com/api/v2/auth_info" + [] + [ ("apiKey", apiKey) + , ("token", token) + ] + o <- decode $ pack b + m <- fromMapping o + stat <- lookupScalar "stat" m + unless (stat == "ok") $ failure $ AuthenticateException $ + "Rpxnow login not accepted: " ++ stat ++ "\n" ++ b + parseProfile m -parseProfile :: Monad m => JSObject JSValue -> m Identifier -parseProfile v = do - profile <- resultToMonad $ valFromObj "profile" v >>= getObject - ident <- resultToMonad $ valFromObj "identifier" profile - let pairs = fromJSObject profile - pairs' = filter (\(k, _) -> k /= "identifier") pairs - pairs'' = map fromJust . filter isJust . map takeString $ pairs' - return $ Identifier ident pairs'' - -takeString :: (String, JSValue) -> Maybe (String, String) -takeString (k, JSString v) = Just (k, fromJSString v) -takeString _ = Nothing - -getObject :: Monad m => JSValue -> m (JSObject JSValue) -getObject (JSObject o) = return o -getObject _ = fail "Not an object" - -resultToMonad :: Monad m => Result a -> m a -resultToMonad (Ok x) = return x -resultToMonad (Error s) = fail s +parseProfile :: (Monad m, Failure ObjectExtractError m) + => [(String, StringObject)] -> m Identifier +parseProfile m = do + profile <- lookupMapping "profile" m + ident <- lookupScalar "identifier" profile + let profile' = mapMaybe go profile + return $ Identifier ident profile' + where + go ("identifier", _) = Nothing + go (k, Scalar v) = Just (k, v) + go _ = Nothing diff --git a/authenticate.cabal b/authenticate.cabal index 46dc1019..33991ddf 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.0.2 +version: 0.6.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -13,22 +13,15 @@ cabal-version: >= 1.2 build-type: Simple homepage: http://github.com/snoyberg/authenticate/tree/master -flag transformers_02 - description: transformers = 0.2.* - library build-depends: base >= 4 && < 5, - json >= 0.4.3 && < 0.5, + data-object >= 0.3.1 && < 0.4, + data-object-json >= 0.3.1 && < 0.4, http-wget >= 0.6 && < 0.7, tagsoup >= 0.6 && < 0.10, - failure >= 0.0.0 && < 0.1, - safe-failure >= 0.4 && < 0.5, - syb - if flag(transformers_02) - build-depends: transformers >= 0.2 && < 0.3 - CPP-OPTIONS: -DTRANSFORMERS_02 - else - build-depends: transformers >= 0.1 && < 0.2 + failure >= 0.0.0 && < 0.2, + transformers >= 0.1 && < 0.3, + bytestring >= 0.9 && < 0.10 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId ghc-options: -Wall -fno-warn-orphans From b05722e218d902ec6170dd375549e9755d68b9b4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 25 Jun 2010 15:07:12 +0300 Subject: [PATCH 017/182] A working Facebook API and simple sample application --- Web/Authenticate/Facebook.hs | 65 ++++++++++++++++++++++++++++++++++++ Web/Authenticate/OpenId.hs | 4 --- Web/Authenticate/Rpxnow.hs | 4 --- authenticate.cabal | 5 +-- facebook.hs | 56 +++++++++++++++++++++++++++++++ 5 files changed, 124 insertions(+), 10 deletions(-) create mode 100644 Web/Authenticate/Facebook.hs create mode 100644 facebook.hs diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs new file mode 100644 index 00000000..f802078c --- /dev/null +++ b/Web/Authenticate/Facebook.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +module Web.Authenticate.Facebook where + +import Network.HTTP.Wget +import Control.Failure hiding (Error) +import Control.Monad.IO.Class +import Data.List (intercalate) +import Data.Object +import Data.Object.Json +import Data.ByteString.Char8 (pack) + +data Facebook = Facebook + { facebookClientId :: String + , facebookClientSecret :: String + , facebookRedirectUri :: String + } + +newtype AccessToken = AccessToken { unAccessToken :: String } + deriving Show + +getForwardUrl :: Facebook -> [String] -> String +getForwardUrl fb perms = concat + [ "https://graph.facebook.com/oauth/authorize?client_id=" + , facebookClientId fb -- FIXME escape + , "&redirect_uri=" + , facebookRedirectUri fb -- FIXME escape + , if null perms + then "" + else "&scope=" ++ intercalate "," perms + ] + +accessTokenUrl :: Facebook -> String -> String +accessTokenUrl fb code = concat + [ "https://graph.facebook.com/oauth/access_token?client_id=" + , facebookClientId fb + , "&redirect_uri=" + , facebookRedirectUri fb + , "&client_secret=" + , facebookClientSecret fb + , "&code=" + , code + ] + +getAccessToken :: Facebook -> String -> IO AccessToken +getAccessToken fb code = do + let url = accessTokenUrl fb code + b <- wget url [] [] + let (front, back) = splitAt 13 b + case front of + "access_token=" -> return $ AccessToken back + _ -> error $ "Invalid facebook response: " ++ back + +graphUrl :: AccessToken -> String -> String +graphUrl (AccessToken s) func = concat + [ "https://graph.facebook.com/" + , func + , "?access_token=" + , s + ] + +getGraphData :: AccessToken -> String -> IO StringObject +getGraphData at func = do + let url = graphUrl at func + b <- wget url [] [] + decode $ pack b diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index d9f0ff8e..548ff0b9 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -26,11 +26,7 @@ module Web.Authenticate.OpenId import Network.HTTP.Wget import Text.HTML.TagSoup import Numeric (showHex) -#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class -#else -import "transformers" Control.Monad.Trans -#endif import Data.Data import Control.Failure hiding (Error) import Control.Exception diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index d9698998..676960da 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -22,11 +22,7 @@ module Web.Authenticate.Rpxnow import Data.Object import Data.Object.Json import Network.HTTP.Wget -#if MIN_VERSION_transformers(0,2,0) import "transformers" Control.Monad.IO.Class -#else -import "transformers" Control.Monad.Trans -#endif import Control.Failure import Data.Maybe import Web.Authenticate.OpenId (AuthenticateException (..)) diff --git a/authenticate.cabal b/authenticate.cabal index 33991ddf..4057209c 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.2 +version: 0.6.3 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -23,5 +23,6 @@ library transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10 exposed-modules: Web.Authenticate.Rpxnow, - Web.Authenticate.OpenId + Web.Authenticate.OpenId, + Web.Authenticate.Facebook ghc-options: -Wall -fno-warn-orphans diff --git a/facebook.hs b/facebook.hs new file mode 100644 index 00000000..585f90cb --- /dev/null +++ b/facebook.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +import Yesod +import Web.Authenticate.Facebook +import Data.Object +import Data.Maybe (fromMaybe) + +data FB = FB Facebook +fb :: FB +fb = FB $ Facebook "134280699924829" "a7685e10c8977f5435e599aaf1d232eb" + "http://localhost:3000/facebook/" +mkYesod "FB" [$parseRoutes| +/ RootR GET +/facebook FacebookR GET +|] + +instance Yesod FB where approot _ = "http://localhost:3000" + +getRootR = do + FB f <- getYesod + redirectString RedirectTemporary $ getForwardUrl f ["email"] + return () + +getFacebookR = do + FB f <- getYesod + code <- runFormGet $ required $ input "code" + at <- liftIO $ getAccessToken f code + mreq <-runFormGet $ optional $ input "req" + let req = fromMaybe "me" mreq + so <- liftIO $ getGraphData at req + let so' = objToHamlet so + hamletToRepHtml [$hamlet| +%form + %input!type=hidden!name=code!value=$string.code$ + Request: $ + %input!type=text!name=req!value=$string.req$ + \ $ + %input!type=submit +%hr +^so'^ +|] + +main = toWaiApp fb >>= basicHandler 3000 + +objToHamlet :: StringObject -> Hamlet url +objToHamlet (Scalar s) = [$hamlet|$string.s$|] +objToHamlet (Sequence list) = [$hamlet| +%ul + $forall list o + %li ^objToHamlet.o^ +|] +objToHamlet (Mapping pairs) = [$hamlet| +%dl + $forall pairs pair + %dt $string.fst.pair$ + %dd ^objToHamlet.snd.pair^ +|] From 0d343321821a79a89f3dd5ab0f11a8cc6aa79604 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 29 Jun 2010 09:36:33 +0300 Subject: [PATCH 018/182] Some extra deriving of typeclasses --- Web/Authenticate/Facebook.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index f802078c..6c440004 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -2,8 +2,6 @@ module Web.Authenticate.Facebook where import Network.HTTP.Wget -import Control.Failure hiding (Error) -import Control.Monad.IO.Class import Data.List (intercalate) import Data.Object import Data.Object.Json @@ -14,9 +12,10 @@ data Facebook = Facebook , facebookClientSecret :: String , facebookRedirectUri :: String } + deriving (Show, Eq, Read) newtype AccessToken = AccessToken { unAccessToken :: String } - deriving Show + deriving (Show, Eq, Read) getForwardUrl :: Facebook -> [String] -> String getForwardUrl fb perms = concat From 8227bb17a9d8270bf1879d554d8b44a3e1491968 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 28 Sep 2010 11:24:18 +0200 Subject: [PATCH 019/182] tagsoup 0.11 --- authenticate.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/authenticate.cabal b/authenticate.cabal index 4057209c..738f1dad 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.3 +version: 0.6.3.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -18,7 +18,7 @@ library data-object >= 0.3.1 && < 0.4, data-object-json >= 0.3.1 && < 0.4, http-wget >= 0.6 && < 0.7, - tagsoup >= 0.6 && < 0.10, + tagsoup >= 0.6 && < 0.12, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10 From 7ebf584f5272012f80225c5bbd5650ed7cffae8b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 24 Sep 2010 09:00:37 +0200 Subject: [PATCH 020/182] Migrate to http-enumerator --- Web/Authenticate/Facebook.hs | 14 ++++++------ Web/Authenticate/OpenId.hs | 42 +++++++++++++++++++++--------------- Web/Authenticate/Rpxnow.hs | 42 +++++++++++++++++++++++++++--------- authenticate.cabal | 4 ++-- facebook.hs | 7 +++--- 5 files changed, 71 insertions(+), 38 deletions(-) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 6c440004..eb8acb36 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -1,11 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} module Web.Authenticate.Facebook where -import Network.HTTP.Wget +import Network.HTTP.Enumerator import Data.List (intercalate) import Data.Object import Data.Object.Json -import Data.ByteString.Char8 (pack) +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S data Facebook = Facebook { facebookClientId :: String @@ -43,8 +45,8 @@ accessTokenUrl fb code = concat getAccessToken :: Facebook -> String -> IO AccessToken getAccessToken fb code = do let url = accessTokenUrl fb code - b <- wget url [] [] - let (front, back) = splitAt 13 b + b <- simpleHttp url + let (front, back) = splitAt 13 $ L8.unpack b case front of "access_token=" -> return $ AccessToken back _ -> error $ "Invalid facebook response: " ++ back @@ -60,5 +62,5 @@ graphUrl (AccessToken s) func = concat getGraphData :: AccessToken -> String -> IO StringObject getGraphData at func = do let url = graphUrl at func - b <- wget url [] [] - decode $ pack b + b <- simpleHttp url + decode $ S.concat $ L.toChunks b diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 548ff0b9..85110087 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -23,7 +23,7 @@ module Web.Authenticate.OpenId , AuthenticateException (..) ) where -import Network.HTTP.Wget +import Network.HTTP.Enumerator import Text.HTML.TagSoup import Numeric (showHex) import "transformers" Control.Monad.IO.Class @@ -31,6 +31,7 @@ import Data.Data import Control.Failure hiding (Error) import Control.Exception import Control.Monad (liftM) +import qualified Data.ByteString.Lazy.Char8 as L8 -- | An openid identifier (ie, a URL). newtype Identifier = Identifier { identifier :: String } @@ -44,12 +45,16 @@ instance Monad Error where fail s = Error s -- | Returns a URL to forward the user to in order to login. -getForwardUrl :: (MonadIO m, Failure WgetException m) +getForwardUrl :: (MonadIO m, + Failure InvalidUrlException m, + Failure HttpException m + ) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. getForwardUrl openid complete = do - bodyIdent <- wget openid [] [] + bodyIdent' <- simpleHttp openid + let bodyIdent = L8.unpack bodyIdent' server <- getOpenIdVar "server" bodyIdent let delegate = maybe openid id $ getOpenIdVar "delegate" bodyIdent @@ -70,25 +75,28 @@ getOpenIdVar var content = do mhead [] = fail $ "Variable not found: openid." ++ var -- FIXME mhead (x:_) = return x -constructUrl :: String -> [(String, String)] -> String +constructUrl :: String -> [(String, String)] -> String -- FIXME no longer needed, use Request value directly constructUrl url [] = url -constructUrl url args = url ++ "?" ++ queryString args +constructUrl url args = url ++ "?" ++ queryString' args where - queryString [] = error "queryString with empty args cannot happen" - queryString [first] = onePair first - queryString (first:rest) = onePair first ++ "&" ++ queryString rest + queryString' [] = error "queryString with empty args cannot happen" + queryString' [first] = onePair first + queryString' (first:rest) = onePair first ++ "&" ++ queryString' rest onePair (x, y) = urlEncode x ++ "=" ++ urlEncode y -- | Handle a redirect from an OpenID provider and check that the user -- logged in properly. If it was successfully, 'return's the openid. -- Otherwise, 'failure's an explanation. -authenticate :: (MonadIO m, Failure WgetException m, - Failure AuthenticateException m) +authenticate :: (MonadIO m, + Failure AuthenticateException m, + Failure InvalidUrlException m, + Failure HttpException m) => [(String, String)] -> m Identifier authenticate req = do -- FIXME check openid.mode == id_res (not cancel) authUrl <- getAuthUrl req - content <- wget authUrl [] [] + content' <- simpleHttp authUrl + let content = L8.unpack content' let isValid = contains "is_valid:true" content if isValid then Identifier `liftM` alookup "openid.identity" req @@ -99,7 +107,7 @@ alookup :: (Failure AuthenticateException m, Monad m) -> [(String, String)] -> m String alookup k x = case lookup k x of - Just k -> return k + Just k' -> return k' Nothing -> failure $ MissingOpenIdParameter k data AuthenticateException = AuthenticateException String @@ -107,14 +115,14 @@ data AuthenticateException = AuthenticateException String deriving (Show, Typeable) instance Exception AuthenticateException -getAuthUrl :: (MonadIO m, - Failure AuthenticateException m, - Failure WgetException m) +getAuthUrl :: (MonadIO m, Failure AuthenticateException m, + Failure InvalidUrlException m, + Failure HttpException m) => [(String, String)] -> m String getAuthUrl req = do identity <- alookup "openid.identity" req - idContent <- wget identity [] [] - helper idContent + idContent <- simpleHttp identity + helper $ L8.unpack idContent where helper idContent = do server <- getOpenIdVar "server" idContent diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index 676960da..abe4521d 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow @@ -21,13 +22,15 @@ module Web.Authenticate.Rpxnow import Data.Object import Data.Object.Json -import Network.HTTP.Wget +import Network.HTTP.Enumerator import "transformers" Control.Monad.IO.Class import Control.Failure import Data.Maybe import Web.Authenticate.OpenId (AuthenticateException (..)) import Control.Monad -import Data.ByteString.Char8 (pack) +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import Control.Exception (throwIO) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -37,7 +40,8 @@ data Identifier = Identifier -- | Attempt to log a user in. authenticate :: (MonadIO m, - Failure WgetException m, + Failure HttpException m, + Failure InvalidUrlException m, Failure AuthenticateException m, Failure ObjectExtractError m, Failure JsonDecodeError m) @@ -45,16 +49,34 @@ authenticate :: (MonadIO m, -> String -- ^ Token passed by client. -> m Identifier authenticate apiKey token = do - b <- wget "https://rpxnow.com/api/v2/auth_info" - [] - [ ("apiKey", apiKey) - , ("token", token) - ] - o <- decode $ pack b + let body = L.fromChunks + [ "apiKey=" + , S.pack apiKey + , "&token=" + , S.pack token + ] + let req = + Request + { method = "POST" + , secure = True + , host = "rpxnow.com" + , port = 443 + , path = "api/v2/auth_info" + , queryString = [] + , requestHeaders = + [ ("Content-Type", "application/x-www-form-urlencoded") + ] + , requestBody = body + } + res <- httpLbsRedirect req + let b = responseBody res + unless (200 <= statusCode res && statusCode res < 300) $ + liftIO $ throwIO $ HttpException (statusCode res) b + o <- decode $ S.concat $ L.toChunks b m <- fromMapping o stat <- lookupScalar "stat" m unless (stat == "ok") $ failure $ AuthenticateException $ - "Rpxnow login not accepted: " ++ stat ++ "\n" ++ b + "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b parseProfile m parseProfile :: (Monad m, Failure ObjectExtractError m) diff --git a/authenticate.cabal b/authenticate.cabal index 738f1dad..ca8dcf9d 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.3.2 +version: 0.6.4 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,7 +17,7 @@ library build-depends: base >= 4 && < 5, data-object >= 0.3.1 && < 0.4, data-object-json >= 0.3.1 && < 0.4, - http-wget >= 0.6 && < 0.7, + http-enumerator >= 0.1.1 && < 0.2, tagsoup >= 0.6 && < 0.12, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, diff --git a/facebook.hs b/facebook.hs index 585f90cb..b88459ca 100644 --- a/facebook.hs +++ b/facebook.hs @@ -3,6 +3,7 @@ import Yesod import Web.Authenticate.Facebook import Data.Object import Data.Maybe (fromMaybe) +import Network.HTTP.Enumerator data FB = FB Facebook fb :: FB @@ -22,9 +23,9 @@ getRootR = do getFacebookR = do FB f <- getYesod - code <- runFormGet $ required $ input "code" + code <- runFormGet' $ stringInput "code" at <- liftIO $ getAccessToken f code - mreq <-runFormGet $ optional $ input "req" + mreq <- runFormGet' $ maybeStringInput "req" let req = fromMaybe "me" mreq so <- liftIO $ getGraphData at req let so' = objToHamlet so @@ -39,7 +40,7 @@ getFacebookR = do ^so'^ |] -main = toWaiApp fb >>= basicHandler 3000 +main = withHttpEnumerator $ basicHandler 3000 fb objToHamlet :: StringObject -> Hamlet url objToHamlet (Scalar s) = [$hamlet|$string.s$|] From bdb6f2011fea3f68bec080120228ef803a0c7270 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 3 Oct 2010 09:59:41 +0200 Subject: [PATCH 021/182] MissingVar for OpenID --- Web/Authenticate/OpenId.hs | 17 ++++++++++++----- authenticate.cabal | 2 +- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 85110087..0cebb4da 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -47,7 +47,8 @@ instance Monad Error where -- | Returns a URL to forward the user to in order to login. getForwardUrl :: (MonadIO m, Failure InvalidUrlException m, - Failure HttpException m + Failure HttpException m, + Failure MissingVar m ) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. @@ -64,7 +65,11 @@ getForwardUrl openid complete = do , ("openid.return_to", complete) ] -getOpenIdVar :: Monad m => String -> String -> m String +data MissingVar = MissingVar String + deriving (Typeable, Show) +instance Exception MissingVar + +getOpenIdVar :: Failure MissingVar m => String -> String -> m String getOpenIdVar var content = do let tags = parseTags content let secs = sections (~== ("")) tags @@ -72,7 +77,7 @@ getOpenIdVar var content = do secs'' <- mhead secs' return $ fromAttrib "href" secs'' where - mhead [] = fail $ "Variable not found: openid." ++ var -- FIXME + mhead [] = failure $ MissingVar $ "openid." ++ var mhead (x:_) = return x constructUrl :: String -> [(String, String)] -> String -- FIXME no longer needed, use Request value directly @@ -90,7 +95,8 @@ constructUrl url args = url ++ "?" ++ queryString' args authenticate :: (MonadIO m, Failure AuthenticateException m, Failure InvalidUrlException m, - Failure HttpException m) + Failure HttpException m, + Failure MissingVar m) => [(String, String)] -> m Identifier authenticate req = do -- FIXME check openid.mode == id_res (not cancel) @@ -117,7 +123,8 @@ instance Exception AuthenticateException getAuthUrl :: (MonadIO m, Failure AuthenticateException m, Failure InvalidUrlException m, - Failure HttpException m) + Failure HttpException m, + Failure MissingVar m) => [(String, String)] -> m String getAuthUrl req = do identity <- alookup "openid.identity" req diff --git a/authenticate.cabal b/authenticate.cabal index ca8dcf9d..0fa909f0 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.4 +version: 0.6.5 license: BSD3 license-file: LICENSE author: Michael Snoyman From d742893f04140227b40e3f7ddd4f657393364559 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 4 Oct 2010 07:05:53 +0200 Subject: [PATCH 022/182] Percent encoding for Facebook --- Web/Authenticate/Facebook.hs | 32 +++++++++++++++++++++++++------- authenticate.cabal | 5 +++-- 2 files changed, 28 insertions(+), 9 deletions(-) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index eb8acb36..38d62d81 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -8,6 +8,8 @@ import Data.Object.Json import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S +import qualified Codec.Binary.UTF8.String +import Numeric (showHex) data Facebook = Facebook { facebookClientId :: String @@ -19,27 +21,43 @@ data Facebook = Facebook newtype AccessToken = AccessToken { unAccessToken :: String } deriving (Show, Eq, Read) +qsEncode :: String -> String +qsEncode = + concatMap go . Codec.Binary.UTF8.String.encode + where + go 32 = "+" -- space + go 46 = "." + go 45 = "-" + go 126 = "~" + go 95 = "_" + go c + | 48 <= c && c <= 57 = [w2c c] + | 65 <= c && c <= 90 = [w2c c] + | 97 <= c && c <= 122 = [w2c c] + go c = '%' : showHex c "" + w2c = toEnum . fromEnum + getForwardUrl :: Facebook -> [String] -> String getForwardUrl fb perms = concat [ "https://graph.facebook.com/oauth/authorize?client_id=" - , facebookClientId fb -- FIXME escape + , qsEncode $ facebookClientId fb , "&redirect_uri=" - , facebookRedirectUri fb -- FIXME escape + , qsEncode $ facebookRedirectUri fb , if null perms then "" - else "&scope=" ++ intercalate "," perms + else "&scope=" ++ qsEncode (intercalate "," perms) ] accessTokenUrl :: Facebook -> String -> String accessTokenUrl fb code = concat [ "https://graph.facebook.com/oauth/access_token?client_id=" - , facebookClientId fb + , qsEncode $ facebookClientId fb , "&redirect_uri=" - , facebookRedirectUri fb + , qsEncode $ facebookRedirectUri fb , "&client_secret=" - , facebookClientSecret fb + , qsEncode $ facebookClientSecret fb , "&code=" - , code + , qsEncode code ] getAccessToken :: Facebook -> String -> IO AccessToken diff --git a/authenticate.cabal b/authenticate.cabal index 0fa909f0..78e12749 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -21,8 +21,9 @@ library tagsoup >= 0.6 && < 0.12, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, - bytestring >= 0.9 && < 0.10 + bytestring >= 0.9 && < 0.10, + utf8-string >= 0.3 && < 0.4 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.Facebook - ghc-options: -Wall -fno-warn-orphans + ghc-options: -Wall From d6f0d2ee092ab9ab46249d1500c61afaca4bf781 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 4 Oct 2010 07:12:59 +0200 Subject: [PATCH 023/182] OpenID uses same qsEncode as Facebook --- Web/Authenticate/Facebook.hs | 19 +------------------ Web/Authenticate/Internal.hs | 22 ++++++++++++++++++++++ Web/Authenticate/OpenId.hs | 30 +++++++----------------------- authenticate.cabal | 1 + 4 files changed, 31 insertions(+), 41 deletions(-) create mode 100644 Web/Authenticate/Internal.hs diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 38d62d81..b0b24a36 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -8,8 +8,7 @@ import Data.Object.Json import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S -import qualified Codec.Binary.UTF8.String -import Numeric (showHex) +import Web.Authenticate.Internal (qsEncode) data Facebook = Facebook { facebookClientId :: String @@ -21,22 +20,6 @@ data Facebook = Facebook newtype AccessToken = AccessToken { unAccessToken :: String } deriving (Show, Eq, Read) -qsEncode :: String -> String -qsEncode = - concatMap go . Codec.Binary.UTF8.String.encode - where - go 32 = "+" -- space - go 46 = "." - go 45 = "-" - go 126 = "~" - go 95 = "_" - go c - | 48 <= c && c <= 57 = [w2c c] - | 65 <= c && c <= 90 = [w2c c] - | 97 <= c && c <= 122 = [w2c c] - go c = '%' : showHex c "" - w2c = toEnum . fromEnum - getForwardUrl :: Facebook -> [String] -> String getForwardUrl fb perms = concat [ "https://graph.facebook.com/oauth/authorize?client_id=" diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs new file mode 100644 index 00000000..191c6bd7 --- /dev/null +++ b/Web/Authenticate/Internal.hs @@ -0,0 +1,22 @@ +module Web.Authenticate.Internal + ( qsEncode + ) where + +import Codec.Binary.UTF8.String (encode) +import Numeric (showHex) + +qsEncode :: String -> String +qsEncode = + concatMap go . encode + where + go 32 = "+" -- space + go 46 = "." + go 45 = "-" + go 126 = "~" + go 95 = "_" + go c + | 48 <= c && c <= 57 = [w2c c] + | 65 <= c && c <= 90 = [w2c c] + | 97 <= c && c <= 122 = [w2c c] + go c = '%' : showHex c "" + w2c = toEnum . fromEnum diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 0cebb4da..c26c70e9 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -25,13 +25,14 @@ module Web.Authenticate.OpenId import Network.HTTP.Enumerator import Text.HTML.TagSoup -import Numeric (showHex) import "transformers" Control.Monad.IO.Class import Data.Data import Control.Failure hiding (Error) import Control.Exception import Control.Monad (liftM) import qualified Data.ByteString.Lazy.Char8 as L8 +import Web.Authenticate.Internal (qsEncode) +import Data.List (intercalate) -- | An openid identifier (ie, a URL). newtype Identifier = Identifier { identifier :: String } @@ -80,14 +81,12 @@ getOpenIdVar var content = do mhead [] = failure $ MissingVar $ "openid." ++ var mhead (x:_) = return x -constructUrl :: String -> [(String, String)] -> String -- FIXME no longer needed, use Request value directly +constructUrl :: String -> [(String, String)] -> String constructUrl url [] = url -constructUrl url args = url ++ "?" ++ queryString' args - where - queryString' [] = error "queryString with empty args cannot happen" - queryString' [first] = onePair first - queryString' (first:rest) = onePair first ++ "&" ++ queryString' rest - onePair (x, y) = urlEncode x ++ "=" ++ urlEncode y +constructUrl url args = + url ++ "?" ++ intercalate "&" (map qsPair args) + where + qsPair (x, y) = qsEncode x ++ '=' : qsEncode y -- | Handle a redirect from an OpenID provider and check that the user -- logged in properly. If it was successfully, 'return's the openid. @@ -158,18 +157,3 @@ begins :: String -> String -> Bool begins [] _ = True begins _ [] = False begins (x:xs) (y:ys) = x == y && begins xs ys - -urlEncode :: String -> String -urlEncode = concatMap urlEncodeChar - -urlEncodeChar :: Char -> String -urlEncodeChar x - | safeChar (fromEnum x) = return x - | otherwise = '%' : showHex (fromEnum x) "" - -safeChar :: Int -> Bool -safeChar x - | x >= fromEnum 'a' && x <= fromEnum 'z' = True - | x >= fromEnum 'A' && x <= fromEnum 'Z' = True - | x >= fromEnum '0' && x <= fromEnum '9' = True - | otherwise = False diff --git a/authenticate.cabal b/authenticate.cabal index 78e12749..75aecaab 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -26,4 +26,5 @@ library exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.Facebook + other-modules: Web.Authenticate.Internal ghc-options: -Wall From 2a65b1f01698dd685cef5528f2b0cf25f305a9e3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 4 Oct 2010 07:21:10 +0200 Subject: [PATCH 024/182] Checking openid.mode=id_res --- Web/Authenticate/OpenId.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index c26c70e9..3230ec2c 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -29,7 +29,7 @@ import "transformers" Control.Monad.IO.Class import Data.Data import Control.Failure hiding (Error) import Control.Exception -import Control.Monad (liftM) +import Control.Monad (liftM, unless) import qualified Data.ByteString.Lazy.Char8 as L8 import Web.Authenticate.Internal (qsEncode) import Data.List (intercalate) @@ -98,12 +98,12 @@ authenticate :: (MonadIO m, Failure MissingVar m) => [(String, String)] -> m Identifier -authenticate req = do -- FIXME check openid.mode == id_res (not cancel) +authenticate req = do + unless (lookup "openid.mode" req == Just "id_res") $ + failure $ AuthenticateException "authenticate without openid.mode=id_res" authUrl <- getAuthUrl req - content' <- simpleHttp authUrl - let content = L8.unpack content' - let isValid = contains "is_valid:true" content - if isValid + content <- L8.unpack `liftM` simpleHttp authUrl + if contains "is_valid:true" content then Identifier `liftM` alookup "openid.identity" req else failure $ AuthenticateException content From 17b5406fceb865a193236234b393cabd91239c0d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 08:37:04 +0200 Subject: [PATCH 025/182] OpenID v2 support. All of the heavy lifting was taken directly from the openid package, and lives in the OpenId2.* module hierarchy. The difference here is that we don't use associations at all, removing the need for some hefty dependencies. I've also gutted MonadLib dependencies. --- .gitignore | 1 + OpenId2/Discovery.hs | 154 +++++++++++++++++++++++++++++++++++ OpenId2/HTTP.hs | 94 +++++++++++++++++++++ OpenId2/Normalization.hs | 62 ++++++++++++++ OpenId2/Types.hs | 125 ++++++++++++++++++++++++++++ OpenId2/XRDS.hs | 116 ++++++++++++++++++++++++++ Web/Authenticate/Internal.hs | 9 ++ Web/Authenticate/OpenId.hs | 13 +-- Web/Authenticate/OpenId2.hs | 63 ++++++++++++++ authenticate.cabal | 14 +++- openid2.hs | 36 ++++++++ 11 files changed, 674 insertions(+), 13 deletions(-) create mode 100644 OpenId2/Discovery.hs create mode 100644 OpenId2/HTTP.hs create mode 100644 OpenId2/Normalization.hs create mode 100644 OpenId2/Types.hs create mode 100644 OpenId2/XRDS.hs create mode 100644 Web/Authenticate/OpenId2.hs create mode 100644 openid2.hs diff --git a/.gitignore b/.gitignore index 019dac95..c479d6bc 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ *.swp dist +client_session_key.aes diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs new file mode 100644 index 00000000..2afcc1c5 --- /dev/null +++ b/OpenId2/Discovery.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE FlexibleContexts #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Discovery +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Discovery ( + -- * Discovery + discover + ) where + +-- Friends +import OpenId2.Types +import OpenId2.XRDS + +-- Libraries +import Data.Char +import Data.List +import Data.Maybe +import Network.HTTP.Enumerator +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import qualified Data.ByteString.Char8 as S8 +import Control.Arrow (first) +import Control.Applicative ((<$>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Failure (Failure (failure)) + +-- | Attempt to resolve an OpenID endpoint, and user identifier. +discover :: (MonadIO m, Failure OpenIdException m) + => Resolver IO + -> Identifier + -> m (Provider, Identifier) +discover resolve ident@(Identifier i) = do + res1 <- liftIO $ discoverYADIS resolve ident Nothing + case res1 of + Just x -> return x + Nothing -> do + res2 <- liftIO $ discoverHTML resolve ident + case res2 of + Just x -> return x + Nothing -> failure $ DiscoveryException 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 :: Resolver IO + -> Identifier + -> Maybe String + -> IO (Maybe (Provider,Identifier)) +discoverYADIS resolve ident mb_loc = do + let uri = fromMaybe (getIdentifier ident) mb_loc + req <- parseUrl uri + res <- httpLbs req + let mloc = lookup "x-xrds-location" + $ map (first $ map toLower . S8.unpack) + $ responseHeaders res + case statusCode res of + 200 -> + case mloc of + Just loc -> discoverYADIS resolve ident (Just $ S8.unpack loc) + Nothing -> do + let mdoc = parseXRDS $ BSLU.toString $ responseBody res + case mdoc of + Just doc -> return $ parseYADIS ident doc + Nothing -> return Nothing + _ -> return Nothing + + +-- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml +-- document. +parseYADIS :: Identifier -> XRDS -> Maybe (Provider,Identifier) +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 <- listToMaybe $ mapMaybe f + [ ("http://specs.openid.net/auth/2.0/server", ident) + -- claimed identifiers + , ("http://specs.openid.net/auth/2.0/signon", localId) + , ("http://openid.net/signon/1.0" , localId) + , ("http://openid.net/signon/1.1" , localId) + ] + uri <- parseProvider =<< listToMaybe (serviceURIs svc) + return (uri,lid) + + +-- 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 :: Resolver IO -> Identifier -> IO (Maybe (Provider,Identifier)) +discoverHTML resolve ident'@(Identifier ident) = + parseHTML ident' . BSLU.toString <$> simpleHttp ident + +-- | Parse out an OpenID endpoint and an actual identifier from an HTML +-- document. +parseHTML :: Identifier -> String -> Maybe (Provider,Identifier) +parseHTML ident = resolve + . filter isOpenId + . linkTags + . htmlTags + where + isOpenId (rel,_) = "openid" `isPrefixOf` rel + resolve ls = do + prov <- parseProvider =<< lookup "openid2.provider" ls + let lid = maybe ident Identifier $ lookup "openid2.local_id" ls + return (prov,lid) + + +-- | Filter out link tags from a list of html tags. +linkTags :: [String] -> [(String,String)] +linkTags = mapMaybe f . filter p + where + p = ("link " `isPrefixOf`) + f xs = do + let ys = unfoldr splitAttr (drop 5 xs) + x <- lookup "rel" ys + y <- lookup "href" ys + return (x,y) + + +-- | Split a string into strings of html tags. +htmlTags :: String -> [String] +htmlTags [] = [] +htmlTags xs = case break (== '<') xs of + (as,_:bs) -> fmt as : htmlTags bs + (as,[]) -> [as] + where + fmt as = case break (== '>') as of + (bs,_) -> bs + + +-- | Split out values from a key="value" like string, in a way that +-- is suitable for use with unfoldr. +splitAttr :: String -> Maybe ((String,String),String) +splitAttr xs = case break (== '=') xs of + (_,[]) -> Nothing + (key,_:'"':ys) -> f key (== '"') ys + (key,_:ys) -> f key isSpace ys + where + f key p cs = case break p cs of + (_,[]) -> Nothing + (value,_:rest) -> Just ((key,value), dropWhile isSpace rest) diff --git a/OpenId2/HTTP.hs b/OpenId2/HTTP.hs new file mode 100644 index 00000000..5ca523d5 --- /dev/null +++ b/OpenId2/HTTP.hs @@ -0,0 +1,94 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.HTTP +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.HTTP ( + -- * Request Interface + makeRequest + + -- * Request/Response Parsing and Formatting + , parseDirectResponse + , formatParams + , formatDirectParams + , escapeParam + , addParams + , parseParams + ) where + +-- friends +import OpenId2.Types +--import Network.OpenID.Utils + +-- libraries +import Data.List +import Network.BSD +import Network.Socket +import Network.URI hiding (query) +import Network.HTTP.Enumerator + + +-- | Perform an http request. +-- If the Bool parameter is set to True, redirects from the server will be +-- followed. +makeRequest :: Bool -> Resolver IO +makeRequest follow = if follow then httpLbsRedirect else httpLbs + +-- Parsing and Formatting ------------------------------------------------------ + +-- | Turn a response body into a list of parameters. +parseDirectResponse :: String -> Params +parseDirectResponse = unfoldr step + where + step [] = Nothing + step str = case split (== '\n') str of + (ps,rest) -> Just (split (== ':') ps,rest) + + +-- | Format OpenID parameters as a query string +formatParams :: Params -> String +formatParams = intercalate "&" . map f + where f (x,y) = x ++ "=" ++ escapeParam y + + +-- | Format OpenID parameters as a direct response +formatDirectParams :: Params -> String +formatDirectParams = concatMap f + where f (x,y) = x ++ ":" ++ y ++ "\n" + + +-- | Escape for the query string of a URI +escapeParam :: String -> String +escapeParam = escapeURIString isUnreserved + + +-- | Add Parameters to a URI +addParams :: Params -> URI -> URI +addParams ps uri = uri { uriQuery = query } + where + f (k,v) = (k,v) + ps' = map f ps + query = '?' : formatParams (parseParams (uriQuery uri) ++ ps') + + +-- | Parse OpenID parameters out of a url string +parseParams :: String -> Params +parseParams xs = case split (== '?') xs of + (_,bs) -> unfoldr step bs + where + step [] = Nothing + step bs = case split (== '&') bs of + (as,rest) -> case split (== '=') as of + (k,v) -> Just ((k, unEscapeString v),rest) + +split :: (a -> Bool) -> [a] -> ([a],[a]) +split p as = case break p as of + (xs,_:ys) -> (xs,ys) + pair -> pair diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs new file mode 100644 index 00000000..0dc4eb4b --- /dev/null +++ b/OpenId2/Normalization.hs @@ -0,0 +1,62 @@ +{-# 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 hiding (scheme,path) +import Control.Failure (Failure (..)) + +normalize :: Failure OpenIdException m => String -> m Identifier +normalize ident = + case normalizeIdentifier $ Identifier ident of + Just i -> return i + Nothing -> failure $ NormalizationException 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 `fmap` xri str + | head str `elem` "=@+$!" = Identifier `fmap` xri str + | otherwise = fmt `fmap` (url >>= norm) + where + 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 + $ normalizePathSegments + $ normalizeEscape + $ normalizeCase + $ uriToString (const "") u [] diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs new file mode 100644 index 00000000..ad2bf473 --- /dev/null +++ b/OpenId2/Types.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Types +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Types ( + AssocType(..) + , SessionType(..) + , Association(..) + , Params + , ReturnTo + , Realm + , Resolver + , Provider (..) + , parseProvider + , showProvider + , modifyProvider + , Identifier(..) + , Error(..) + , assocString + , OpenIdException (..) + ) where + +-- Libraries +import Data.List +import Data.Word +import Network.URI +import Network.HTTP.Enumerator (Request, Response) +import Control.Exception (Exception) +import Data.Typeable (Typeable) + +data OpenIdException = + NormalizationException String + | DiscoveryException String + | AuthenticationException String + deriving (Show, Typeable) +instance Exception OpenIdException + +-------------------------------------------------------------------------------- +-- Types + +-- | Supported association types +data AssocType = HmacSha1 | HmacSha256 + deriving (Read,Show) + +assocString :: AssocType -> String +assocString HmacSha1 = "HMAC-SHA1" +assocString HmacSha256 = "HMAC-SHA256" + +{- +instance Show AssocType where + show HmacSha1 = "HMAC-SHA1" + show HmacSha256 = "HMAC-SHA256" + +instance Read AssocType where + readsPrec _ str | "HMAC-SHA1" `isPrefixOf` str = [(HmacSha1 ,drop 9 str)] + | "HMAC-SHA256" `isPrefixOf` str = [(HmacSha256, drop 11 str)] + | otherwise = [] +-} + +-- | Session types for association establishment +data SessionType = NoEncryption | DhSha1 | DhSha256 + +instance Show SessionType where + show NoEncryption = "no-encryption" + show DhSha1 = "DH-SHA1" + show DhSha256 = "DH-SHA256" + +instance Read SessionType where + readsPrec _ str + | "no-encryption" `isPrefixOf` str = [(NoEncryption, drop 13 str)] + | "DH-SHA1" `isPrefixOf` str = [(DhSha1, drop 7 str)] + | "DH-SHA256" `isPrefixOf` str = [(DhSha256, drop 9 str)] + | otherwise = [] + + +-- | An association with a provider. +data Association = Association + { assocExpiresIn :: Int + , assocHandle :: String + , assocMacKey :: [Word8] + , assocType :: AssocType + } deriving (Show,Read) + + +-- | Parameter lists for communication with the server +type Params = [(String,String)] + +-- | A return to path +type ReturnTo = String + +-- | A realm of uris for a provider to inform a user about +type Realm = String + +-- | A way to resolve an HTTP request +type Resolver m = Request -> m Response + +-- | An OpenID provider. +newtype Provider = Provider { providerURI :: URI } deriving (Eq,Show) + +-- | Parse a provider +parseProvider :: String -> Maybe Provider +parseProvider = fmap Provider . parseURI + +-- | Show a provider +showProvider :: Provider -> String +showProvider (Provider uri) = uriToString (const "") uri [] + +-- | Modify the URI in a provider +modifyProvider :: (URI -> URI) -> Provider -> Provider +modifyProvider f (Provider uri) = Provider (f uri) + +-- | A valid OpenID identifier. +newtype Identifier = Identifier { getIdentifier :: String } + deriving (Eq,Show,Read) + +-- | Errors +newtype Error = Error String deriving Show diff --git a/OpenId2/XRDS.hs b/OpenId2/XRDS.hs new file mode 100644 index 00000000..7594f94a --- /dev/null +++ b/OpenId2/XRDS.hs @@ -0,0 +1,116 @@ + +-------------------------------------------------------------------------------- +-- | +-- Module : Text.XRDS +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.XRDS ( + -- * Types + XRDS, XRD + , Service(..) + + -- * Utility Functions + , isUsable + , hasType + + -- * Parsing + , parseXRDS + ) where + +-- Libraries +import Control.Arrow +import Control.Monad +import Data.List +import Data.Maybe +import Text.XML.Light + + +-- Types ----------------------------------------------------------------------- + +type XRDS = [XRD] + +type XRD = [Service] + +data Service = Service + { serviceTypes :: [String] + , serviceMediaTypes :: [String] + , serviceURIs :: [String] + , serviceLocalIDs :: [String] + , servicePriority :: Maybe Int + , serviceExtra :: [Element] + } deriving Show + +-- Utilities ------------------------------------------------------------------- + +-- | Check to see if an XRDS service description is usable. +isUsable :: XRDS -> Bool +isUsable = not . null . concat + + +-- | Generate a tag name predicate, that ignores prefix and namespace. +tag :: String -> Element -> Bool +tag n el = qName (elName el) == n + + +-- | Filter the attributes of an element by some predicate +findAttr' :: (QName -> Bool) -> Element -> Maybe String +findAttr' p el = attrVal `fmap` find (p . attrKey) (elAttribs el) + + +-- | Read, maybe +readMaybe :: Read a => String -> Maybe a +readMaybe str = case reads str of + [(x,"")] -> Just x + _ -> Nothing + + +-- | Get the text of an element +getText :: Element -> String +getText el = case elContent el of + [Text cd] -> cdData cd + _ -> [] + + +-- | Generate a predicate over Service Types. +hasType :: String -> Service -> Bool +hasType ty svc = ty `elem` serviceTypes svc + + +-- Parsing --------------------------------------------------------------------- + + +parseXRDS :: String -> Maybe XRDS +parseXRDS str = do + doc <- parseXMLDoc str + let xrds = filterChildren (tag "XRD") doc + return $ map parseXRD xrds + + +parseXRD :: Element -> XRD +parseXRD el = + let svcs = filterChildren (tag "Service") el + in mapMaybe parseService svcs + + +parseService :: Element -> Maybe Service +parseService el = do + let vals t x = first (map getText) $ partition (tag t) x + (tys,tr) = vals "Type" (elChildren el) + (mts,mr) = vals "MediaType" tr + (uris,ur) = vals "URI" mr + (lids,rest) = vals "LocalID" ur + priority = readMaybe =<< findAttr' (("priority" ==) . qName) el + guard $ not $ null tys + return $ Service { serviceTypes = tys + , serviceMediaTypes = mts + , serviceURIs = uris + , serviceLocalIDs = lids + , servicePriority = priority + , serviceExtra = rest + } diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs index 191c6bd7..93e8594a 100644 --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -1,9 +1,18 @@ module Web.Authenticate.Internal ( qsEncode + , qsUrl ) where import Codec.Binary.UTF8.String (encode) import Numeric (showHex) +import Data.List (intercalate) + +qsUrl :: String -> [(String, String)] -> String +qsUrl s [] = s +qsUrl url pairs = + url ++ "?" ++ intercalate "&" (map qsPair pairs) + where + qsPair (x, y) = qsEncode x ++ '=' : qsEncode y qsEncode :: String -> String qsEncode = diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 3230ec2c..589498bd 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -31,7 +31,7 @@ import Control.Failure hiding (Error) import Control.Exception import Control.Monad (liftM, unless) import qualified Data.ByteString.Lazy.Char8 as L8 -import Web.Authenticate.Internal (qsEncode) +import Web.Authenticate.Internal (qsUrl) import Data.List (intercalate) -- | An openid identifier (ie, a URL). @@ -60,7 +60,7 @@ getForwardUrl openid complete = do server <- getOpenIdVar "server" bodyIdent let delegate = maybe openid id $ getOpenIdVar "delegate" bodyIdent - return $ constructUrl server + return $ qsUrl server [ ("openid.mode", "checkid_setup") , ("openid.identity", delegate) , ("openid.return_to", complete) @@ -81,13 +81,6 @@ getOpenIdVar var content = do mhead [] = failure $ MissingVar $ "openid." ++ var mhead (x:_) = return x -constructUrl :: String -> [(String, String)] -> String -constructUrl url [] = url -constructUrl url args = - url ++ "?" ++ intercalate "&" (map qsPair args) - where - qsPair (x, y) = qsEncode x ++ '=' : qsEncode y - -- | Handle a redirect from an OpenID provider and check that the user -- logged in properly. If it was successfully, 'return's the openid. -- Otherwise, 'failure's an explanation. @@ -140,7 +133,7 @@ getAuthUrl req = do "return_to" ] let sargs = [("openid.mode", "check_authentication")] - return $ constructUrl server $ dargs ++ sargs + return $ qsUrl server $ dargs ++ sargs makeArg s = do let k = "openid." ++ s v <- alookup k req diff --git a/Web/Authenticate/OpenId2.hs b/Web/Authenticate/OpenId2.hs new file mode 100644 index 00000000..b39d8b7c --- /dev/null +++ b/Web/Authenticate/OpenId2.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} +module Web.Authenticate.OpenId2 + ( getForwardUrl + , authenticate + , OpenIdException (..) + ) where + +import Control.Monad.IO.Class +import OpenId2.Normalization (normalize) +import OpenId2.Discovery (discover) +import OpenId2.HTTP (makeRequest, parseDirectResponse) +import Control.Failure (Failure (failure)) +import OpenId2.Types (OpenIdException (..), Identifier (Identifier), + Provider (Provider)) +import Web.Authenticate.Internal (qsUrl) +import Control.Monad (unless) +import qualified Data.ByteString.UTF8 as BSU +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import Network.HTTP.Enumerator (parseUrl, urlEncodedBody, responseBody) +import Control.Arrow ((***)) + +getForwardUrl :: (MonadIO m, Failure OpenIdException m) + => String -- ^ The openid the user provided. + -> String -- ^ The URL for this application\'s complete page. + -> m String -- ^ URL to send the user to. +getForwardUrl openid' complete = do + let resolve = makeRequest True + (Provider p, Identifier i) <- normalize openid' >>= discover resolve + return $ qsUrl (show p) + [ ("openid.ns", "http://specs.openid.net/auth/2.0") + , ("openid.mode", "checkid_setup") + , ("openid.claimed_id", i) + , ("openid.identity", i) + , ("openid.return_to", complete) + ] + +authenticate :: (MonadIO m, Failure OpenIdException m) + => [(String, String)] + -> m String +authenticate params = do + unless (lookup "openid.mode" params == Just "id_res") + $ failure $ AuthenticationException "mode is not id_res" + ident <- case lookup "openid.identity" params of + Just i -> return i + Nothing -> + failure $ AuthenticationException "Missing identity" + endpoint <- + case lookup "openid.op_endpoint" params of + Just e -> return e + Nothing -> + failure $ AuthenticationException "Missing op_endpoint" + let params' = map (BSU.fromString *** BSU.fromString) + $ ("openid.mode", "check_authentication") + : filter (\(k, _) -> k /= "openid.mode") params + req' <- liftIO $ parseUrl endpoint + let req = urlEncodedBody params' req' + rsp <- liftIO $ makeRequest True req + let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp + case lookup "is_valid" rps of + Just "true" -> return ident + Nothing -> + failure $ AuthenticationException "OpenID provider did not validate" + -- FIXME check if endpoint is valid for given identity diff --git a/authenticate.cabal b/authenticate.cabal index 75aecaab..0b7e3f15 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.5 +version: 0.6.6 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -22,9 +22,17 @@ library failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10, - utf8-string >= 0.3 && < 0.4 + utf8-string >= 0.3 && < 0.4, + network >= 2.2.1 && < 2.3, + xml >= 1.3.7 && < 1.4 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, + Web.Authenticate.OpenId2, Web.Authenticate.Facebook - other-modules: Web.Authenticate.Internal + other-modules: Web.Authenticate.Internal, + OpenId2.Discovery, + OpenId2.HTTP, + OpenId2.Normalization, + OpenId2.Types, + OpenId2.XRDS ghc-options: -Wall diff --git a/openid2.hs b/openid2.hs new file mode 100644 index 00000000..4f160b80 --- /dev/null +++ b/openid2.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +import Yesod +import Web.Authenticate.OpenId2 +import Data.Object +import Data.Maybe (fromMaybe) +import Network.HTTP.Enumerator + +data OID = OID +mkYesod "OID" [$parseRoutes| +/ RootR GET +/forward ForwardR GET +/complete CompleteR GET +|] + +instance Yesod OID where approot _ = "http://localhost:3000" + +getRootR = defaultLayout [$hamlet| +%form!action=@ForwardR@ + OpenId: + %input!type=text!name=openid_identifier!value="http://" + %input!type=submit +|] + +getForwardR = do + openid <- runFormGet' $ stringInput "openid_identifier" + render <- getUrlRender + url <- liftIO $ getForwardUrl openid $ render CompleteR + redirectString RedirectTemporary url + return () + +getCompleteR = do + params <- reqGetParams `fmap` getRequest + ident <- liftIO $ authenticate params + return $ RepPlain $ toContent ident + +main = withHttpEnumerator $ basicHandler 3000 OID From 0da51855ec4e5c26a95f2605cf1849cfd9bc5fa4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 09:05:36 +0200 Subject: [PATCH 026/182] Slimmed down code --- OpenId2/Discovery.hs | 28 +++++------ OpenId2/HTTP.hs | 94 ------------------------------------ OpenId2/Normalization.hs | 12 ++--- OpenId2/Types.hs | 96 ++----------------------------------- OpenId2/XRDS.hs | 17 +------ Web/Authenticate/OpenId2.hs | 32 +++++++++---- authenticate.cabal | 1 - 7 files changed, 46 insertions(+), 234 deletions(-) delete mode 100644 OpenId2/HTTP.hs diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 2afcc1c5..f4898bb0 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -34,15 +34,14 @@ import Control.Failure (Failure (failure)) -- | Attempt to resolve an OpenID endpoint, and user identifier. discover :: (MonadIO m, Failure OpenIdException m) - => Resolver IO - -> Identifier + => Identifier -> m (Provider, Identifier) -discover resolve ident@(Identifier i) = do - res1 <- liftIO $ discoverYADIS resolve ident Nothing +discover ident@(Identifier i) = do + res1 <- liftIO $ discoverYADIS ident Nothing case res1 of Just x -> return x Nothing -> do - res2 <- liftIO $ discoverHTML resolve ident + res2 <- liftIO $ discoverHTML ident case res2 of Just x -> return x Nothing -> failure $ DiscoveryException i @@ -51,11 +50,10 @@ discover resolve ident@(Identifier i) = do -- | Attempt a YADIS based discovery, given a valid identifier. The result is -- an OpenID endpoint, and the actual identifier for the user. -discoverYADIS :: Resolver IO - -> Identifier +discoverYADIS :: Identifier -> Maybe String -> IO (Maybe (Provider,Identifier)) -discoverYADIS resolve ident mb_loc = do +discoverYADIS ident mb_loc = do let uri = fromMaybe (getIdentifier ident) mb_loc req <- parseUrl uri res <- httpLbs req @@ -65,7 +63,7 @@ discoverYADIS resolve ident mb_loc = do case statusCode res of 200 -> case mloc of - Just loc -> discoverYADIS resolve ident (Just $ S8.unpack loc) + Just loc -> discoverYADIS ident (Just $ S8.unpack loc) Nothing -> do let mdoc = parseXRDS $ BSLU.toString $ responseBody res case mdoc of @@ -91,16 +89,16 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat , ("http://openid.net/signon/1.0" , localId) , ("http://openid.net/signon/1.1" , localId) ] - uri <- parseProvider =<< listToMaybe (serviceURIs svc) - return (uri,lid) + uri <- listToMaybe $ serviceURIs svc + return (Provider uri, lid) -- 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 :: Resolver IO -> Identifier -> IO (Maybe (Provider,Identifier)) -discoverHTML resolve ident'@(Identifier ident) = +discoverHTML :: Identifier -> IO (Maybe (Provider,Identifier)) +discoverHTML ident'@(Identifier ident) = parseHTML ident' . BSLU.toString <$> simpleHttp ident -- | Parse out an OpenID endpoint and an actual identifier from an HTML @@ -113,9 +111,9 @@ parseHTML ident = resolve where isOpenId (rel,_) = "openid" `isPrefixOf` rel resolve ls = do - prov <- parseProvider =<< lookup "openid2.provider" ls + prov <- lookup "openid2.provider" ls let lid = maybe ident Identifier $ lookup "openid2.local_id" ls - return (prov,lid) + return (Provider prov,lid) -- | Filter out link tags from a list of html tags. diff --git a/OpenId2/HTTP.hs b/OpenId2/HTTP.hs deleted file mode 100644 index 5ca523d5..00000000 --- a/OpenId2/HTTP.hs +++ /dev/null @@ -1,94 +0,0 @@ - --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.HTTP --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -module OpenId2.HTTP ( - -- * Request Interface - makeRequest - - -- * Request/Response Parsing and Formatting - , parseDirectResponse - , formatParams - , formatDirectParams - , escapeParam - , addParams - , parseParams - ) where - --- friends -import OpenId2.Types ---import Network.OpenID.Utils - --- libraries -import Data.List -import Network.BSD -import Network.Socket -import Network.URI hiding (query) -import Network.HTTP.Enumerator - - --- | Perform an http request. --- If the Bool parameter is set to True, redirects from the server will be --- followed. -makeRequest :: Bool -> Resolver IO -makeRequest follow = if follow then httpLbsRedirect else httpLbs - --- Parsing and Formatting ------------------------------------------------------ - --- | Turn a response body into a list of parameters. -parseDirectResponse :: String -> Params -parseDirectResponse = unfoldr step - where - step [] = Nothing - step str = case split (== '\n') str of - (ps,rest) -> Just (split (== ':') ps,rest) - - --- | Format OpenID parameters as a query string -formatParams :: Params -> String -formatParams = intercalate "&" . map f - where f (x,y) = x ++ "=" ++ escapeParam y - - --- | Format OpenID parameters as a direct response -formatDirectParams :: Params -> String -formatDirectParams = concatMap f - where f (x,y) = x ++ ":" ++ y ++ "\n" - - --- | Escape for the query string of a URI -escapeParam :: String -> String -escapeParam = escapeURIString isUnreserved - - --- | Add Parameters to a URI -addParams :: Params -> URI -> URI -addParams ps uri = uri { uriQuery = query } - where - f (k,v) = (k,v) - ps' = map f ps - query = '?' : formatParams (parseParams (uriQuery uri) ++ ps') - - --- | Parse OpenID parameters out of a url string -parseParams :: String -> Params -parseParams xs = case split (== '?') xs of - (_,bs) -> unfoldr step bs - where - step [] = Nothing - step bs = case split (== '&') bs of - (as,rest) -> case split (== '=') as of - (k,v) -> Just ((k, unEscapeString v),rest) - -split :: (a -> Bool) -> [a] -> ([a],[a]) -split p as = case break p as of - (xs,_:ys) -> (xs,ys) - pair -> pair diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs index 0dc4eb4b..203c697c 100644 --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -21,8 +21,8 @@ import OpenId2.Types import Control.Applicative import Control.Monad import Data.List -import Network.URI hiding (scheme,path) import Control.Failure (Failure (..)) +import Network.URI normalize :: Failure OpenIdException m => String -> m Identifier normalize ident = @@ -49,11 +49,11 @@ normalizeIdentifier' xri (Identifier 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 + scheme' = uriScheme uri + validScheme = guard (scheme' == "http:" || scheme' == "https:") + u = uri { uriFragment = "", uriPath = path' } + path' | null (uriPath uri) = "/" + | otherwise = uriPath uri fmt u = Identifier $ normalizePathSegments diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index ad2bf473..95b76ae4 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -11,28 +11,12 @@ -- module OpenId2.Types ( - AssocType(..) - , SessionType(..) - , Association(..) - , Params - , ReturnTo - , Realm - , Resolver - , Provider (..) - , parseProvider - , showProvider - , modifyProvider - , Identifier(..) - , Error(..) - , assocString + Provider (..) + , Identifier (..) , OpenIdException (..) ) where -- Libraries -import Data.List -import Data.Word -import Network.URI -import Network.HTTP.Enumerator (Request, Response) import Control.Exception (Exception) import Data.Typeable (Typeable) @@ -43,83 +27,9 @@ data OpenIdException = deriving (Show, Typeable) instance Exception OpenIdException --------------------------------------------------------------------------------- --- Types - --- | Supported association types -data AssocType = HmacSha1 | HmacSha256 - deriving (Read,Show) - -assocString :: AssocType -> String -assocString HmacSha1 = "HMAC-SHA1" -assocString HmacSha256 = "HMAC-SHA256" - -{- -instance Show AssocType where - show HmacSha1 = "HMAC-SHA1" - show HmacSha256 = "HMAC-SHA256" - -instance Read AssocType where - readsPrec _ str | "HMAC-SHA1" `isPrefixOf` str = [(HmacSha1 ,drop 9 str)] - | "HMAC-SHA256" `isPrefixOf` str = [(HmacSha256, drop 11 str)] - | otherwise = [] --} - --- | Session types for association establishment -data SessionType = NoEncryption | DhSha1 | DhSha256 - -instance Show SessionType where - show NoEncryption = "no-encryption" - show DhSha1 = "DH-SHA1" - show DhSha256 = "DH-SHA256" - -instance Read SessionType where - readsPrec _ str - | "no-encryption" `isPrefixOf` str = [(NoEncryption, drop 13 str)] - | "DH-SHA1" `isPrefixOf` str = [(DhSha1, drop 7 str)] - | "DH-SHA256" `isPrefixOf` str = [(DhSha256, drop 9 str)] - | otherwise = [] - - --- | An association with a provider. -data Association = Association - { assocExpiresIn :: Int - , assocHandle :: String - , assocMacKey :: [Word8] - , assocType :: AssocType - } deriving (Show,Read) - - --- | Parameter lists for communication with the server -type Params = [(String,String)] - --- | A return to path -type ReturnTo = String - --- | A realm of uris for a provider to inform a user about -type Realm = String - --- | A way to resolve an HTTP request -type Resolver m = Request -> m Response - -- | An OpenID provider. -newtype Provider = Provider { providerURI :: URI } deriving (Eq,Show) - --- | Parse a provider -parseProvider :: String -> Maybe Provider -parseProvider = fmap Provider . parseURI - --- | Show a provider -showProvider :: Provider -> String -showProvider (Provider uri) = uriToString (const "") uri [] - --- | Modify the URI in a provider -modifyProvider :: (URI -> URI) -> Provider -> Provider -modifyProvider f (Provider uri) = Provider (f uri) +newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) -- | A valid OpenID identifier. newtype Identifier = Identifier { getIdentifier :: String } deriving (Eq,Show,Read) - --- | Errors -newtype Error = Error String deriving Show diff --git a/OpenId2/XRDS.hs b/OpenId2/XRDS.hs index 7594f94a..1cfba367 100644 --- a/OpenId2/XRDS.hs +++ b/OpenId2/XRDS.hs @@ -12,13 +12,9 @@ module OpenId2.XRDS ( -- * Types - XRDS, XRD + XRDS , Service(..) - -- * Utility Functions - , isUsable - , hasType - -- * Parsing , parseXRDS ) where @@ -48,11 +44,6 @@ data Service = Service -- Utilities ------------------------------------------------------------------- --- | Check to see if an XRDS service description is usable. -isUsable :: XRDS -> Bool -isUsable = not . null . concat - - -- | Generate a tag name predicate, that ignores prefix and namespace. tag :: String -> Element -> Bool tag n el = qName (elName el) == n @@ -76,12 +67,6 @@ getText el = case elContent el of [Text cd] -> cdData cd _ -> [] - --- | Generate a predicate over Service Types. -hasType :: String -> Service -> Bool -hasType ty svc = ty `elem` serviceTypes svc - - -- Parsing --------------------------------------------------------------------- diff --git a/Web/Authenticate/OpenId2.hs b/Web/Authenticate/OpenId2.hs index b39d8b7c..59498f92 100644 --- a/Web/Authenticate/OpenId2.hs +++ b/Web/Authenticate/OpenId2.hs @@ -8,7 +8,6 @@ module Web.Authenticate.OpenId2 import Control.Monad.IO.Class import OpenId2.Normalization (normalize) import OpenId2.Discovery (discover) -import OpenId2.HTTP (makeRequest, parseDirectResponse) import Control.Failure (Failure (failure)) import OpenId2.Types (OpenIdException (..), Identifier (Identifier), Provider (Provider)) @@ -16,17 +15,18 @@ import Web.Authenticate.Internal (qsUrl) import Control.Monad (unless) import qualified Data.ByteString.UTF8 as BSU import qualified Data.ByteString.Lazy.UTF8 as BSLU -import Network.HTTP.Enumerator (parseUrl, urlEncodedBody, responseBody) +import Network.HTTP.Enumerator + (parseUrl, urlEncodedBody, responseBody, httpLbsRedirect) import Control.Arrow ((***)) +import Data.List (unfoldr) getForwardUrl :: (MonadIO m, Failure OpenIdException m) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. getForwardUrl openid' complete = do - let resolve = makeRequest True - (Provider p, Identifier i) <- normalize openid' >>= discover resolve - return $ qsUrl (show p) + (Provider p, Identifier i) <- normalize openid' >>= discover + return $ qsUrl p [ ("openid.ns", "http://specs.openid.net/auth/2.0") , ("openid.mode", "checkid_setup") , ("openid.claimed_id", i) @@ -49,15 +49,29 @@ authenticate params = do Just e -> return e Nothing -> failure $ AuthenticationException "Missing op_endpoint" + (Provider p, Identifier i) <- normalize ident >>= discover + unless (endpoint == p) $ + failure $ AuthenticationException "endpoint does not match discovery" let params' = map (BSU.fromString *** BSU.fromString) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params req' <- liftIO $ parseUrl endpoint let req = urlEncodedBody params' req' - rsp <- liftIO $ makeRequest True req + rsp <- liftIO $ httpLbsRedirect req let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp case lookup "is_valid" rps of Just "true" -> return ident - Nothing -> - failure $ AuthenticationException "OpenID provider did not validate" - -- FIXME check if endpoint is valid for given identity + _ -> failure $ AuthenticationException "OpenID provider did not validate" + +-- | Turn a response body into a list of parameters. +parseDirectResponse :: String -> [(String, String)] +parseDirectResponse = unfoldr step + 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.cabal b/authenticate.cabal index 0b7e3f15..01f26b9e 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -31,7 +31,6 @@ library Web.Authenticate.Facebook other-modules: Web.Authenticate.Internal, OpenId2.Discovery, - OpenId2.HTTP, OpenId2.Normalization, OpenId2.Types, OpenId2.XRDS From 6e575cf0276e5a447987b9add1eb442a8965b6d8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 11:02:49 +0200 Subject: [PATCH 027/182] OpenID 1 support built into OpenID 2 code --- OpenId2/Discovery.hs | 36 ++++++++++++++++++++++++++------- Web/Authenticate/Internal.hs | 3 ++- Web/Authenticate/OpenId2.hs | 39 ++++++++++++++++++++---------------- 3 files changed, 53 insertions(+), 25 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index f4898bb0..935429f4 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -14,8 +14,10 @@ module OpenId2.Discovery ( -- * Discovery discover + , Discovery (..) ) where +import Debug.Trace -- FIXME -- Friends import OpenId2.Types import OpenId2.XRDS @@ -27,19 +29,24 @@ import Data.Maybe import Network.HTTP.Enumerator import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Char8 as S8 -import Control.Arrow (first) +import Control.Arrow (first, (***)) import Control.Applicative ((<$>)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Failure (Failure (failure)) +import Control.Monad (mplus) + +data Discovery = Discovery1 String (Maybe String) + | Discovery2 Provider Identifier + deriving Show -- | Attempt to resolve an OpenID endpoint, and user identifier. discover :: (MonadIO m, Failure OpenIdException m) => Identifier - -> m (Provider, Identifier) + -> m Discovery discover ident@(Identifier i) = do res1 <- liftIO $ discoverYADIS ident Nothing case res1 of - Just x -> return x + Just (x, y) -> return $ Discovery2 x y Nothing -> do res2 <- liftIO $ discoverHTML ident case res2 of @@ -97,23 +104,29 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat -- | 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 :: Identifier -> IO (Maybe (Provider,Identifier)) +discoverHTML :: Identifier -> IO (Maybe Discovery) discoverHTML ident'@(Identifier ident) = parseHTML ident' . BSLU.toString <$> simpleHttp ident -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. -parseHTML :: Identifier -> String -> Maybe (Provider,Identifier) +parseHTML :: Identifier -> String -> Maybe Discovery parseHTML ident = resolve . filter isOpenId + . map (dropQuotes *** dropQuotes) . linkTags . htmlTags where isOpenId (rel,_) = "openid" `isPrefixOf` rel - resolve ls = do + 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 - return (Provider prov,lid) + return $ Discovery2 (Provider prov) lid + resolve ls = traceShow ls $ resolve2 ls `mplus` resolve1 ls -- | Filter out link tags from a list of html tags. @@ -150,3 +163,12 @@ splitAttr xs = case break (== '=') xs of f key p cs = case break p cs of (_,[]) -> Nothing (value,_:rest) -> Just ((key,value), dropWhile isSpace rest) + +dropQuotes :: String -> String +dropQuotes s@('\'':x:y) + | last y == '\'' = x : init y + | otherwise = s +dropQuotes s@('"':x:y) + | last y == '"' = x : init y + | otherwise = s +dropQuotes s = s diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs index 93e8594a..9e410ce7 100644 --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -10,9 +10,10 @@ import Data.List (intercalate) qsUrl :: String -> [(String, String)] -> String qsUrl s [] = s qsUrl url pairs = - url ++ "?" ++ intercalate "&" (map qsPair pairs) + url ++ delim : intercalate "&" (map qsPair pairs) where qsPair (x, y) = qsEncode x ++ '=' : qsEncode y + delim = if '?' `elem` url then '&' else '?' qsEncode :: String -> String qsEncode = diff --git a/Web/Authenticate/OpenId2.hs b/Web/Authenticate/OpenId2.hs index 59498f92..9b408625 100644 --- a/Web/Authenticate/OpenId2.hs +++ b/Web/Authenticate/OpenId2.hs @@ -7,7 +7,7 @@ module Web.Authenticate.OpenId2 import Control.Monad.IO.Class import OpenId2.Normalization (normalize) -import OpenId2.Discovery (discover) +import OpenId2.Discovery (discover, Discovery (..)) import Control.Failure (Failure (failure)) import OpenId2.Types (OpenIdException (..), Identifier (Identifier), Provider (Provider)) @@ -19,20 +19,29 @@ import Network.HTTP.Enumerator (parseUrl, urlEncodedBody, responseBody, httpLbsRedirect) import Control.Arrow ((***)) import Data.List (unfoldr) +import Data.Maybe (fromMaybe) getForwardUrl :: (MonadIO m, Failure OpenIdException m) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. getForwardUrl openid' complete = do - (Provider p, Identifier i) <- normalize openid' >>= discover - return $ qsUrl p - [ ("openid.ns", "http://specs.openid.net/auth/2.0") - , ("openid.mode", "checkid_setup") - , ("openid.claimed_id", i) - , ("openid.identity", i) - , ("openid.return_to", complete) - ] + disc <- normalize openid' >>= discover + case disc of + Discovery1 server mdelegate -> + return $ qsUrl server + [ ("openid.mode", "checkid_setup") + , ("openid.identity", fromMaybe openid' mdelegate) + , ("openid.return_to", complete) + ] + Discovery2 (Provider p) (Identifier i) -> + return $ qsUrl p + [ ("openid.ns", "http://specs.openid.net/auth/2.0") + , ("openid.mode", "checkid_setup") + , ("openid.claimed_id", i) + , ("openid.identity", i) + , ("openid.return_to", complete) + ] authenticate :: (MonadIO m, Failure OpenIdException m) => [(String, String)] @@ -44,14 +53,10 @@ authenticate params = do Just i -> return i Nothing -> failure $ AuthenticationException "Missing identity" - endpoint <- - case lookup "openid.op_endpoint" params of - Just e -> return e - Nothing -> - failure $ AuthenticationException "Missing op_endpoint" - (Provider p, Identifier i) <- normalize ident >>= discover - unless (endpoint == p) $ - failure $ AuthenticationException "endpoint does not match discovery" + disc <- normalize ident >>= discover + let endpoint = case disc of + Discovery1 p _ -> p + Discovery2 (Provider p) _ -> p let params' = map (BSU.fromString *** BSU.fromString) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params From 48f31ed6de6e891d1fa74c16574ecb716d5f4dc8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 11:11:35 +0200 Subject: [PATCH 028/182] Merged OpenId and OpenId2 --- OpenId2/Discovery.hs | 6 +- OpenId2/Types.hs | 4 +- Web/Authenticate/OpenId.hs | 205 ++++++++++++------------------------ Web/Authenticate/OpenId2.hs | 82 --------------- Web/Authenticate/Rpxnow.hs | 14 ++- authenticate.cabal | 1 - 6 files changed, 83 insertions(+), 229 deletions(-) delete mode 100644 Web/Authenticate/OpenId2.hs diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 935429f4..7922638a 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -17,7 +17,6 @@ module OpenId2.Discovery ( , Discovery (..) ) where -import Debug.Trace -- FIXME -- Friends import OpenId2.Types import OpenId2.XRDS @@ -61,7 +60,7 @@ discoverYADIS :: Identifier -> Maybe String -> IO (Maybe (Provider,Identifier)) discoverYADIS ident mb_loc = do - let uri = fromMaybe (getIdentifier ident) mb_loc + let uri = fromMaybe (identifier ident) mb_loc req <- parseUrl uri res <- httpLbs req let mloc = lookup "x-xrds-location" @@ -126,9 +125,10 @@ parseHTML ident = resolve prov <- lookup "openid2.provider" ls let lid = maybe ident Identifier $ lookup "openid2.local_id" ls return $ Discovery2 (Provider prov) lid - resolve ls = traceShow ls $ resolve2 ls `mplus` resolve1 ls + resolve ls = resolve2 ls `mplus` resolve1 ls +-- FIXME this would all be a lot better if it used tagsoup -- | Filter out link tags from a list of html tags. linkTags :: [String] -> [(String,String)] linkTags = mapMaybe f . filter p diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index 95b76ae4..2660ca57 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -31,5 +31,5 @@ instance Exception OpenIdException newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) -- | A valid OpenID identifier. -newtype Identifier = Identifier { getIdentifier :: String } - deriving (Eq,Show,Read) +newtype Identifier = Identifier { identifier :: String } + deriving (Eq, Show, Read) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 589498bd..0652a052 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,152 +1,83 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE PackageImports #-} ---------------------------------------------------------- --- | --- Module : Web.Authenticate.OpenId --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Unstable --- Portability : portable --- --- Provides functionality for being an OpenId consumer. --- ---------------------------------------------------------- module Web.Authenticate.OpenId - ( Identifier (..) - , getForwardUrl + ( getForwardUrl , authenticate - , AuthenticateException (..) + , OpenIdException (..) + , Identifier (..) ) where -import Network.HTTP.Enumerator -import Text.HTML.TagSoup -import "transformers" Control.Monad.IO.Class -import Data.Data -import Control.Failure hiding (Error) -import Control.Exception -import Control.Monad (liftM, unless) -import qualified Data.ByteString.Lazy.Char8 as L8 +import Control.Monad.IO.Class +import OpenId2.Normalization (normalize) +import OpenId2.Discovery (discover, Discovery (..)) +import Control.Failure (Failure (failure)) +import OpenId2.Types (OpenIdException (..), Identifier (Identifier), + Provider (Provider)) import Web.Authenticate.Internal (qsUrl) -import Data.List (intercalate) +import Control.Monad (unless) +import qualified Data.ByteString.UTF8 as BSU +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import Network.HTTP.Enumerator + (parseUrl, urlEncodedBody, responseBody, httpLbsRedirect) +import Control.Arrow ((***)) +import Data.List (unfoldr) +import Data.Maybe (fromMaybe) --- | An openid identifier (ie, a URL). -newtype Identifier = Identifier { identifier :: String } - deriving (Eq, Show) - -data Error v = Error String | Ok v -instance Monad Error where - return = Ok - Error s >>= _ = Error s - Ok v >>= f = f v - fail s = Error s - --- | Returns a URL to forward the user to in order to login. -getForwardUrl :: (MonadIO m, - Failure InvalidUrlException m, - Failure HttpException m, - Failure MissingVar m - ) +getForwardUrl :: (MonadIO m, Failure OpenIdException m) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. -getForwardUrl openid complete = do - bodyIdent' <- simpleHttp openid - let bodyIdent = L8.unpack bodyIdent' - server <- getOpenIdVar "server" bodyIdent - let delegate = maybe openid id - $ getOpenIdVar "delegate" bodyIdent - return $ qsUrl server - [ ("openid.mode", "checkid_setup") - , ("openid.identity", delegate) - , ("openid.return_to", complete) - ] +getForwardUrl openid' complete = do + disc <- normalize openid' >>= discover + case disc of + Discovery1 server mdelegate -> + return $ qsUrl server + [ ("openid.mode", "checkid_setup") + , ("openid.identity", fromMaybe openid' mdelegate) + , ("openid.return_to", complete) + ] + Discovery2 (Provider p) (Identifier i) -> + return $ qsUrl p + [ ("openid.ns", "http://specs.openid.net/auth/2.0") + , ("openid.mode", "checkid_setup") + , ("openid.claimed_id", i) + , ("openid.identity", i) + , ("openid.return_to", complete) + ] -data MissingVar = MissingVar String - deriving (Typeable, Show) -instance Exception MissingVar - -getOpenIdVar :: Failure MissingVar m => String -> String -> m String -getOpenIdVar var content = do - let tags = parseTags content - let secs = sections (~== ("")) tags - secs' <- mhead secs - secs'' <- mhead secs' - return $ fromAttrib "href" secs'' - where - mhead [] = failure $ MissingVar $ "openid." ++ var - mhead (x:_) = return x - --- | Handle a redirect from an OpenID provider and check that the user --- logged in properly. If it was successfully, 'return's the openid. --- Otherwise, 'failure's an explanation. -authenticate :: (MonadIO m, - Failure AuthenticateException m, - Failure InvalidUrlException m, - Failure HttpException m, - Failure MissingVar m) +authenticate :: (MonadIO m, Failure OpenIdException m) => [(String, String)] -> m Identifier -authenticate req = do - unless (lookup "openid.mode" req == Just "id_res") $ - failure $ AuthenticateException "authenticate without openid.mode=id_res" - authUrl <- getAuthUrl req - content <- L8.unpack `liftM` simpleHttp authUrl - if contains "is_valid:true" content - then Identifier `liftM` alookup "openid.identity" req - else failure $ AuthenticateException content +authenticate params = do + unless (lookup "openid.mode" params == Just "id_res") + $ failure $ AuthenticationException "mode is not id_res" + ident <- case lookup "openid.identity" params of + Just i -> return i + Nothing -> + failure $ AuthenticationException "Missing identity" + disc <- normalize ident >>= discover + let endpoint = case disc of + Discovery1 p _ -> p + Discovery2 (Provider p) _ -> p + let params' = map (BSU.fromString *** BSU.fromString) + $ ("openid.mode", "check_authentication") + : filter (\(k, _) -> k /= "openid.mode") params + req' <- liftIO $ parseUrl endpoint + let req = urlEncodedBody params' req' + rsp <- liftIO $ httpLbsRedirect req + let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp + case lookup "is_valid" rps of + Just "true" -> return $ Identifier ident + _ -> failure $ AuthenticationException "OpenID provider did not validate" -alookup :: (Failure AuthenticateException m, Monad m) - => String - -> [(String, String)] - -> m String -alookup k x = case lookup k x of - Just k' -> return k' - Nothing -> failure $ MissingOpenIdParameter k +-- | Turn a response body into a list of parameters. +parseDirectResponse :: String -> [(String, String)] +parseDirectResponse = unfoldr step + where + step [] = Nothing + step str = case split (== '\n') str of + (ps,rest) -> Just (split (== ':') ps,rest) -data AuthenticateException = AuthenticateException String - | MissingOpenIdParameter String - deriving (Show, Typeable) -instance Exception AuthenticateException - -getAuthUrl :: (MonadIO m, Failure AuthenticateException m, - Failure InvalidUrlException m, - Failure HttpException m, - Failure MissingVar m) - => [(String, String)] -> m String -getAuthUrl req = do - identity <- alookup "openid.identity" req - idContent <- simpleHttp identity - helper $ L8.unpack idContent - where - helper idContent = do - server <- getOpenIdVar "server" idContent - dargs <- mapM makeArg [ - "assoc_handle", - "sig", - "signed", - "identity", - "return_to" - ] - let sargs = [("openid.mode", "check_authentication")] - return $ qsUrl server $ dargs ++ sargs - makeArg s = do - let k = "openid." ++ s - v <- alookup k req - return (k, v) - -contains :: String -> String -> Bool -contains [] _ = True -contains _ [] = False -contains needle haystack = - begins needle haystack || - (contains needle $ tail haystack) - -begins :: String -> String -> Bool -begins [] _ = True -begins _ [] = False -begins (x:xs) (y:ys) = x == y && begins xs ys +split :: (a -> Bool) -> [a] -> ([a],[a]) +split p as = case break p as of + (xs,_:ys) -> (xs,ys) + pair -> pair diff --git a/Web/Authenticate/OpenId2.hs b/Web/Authenticate/OpenId2.hs deleted file mode 100644 index 9b408625..00000000 --- a/Web/Authenticate/OpenId2.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Web.Authenticate.OpenId2 - ( getForwardUrl - , authenticate - , OpenIdException (..) - ) where - -import Control.Monad.IO.Class -import OpenId2.Normalization (normalize) -import OpenId2.Discovery (discover, Discovery (..)) -import Control.Failure (Failure (failure)) -import OpenId2.Types (OpenIdException (..), Identifier (Identifier), - Provider (Provider)) -import Web.Authenticate.Internal (qsUrl) -import Control.Monad (unless) -import qualified Data.ByteString.UTF8 as BSU -import qualified Data.ByteString.Lazy.UTF8 as BSLU -import Network.HTTP.Enumerator - (parseUrl, urlEncodedBody, responseBody, httpLbsRedirect) -import Control.Arrow ((***)) -import Data.List (unfoldr) -import Data.Maybe (fromMaybe) - -getForwardUrl :: (MonadIO m, Failure OpenIdException m) - => String -- ^ The openid the user provided. - -> String -- ^ The URL for this application\'s complete page. - -> m String -- ^ URL to send the user to. -getForwardUrl openid' complete = do - disc <- normalize openid' >>= discover - case disc of - Discovery1 server mdelegate -> - return $ qsUrl server - [ ("openid.mode", "checkid_setup") - , ("openid.identity", fromMaybe openid' mdelegate) - , ("openid.return_to", complete) - ] - Discovery2 (Provider p) (Identifier i) -> - return $ qsUrl p - [ ("openid.ns", "http://specs.openid.net/auth/2.0") - , ("openid.mode", "checkid_setup") - , ("openid.claimed_id", i) - , ("openid.identity", i) - , ("openid.return_to", complete) - ] - -authenticate :: (MonadIO m, Failure OpenIdException m) - => [(String, String)] - -> m String -authenticate params = do - unless (lookup "openid.mode" params == Just "id_res") - $ failure $ AuthenticationException "mode is not id_res" - ident <- case lookup "openid.identity" params of - Just i -> return i - Nothing -> - failure $ AuthenticationException "Missing identity" - disc <- normalize ident >>= discover - let endpoint = case disc of - Discovery1 p _ -> p - Discovery2 (Provider p) _ -> p - let params' = map (BSU.fromString *** BSU.fromString) - $ ("openid.mode", "check_authentication") - : filter (\(k, _) -> k /= "openid.mode") params - req' <- liftIO $ parseUrl endpoint - let req = urlEncodedBody params' req' - rsp <- liftIO $ httpLbsRedirect req - let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp - case lookup "is_valid" rps of - Just "true" -> return ident - _ -> failure $ AuthenticationException "OpenID provider did not validate" - --- | Turn a response body into a list of parameters. -parseDirectResponse :: String -> [(String, String)] -parseDirectResponse = unfoldr step - 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/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index abe4521d..299a9b30 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow @@ -18,6 +19,7 @@ module Web.Authenticate.Rpxnow ( Identifier (..) , authenticate + , RpxnowException (..) ) where import Data.Object @@ -26,11 +28,11 @@ import Network.HTTP.Enumerator import "transformers" Control.Monad.IO.Class import Control.Failure import Data.Maybe -import Web.Authenticate.OpenId (AuthenticateException (..)) import Control.Monad import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L -import Control.Exception (throwIO) +import Control.Exception (throwIO, Exception) +import Data.Typeable (Typeable) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -42,7 +44,7 @@ data Identifier = Identifier authenticate :: (MonadIO m, Failure HttpException m, Failure InvalidUrlException m, - Failure AuthenticateException m, + Failure RpxnowException m, Failure ObjectExtractError m, Failure JsonDecodeError m) => String -- ^ API key given by RPXNOW. @@ -75,7 +77,7 @@ authenticate apiKey token = do o <- decode $ S.concat $ L.toChunks b m <- fromMapping o stat <- lookupScalar "stat" m - unless (stat == "ok") $ failure $ AuthenticateException $ + unless (stat == "ok") $ failure $ RpxnowException $ "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b parseProfile m @@ -90,3 +92,7 @@ parseProfile m = do go ("identifier", _) = Nothing go (k, Scalar v) = Just (k, v) go _ = Nothing + +data RpxnowException = RpxnowException String + deriving (Show, Typeable) +instance Exception RpxnowException diff --git a/authenticate.cabal b/authenticate.cabal index 01f26b9e..1042bc06 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -27,7 +27,6 @@ library xml >= 1.3.7 && < 1.4 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, - Web.Authenticate.OpenId2, Web.Authenticate.Facebook other-modules: Web.Authenticate.Internal, OpenId2.Discovery, From 63853a78dfffbf6edf70b20bcf32d0a73bf6e15d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Oct 2010 11:16:42 +0200 Subject: [PATCH 029/182] Proper exception propogation --- OpenId2/Discovery.hs | 32 ++++++++++++++++++++++---------- Web/Authenticate/OpenId.hs | 20 +++++++++++++++----- 2 files changed, 37 insertions(+), 15 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 7922638a..9ba7385a 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -29,25 +29,28 @@ import Network.HTTP.Enumerator import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Char8 as S8 import Control.Arrow (first, (***)) -import Control.Applicative ((<$>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.IO.Class (MonadIO) import Control.Failure (Failure (failure)) -import Control.Monad (mplus) +import Control.Monad (mplus, liftM) data Discovery = Discovery1 String (Maybe String) | Discovery2 Provider Identifier deriving Show -- | Attempt to resolve an OpenID endpoint, and user identifier. -discover :: (MonadIO m, Failure OpenIdException m) +discover :: ( MonadIO m + , Failure OpenIdException m + , Failure HttpException m + , Failure InvalidUrlException m + ) => Identifier -> m Discovery discover ident@(Identifier i) = do - res1 <- liftIO $ discoverYADIS ident Nothing + res1 <- discoverYADIS ident Nothing case res1 of Just (x, y) -> return $ Discovery2 x y Nothing -> do - res2 <- liftIO $ discoverHTML ident + res2 <- discoverHTML ident case res2 of Just x -> return x Nothing -> failure $ DiscoveryException i @@ -56,9 +59,13 @@ discover ident@(Identifier i) = do -- | Attempt a YADIS based discovery, given a valid identifier. The result is -- an OpenID endpoint, and the actual identifier for the user. -discoverYADIS :: Identifier +discoverYADIS :: ( MonadIO m + , Failure HttpException m + , Failure InvalidUrlException m + ) + => Identifier -> Maybe String - -> IO (Maybe (Provider,Identifier)) + -> m (Maybe (Provider,Identifier)) discoverYADIS ident mb_loc = do let uri = fromMaybe (identifier ident) mb_loc req <- parseUrl uri @@ -103,9 +110,14 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat -- | 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 :: Identifier -> IO (Maybe Discovery) +discoverHTML :: ( MonadIO m + , Failure HttpException m + , Failure InvalidUrlException m + ) + => Identifier + -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) = - parseHTML ident' . BSLU.toString <$> simpleHttp ident + (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 0652a052..8c510320 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -17,12 +17,18 @@ import Control.Monad (unless) import qualified Data.ByteString.UTF8 as BSU import qualified Data.ByteString.Lazy.UTF8 as BSLU import Network.HTTP.Enumerator - (parseUrl, urlEncodedBody, responseBody, httpLbsRedirect) + ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect + , HttpException, InvalidUrlException + ) import Control.Arrow ((***)) import Data.List (unfoldr) import Data.Maybe (fromMaybe) -getForwardUrl :: (MonadIO m, Failure OpenIdException m) +getForwardUrl :: ( MonadIO m + , Failure OpenIdException m + , Failure HttpException m + , Failure InvalidUrlException m + ) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. @@ -44,7 +50,11 @@ getForwardUrl openid' complete = do , ("openid.return_to", complete) ] -authenticate :: (MonadIO m, Failure OpenIdException m) +authenticate :: ( MonadIO m + , Failure OpenIdException m + , Failure InvalidUrlException m + , Failure HttpException m + ) => [(String, String)] -> m Identifier authenticate params = do @@ -61,9 +71,9 @@ authenticate params = do let params' = map (BSU.fromString *** BSU.fromString) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params - req' <- liftIO $ parseUrl endpoint + req' <- parseUrl endpoint let req = urlEncodedBody params' req' - rsp <- liftIO $ httpLbsRedirect req + rsp <- httpLbsRedirect req let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp case lookup "is_valid" rps of Just "true" -> return $ Identifier ident From e0011ad2b5eb5dd574507dd7b9a3667131c452f0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 6 Oct 2010 05:55:25 +0200 Subject: [PATCH 030/182] Prevent endless YADIS-redirect loop --- OpenId2/Discovery.hs | 8 +++++--- authenticate.cabal | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 9ba7385a..03b6a561 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -70,13 +70,15 @@ discoverYADIS ident mb_loc = do let uri = fromMaybe (identifier ident) mb_loc req <- parseUrl uri res <- httpLbs req - let mloc = lookup "x-xrds-location" + let mloc = fmap S8.unpack + $ lookup "x-xrds-location" $ map (first $ map toLower . S8.unpack) $ responseHeaders res + let mloc' = if mloc == mb_loc then Nothing else mloc case statusCode res of 200 -> - case mloc of - Just loc -> discoverYADIS ident (Just $ S8.unpack loc) + case mloc' of + Just loc -> discoverYADIS ident (Just loc) Nothing -> do let mdoc = parseXRDS $ BSLU.toString $ responseBody res case mdoc of diff --git a/authenticate.cabal b/authenticate.cabal index 1042bc06..604d5fab 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.6 +version: 0.6.6.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From a2eb422a2a9b55d346ad05cfccc0e1b7d48f22d5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 6 Oct 2010 19:59:47 +0200 Subject: [PATCH 031/182] Cap YADIS redirects to 10 --- OpenId2/Discovery.hs | 9 ++++++--- Web/Authenticate/OpenId.hs | 1 + authenticate.cabal | 2 +- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 03b6a561..ba60a3a1 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -46,7 +46,7 @@ discover :: ( MonadIO m => Identifier -> m Discovery discover ident@(Identifier i) = do - res1 <- discoverYADIS ident Nothing + res1 <- discoverYADIS ident Nothing 10 case res1 of Just (x, y) -> return $ Discovery2 x y Nothing -> do @@ -65,8 +65,11 @@ discoverYADIS :: ( MonadIO m ) => Identifier -> Maybe String + -> Int -- ^ remaining redirects -> m (Maybe (Provider,Identifier)) -discoverYADIS ident mb_loc = do +discoverYADIS _ _ 0 = + failure $ InvalidUrlException "" "discoverYADIS redirected too many times" -- FIXME better failure +discoverYADIS ident mb_loc redirects = do let uri = fromMaybe (identifier ident) mb_loc req <- parseUrl uri res <- httpLbs req @@ -78,7 +81,7 @@ discoverYADIS ident mb_loc = do case statusCode res of 200 -> case mloc' of - Just loc -> discoverYADIS ident (Just loc) + Just loc -> discoverYADIS ident (Just loc) (redirects - 1) Nothing -> do let mdoc = parseXRDS $ BSLU.toString $ responseBody res case mdoc of diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 8c510320..8d773653 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -40,6 +40,7 @@ getForwardUrl openid' complete = do [ ("openid.mode", "checkid_setup") , ("openid.identity", fromMaybe openid' mdelegate) , ("openid.return_to", complete) + , ("openid.trust_root", complete) ] Discovery2 (Provider p) (Identifier i) -> return $ qsUrl p diff --git a/authenticate.cabal b/authenticate.cabal index 604d5fab..296a7f42 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.6.1 +version: 0.6.6.2 license: BSD3 license-file: LICENSE author: Michael Snoyman From 0571daf1ff662d58a310fb0a2b00ef287f3d7ad4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 7 Oct 2010 23:34:18 +0200 Subject: [PATCH 032/182] Consolidated exception types --- OpenId2/Discovery.hs | 12 +++--------- OpenId2/Normalization.hs | 2 +- OpenId2/Types.hs | 10 ++-------- Web/Authenticate/Internal.hs | 14 +++++++++++++- Web/Authenticate/OpenId.hs | 13 +++++-------- Web/Authenticate/Rpxnow.hs | 15 +++++---------- authenticate.cabal | 4 ++-- 7 files changed, 31 insertions(+), 39 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index ba60a3a1..6381441e 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -39,9 +39,8 @@ data Discovery = Discovery1 String (Maybe String) -- | Attempt to resolve an OpenID endpoint, and user identifier. discover :: ( MonadIO m - , Failure OpenIdException m + , Failure AuthenticateException m , Failure HttpException m - , Failure InvalidUrlException m ) => Identifier -> m Discovery @@ -61,14 +60,12 @@ discover ident@(Identifier i) = do -- an OpenID endpoint, and the actual identifier for the user. discoverYADIS :: ( MonadIO m , Failure HttpException m - , Failure InvalidUrlException m ) => Identifier -> Maybe String -> Int -- ^ remaining redirects -> m (Maybe (Provider,Identifier)) -discoverYADIS _ _ 0 = - failure $ InvalidUrlException "" "discoverYADIS redirected too many times" -- FIXME better failure +discoverYADIS _ _ 0 = failure TooManyRedirects discoverYADIS ident mb_loc redirects = do let uri = fromMaybe (identifier ident) mb_loc req <- parseUrl uri @@ -115,10 +112,7 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat -- | 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 :: ( MonadIO m - , Failure HttpException m - , Failure InvalidUrlException m - ) +discoverHTML :: ( MonadIO m, Failure HttpException m) => Identifier -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) = diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs index 203c697c..9b71b300 100644 --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -24,7 +24,7 @@ import Data.List import Control.Failure (Failure (..)) import Network.URI -normalize :: Failure OpenIdException m => String -> m Identifier +normalize :: Failure AuthenticateException m => String -> m Identifier normalize ident = case normalizeIdentifier $ Identifier ident of Just i -> return i diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index 2660ca57..8230d634 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -13,19 +13,13 @@ module OpenId2.Types ( Provider (..) , Identifier (..) - , OpenIdException (..) + , AuthenticateException (..) ) where -- Libraries import Control.Exception (Exception) import Data.Typeable (Typeable) - -data OpenIdException = - NormalizationException String - | DiscoveryException String - | AuthenticationException String - deriving (Show, Typeable) -instance Exception OpenIdException +import Web.Authenticate.Internal -- | An OpenID provider. newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs index 9e410ce7..91393ab1 100644 --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -1,18 +1,30 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Web.Authenticate.Internal ( qsEncode , qsUrl + , AuthenticateException (..) ) where import Codec.Binary.UTF8.String (encode) import Numeric (showHex) import Data.List (intercalate) +import Data.Typeable (Typeable) +import Control.Exception (Exception) + +data AuthenticateException = + RpxnowException String + | NormalizationException String + | DiscoveryException String + | AuthenticationException String + deriving (Show, Typeable) +instance Exception AuthenticateException qsUrl :: String -> [(String, String)] -> String qsUrl s [] = s qsUrl url pairs = url ++ delim : intercalate "&" (map qsPair pairs) where - qsPair (x, y) = qsEncode x ++ '=' : qsEncode y + qsPair (x, y) = qsEncode x ++ '=' : qsEncode y delim = if '?' `elem` url then '&' else '?' qsEncode :: String -> String diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 8d773653..ab1244d0 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -2,7 +2,7 @@ module Web.Authenticate.OpenId ( getForwardUrl , authenticate - , OpenIdException (..) + , AuthenticateException (..) , Identifier (..) ) where @@ -10,24 +10,22 @@ import Control.Monad.IO.Class import OpenId2.Normalization (normalize) import OpenId2.Discovery (discover, Discovery (..)) import Control.Failure (Failure (failure)) -import OpenId2.Types (OpenIdException (..), Identifier (Identifier), - Provider (Provider)) +import OpenId2.Types import Web.Authenticate.Internal (qsUrl) import Control.Monad (unless) import qualified Data.ByteString.UTF8 as BSU import qualified Data.ByteString.Lazy.UTF8 as BSLU import Network.HTTP.Enumerator ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect - , HttpException, InvalidUrlException + , HttpException ) import Control.Arrow ((***)) import Data.List (unfoldr) import Data.Maybe (fromMaybe) getForwardUrl :: ( MonadIO m - , Failure OpenIdException m + , Failure AuthenticateException m , Failure HttpException m - , Failure InvalidUrlException m ) => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. @@ -52,8 +50,7 @@ getForwardUrl openid' complete = do ] authenticate :: ( MonadIO m - , Failure OpenIdException m - , Failure InvalidUrlException m + , Failure AuthenticateException m , Failure HttpException m ) => [(String, String)] diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index 299a9b30..740521dc 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -19,7 +19,7 @@ module Web.Authenticate.Rpxnow ( Identifier (..) , authenticate - , RpxnowException (..) + , AuthenticateException (..) ) where import Data.Object @@ -31,8 +31,8 @@ import Data.Maybe import Control.Monad import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L -import Control.Exception (throwIO, Exception) -import Data.Typeable (Typeable) +import Control.Exception (throwIO) +import Web.Authenticate.Internal -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -43,8 +43,7 @@ data Identifier = Identifier -- | Attempt to log a user in. authenticate :: (MonadIO m, Failure HttpException m, - Failure InvalidUrlException m, - Failure RpxnowException m, + Failure AuthenticateException m, Failure ObjectExtractError m, Failure JsonDecodeError m) => String -- ^ API key given by RPXNOW. @@ -73,7 +72,7 @@ authenticate apiKey token = do res <- httpLbsRedirect req let b = responseBody res unless (200 <= statusCode res && statusCode res < 300) $ - liftIO $ throwIO $ HttpException (statusCode res) b + liftIO $ throwIO $ StatusCodeException (statusCode res) b o <- decode $ S.concat $ L.toChunks b m <- fromMapping o stat <- lookupScalar "stat" m @@ -92,7 +91,3 @@ parseProfile m = do go ("identifier", _) = Nothing go (k, Scalar v) = Just (k, v) go _ = Nothing - -data RpxnowException = RpxnowException String - deriving (Show, Typeable) -instance Exception RpxnowException diff --git a/authenticate.cabal b/authenticate.cabal index 296a7f42..068a533b 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.6.6.2 +version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,7 +17,7 @@ library build-depends: base >= 4 && < 5, data-object >= 0.3.1 && < 0.4, data-object-json >= 0.3.1 && < 0.4, - http-enumerator >= 0.1.1 && < 0.2, + http-enumerator >= 0.2.0 && < 0.3, tagsoup >= 0.6 && < 0.12, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, From b901357db4f0468114958c2aebc83fcc8178fde3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Oct 2010 10:20:57 +0200 Subject: [PATCH 033/182] Warnings --- OpenId2/Types.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index 8230d634..33b1601e 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -17,8 +17,6 @@ module OpenId2.Types ( ) where -- Libraries -import Control.Exception (Exception) -import Data.Typeable (Typeable) import Web.Authenticate.Internal -- | An OpenID provider. From 221ee0ad170f28e0bcc24025f36403fc59fb9024 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 23 Oct 2010 19:33:52 +0200 Subject: [PATCH 034/182] Deriving more instances- from Jeremy Shaw --- OpenId2/Types.hs | 4 +++- Web/Authenticate/Facebook.hs | 7 +++++-- Web/Authenticate/Rpxnow.hs | 3 +++ authenticate.cabal | 2 +- 4 files changed, 12 insertions(+), 4 deletions(-) diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index 33b1601e..66afab4b 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -17,6 +17,8 @@ module OpenId2.Types ( ) where -- Libraries +import Data.Data (Data) +import Data.Typeable (Typeable) import Web.Authenticate.Internal -- | An OpenID provider. @@ -24,4 +26,4 @@ newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) -- | A valid OpenID identifier. newtype Identifier = Identifier { identifier :: String } - deriving (Eq, Show, Read) + deriving (Eq, Ord, Show, Read, Data, Typeable) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index b0b24a36..3571401d 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} module Web.Authenticate.Facebook where import Network.HTTP.Enumerator @@ -9,16 +10,18 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S import Web.Authenticate.Internal (qsEncode) +import Data.Data (Data) +import Data.Typeable (Typeable) data Facebook = Facebook { facebookClientId :: String , facebookClientSecret :: String , facebookRedirectUri :: String } - deriving (Show, Eq, Read) + deriving (Show, Eq, Read, Ord, Data, Typeable) newtype AccessToken = AccessToken { unAccessToken :: String } - deriving (Show, Eq, Read) + deriving (Show, Eq, Read, Ord, Data, Typeable) getForwardUrl :: Facebook -> [String] -> String getForwardUrl fb perms = concat diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index 740521dc..c60f235a 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -33,12 +33,15 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Control.Exception (throwIO) import Web.Authenticate.Internal +import Data.Data (Data) +import Data.Typeable (Typeable) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier { identifier :: String , extraData :: [(String, String)] } + deriving (Eq, Ord, Read, Show, Data, Typeable) -- | Attempt to log a user in. authenticate :: (MonadIO m, diff --git a/authenticate.cabal b/authenticate.cabal index 068a533b..3a50de16 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.7.0 +version: 0.7.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From 752abf0cd1922ce316bb737cca324f8289981888 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 24 Oct 2010 10:58:57 +0200 Subject: [PATCH 035/182] Web.Authenticate.OpenId.Providers --- Web/Authenticate/OpenId/Providers.hs | 13 +++++++++++++ authenticate.cabal | 7 ++++--- 2 files changed, 17 insertions(+), 3 deletions(-) create mode 100644 Web/Authenticate/OpenId/Providers.hs diff --git a/Web/Authenticate/OpenId/Providers.hs b/Web/Authenticate/OpenId/Providers.hs new file mode 100644 index 00000000..5cce4c86 --- /dev/null +++ b/Web/Authenticate/OpenId/Providers.hs @@ -0,0 +1,13 @@ +module Web.Authenticate.OpenId.Providers + where + +google = "https://www.google.com/accounts/o8/id" +yahoo = "http://me.yahoo.com/" +livejournal u = concat ["http://", u, ".livejournal.com/"] +myspace = (++) "http://myspace.com/" +wordpress u = concat ["http://", u, ".wordpress.com/"] +blogger u = concat ["http://", u, ".blogger.com/"] +verisign u = concat ["http://", u, ".pip.verisignlabs.com/"] +typepad u = concat ["http://", u, ".typepad.com/"] +myopenid u = concat ["http://", u, ".myopenid.com/"] +claimid = (++) "http://claimid.com/" diff --git a/authenticate.cabal b/authenticate.cabal index 3a50de16..d2a6be59 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,12 +1,12 @@ name: authenticate -version: 0.7.1 +version: 0.7.2 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: Authentication methods for Haskell web applications. -description: Focus is on remote authentication methods, such as OpenID, - rpxnow and Google. +description: Focus is on third-party authentication methods, such as OpenID, + rpxnow and Facebook. category: Web stability: Stable cabal-version: >= 1.2 @@ -27,6 +27,7 @@ library xml >= 1.3.7 && < 1.4 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, + Web.Authenticate.OpenId.Providers, Web.Authenticate.Facebook other-modules: Web.Authenticate.Internal, OpenId2.Discovery, From 40e75f625b7a5c5ef29dd2778c3b4a97ed8511e4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 29 Oct 2010 08:12:57 +0200 Subject: [PATCH 036/182] Type signatures for Providers --- Web/Authenticate/OpenId/Providers.hs | 33 +++++++++++++++++++++++++++- authenticate.cabal | 2 +- 2 files changed, 33 insertions(+), 2 deletions(-) diff --git a/Web/Authenticate/OpenId/Providers.hs b/Web/Authenticate/OpenId/Providers.hs index 5cce4c86..f0faa4ed 100644 --- a/Web/Authenticate/OpenId/Providers.hs +++ b/Web/Authenticate/OpenId/Providers.hs @@ -1,13 +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 - where + ( 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://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.cabal b/authenticate.cabal index d2a6be59..0693e80c 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.7.2 +version: 0.7.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From 5f68cf25e5f432091ab2cc40426bbc0111a99fc9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 11 Nov 2010 19:44:05 +0200 Subject: [PATCH 037/182] network 2.3 --- OpenId2/Normalization.hs | 3 +++ authenticate.cabal | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs index 9b71b300..2bcaf1c5 100644 --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -23,6 +23,9 @@ import Control.Monad import Data.List import Control.Failure (Failure (..)) import Network.URI + ( uriToString, normalizeCase, normalizeEscape + , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment + ) normalize :: Failure AuthenticateException m => String -> m Identifier normalize ident = diff --git a/authenticate.cabal b/authenticate.cabal index 0693e80c..4c7f7256 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.7.2.1 +version: 0.7.2.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -23,7 +23,7 @@ library transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10, utf8-string >= 0.3 && < 0.4, - network >= 2.2.1 && < 2.3, + network >= 2.2.1 && < 2.4, xml >= 1.3.7 && < 1.4 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, From 772afa022466823af1891f10333c77a7cf91202c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Dec 2010 23:34:35 +0200 Subject: [PATCH 038/182] tagsoup 0.12 --- authenticate.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/authenticate.cabal b/authenticate.cabal index 4c7f7256..0ad8d516 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.7.2.2 +version: 0.7.2.3 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -18,7 +18,7 @@ library data-object >= 0.3.1 && < 0.4, data-object-json >= 0.3.1 && < 0.4, http-enumerator >= 0.2.0 && < 0.3, - tagsoup >= 0.6 && < 0.12, + tagsoup >= 0.6 && < 0.13, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10, From a38000b2f3f3664e992f2fa53915bec83c28f690 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Dec 2010 08:10:32 +0200 Subject: [PATCH 039/182] Fixed myspace --- Web/Authenticate/OpenId/Providers.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Web/Authenticate/OpenId/Providers.hs b/Web/Authenticate/OpenId/Providers.hs index f0faa4ed..e5673162 100644 --- a/Web/Authenticate/OpenId/Providers.hs +++ b/Web/Authenticate/OpenId/Providers.hs @@ -23,7 +23,7 @@ livejournal :: String -> String livejournal u = concat ["http://", u, ".livejournal.com/"] myspace :: String -> String -myspace = (++) "http://myspace.com/" +myspace = (++) "http://www.myspace.com/" wordpress :: String -> String wordpress u = concat ["http://", u, ".wordpress.com/"] From 6615274cc854ff0f37e6d77578c9d52d1996cf9f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Dec 2010 11:26:54 +0200 Subject: [PATCH 040/182] getForwardUrlRealm and authenticateParams --- Web/Authenticate/OpenId.hs | 69 ++++++++++++++++++++++++++------------ authenticate.cabal | 2 +- 2 files changed, 49 insertions(+), 22 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index ab1244d0..12a0f852 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,7 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} module Web.Authenticate.OpenId ( getForwardUrl + , getForwardUrlRealm , authenticate + , authenticateParams , AuthenticateException (..) , Identifier (..) ) where @@ -12,7 +14,7 @@ import OpenId2.Discovery (discover, Discovery (..)) import Control.Failure (Failure (failure)) import OpenId2.Types import Web.Authenticate.Internal (qsUrl) -import Control.Monad (unless) +import Control.Monad (unless, liftM) import qualified Data.ByteString.UTF8 as BSU import qualified Data.ByteString.Lazy.UTF8 as BSLU import Network.HTTP.Enumerator @@ -30,32 +32,57 @@ getForwardUrl :: ( MonadIO m => String -- ^ The openid the user provided. -> String -- ^ The URL for this application\'s complete page. -> m String -- ^ URL to send the user to. -getForwardUrl openid' complete = do +getForwardUrl a b = getForwardUrlRealm a b Nothing [] + +getForwardUrlRealm + :: ( MonadIO m + , Failure AuthenticateException m + , Failure HttpException m + ) + => String -- ^ The openid the user provided. + -> String -- ^ The URL for this application\'s complete page. + -> Maybe String -- ^ Optional realm + -> [(String, String)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions. + -> m String -- ^ URL to send the user to. +getForwardUrlRealm openid' complete mrealm params = do + let realm = fromMaybe complete mrealm disc <- normalize openid' >>= discover case disc of Discovery1 server mdelegate -> return $ qsUrl server - [ ("openid.mode", "checkid_setup") - , ("openid.identity", fromMaybe openid' mdelegate) - , ("openid.return_to", complete) - , ("openid.trust_root", complete) - ] + $ ("openid.mode", "checkid_setup") + : ("openid.identity", fromMaybe openid' mdelegate) + : ("openid.return_to", complete) + : ("openid.realm", realm) + : ("openid.trust_root", complete) + : params Discovery2 (Provider p) (Identifier i) -> return $ qsUrl p - [ ("openid.ns", "http://specs.openid.net/auth/2.0") - , ("openid.mode", "checkid_setup") - , ("openid.claimed_id", i) - , ("openid.identity", i) - , ("openid.return_to", complete) - ] + $ ("openid.ns", "http://specs.openid.net/auth/2.0") + : ("openid.mode", "checkid_setup") + : ("openid.claimed_id", i) + : ("openid.identity", i) + : ("openid.return_to", complete) + : ("openid.realm", realm) + : params -authenticate :: ( MonadIO m - , Failure AuthenticateException m - , Failure HttpException m - ) - => [(String, String)] - -> m Identifier -authenticate params = do +authenticate + :: ( MonadIO m + , Failure AuthenticateException m + , Failure HttpException m + ) + => [(String, String)] + -> m Identifier +authenticate = liftM fst . authenticateParams + +authenticateParams + :: ( MonadIO m + , Failure AuthenticateException m + , Failure HttpException m + ) + => [(String, String)] + -> m (Identifier, [(String, String)]) +authenticateParams params = do unless (lookup "openid.mode" params == Just "id_res") $ failure $ AuthenticationException "mode is not id_res" ident <- case lookup "openid.identity" params of @@ -74,7 +101,7 @@ authenticate params = do rsp <- httpLbsRedirect req let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp case lookup "is_valid" rps of - Just "true" -> return $ Identifier ident + Just "true" -> return (Identifier ident, rps) _ -> failure $ AuthenticationException "OpenID provider did not validate" -- | Turn a response body into a list of parameters. diff --git a/authenticate.cabal b/authenticate.cabal index 0ad8d516..6e1f398f 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.7.2.3 +version: 0.7.3 license: BSD3 license-file: LICENSE author: Michael Snoyman From 800283dcc6a01439ffcc9f3f962f57cd84f2239b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Dec 2010 05:44:37 +0200 Subject: [PATCH 041/182] http-enumerator 0.3 --- OpenId2/Discovery.hs | 3 ++- authenticate.cabal | 7 ++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 6381441e..a9ed6e88 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -32,6 +32,7 @@ import Control.Arrow (first, (***)) import Control.Monad.IO.Class (MonadIO) import Control.Failure (Failure (failure)) import Control.Monad (mplus, liftM) +import Network.Wai (ciOriginal) data Discovery = Discovery1 String (Maybe String) | Discovery2 Provider Identifier @@ -72,7 +73,7 @@ discoverYADIS ident mb_loc redirects = do res <- httpLbs req let mloc = fmap S8.unpack $ lookup "x-xrds-location" - $ map (first $ map toLower . S8.unpack) + $ map (first $ map toLower . S8.unpack . ciOriginal) $ responseHeaders res let mloc' = if mloc == mb_loc then Nothing else mloc case statusCode res of diff --git a/authenticate.cabal b/authenticate.cabal index 6e1f398f..66a09147 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.7.3 +version: 0.8.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,14 +17,15 @@ library build-depends: base >= 4 && < 5, data-object >= 0.3.1 && < 0.4, data-object-json >= 0.3.1 && < 0.4, - http-enumerator >= 0.2.0 && < 0.3, + http-enumerator >= 0.3.0 && < 0.4, tagsoup >= 0.6 && < 0.13, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, bytestring >= 0.9 && < 0.10, utf8-string >= 0.3 && < 0.4, network >= 2.2.1 && < 2.4, - xml >= 1.3.7 && < 1.4 + xml >= 1.3.7 && < 1.4, + wai >= 0.3 && < 0.4 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.OpenId.Providers, From d7c19fb6aed623563ca331d85db7ea6353961401 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Dec 2010 05:46:45 +0200 Subject: [PATCH 042/182] Jeremy Shaw's error handling patch --- Web/Authenticate/OpenId.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 12a0f852..0bde99d4 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -84,7 +84,14 @@ authenticateParams -> m (Identifier, [(String, String)]) authenticateParams params = do unless (lookup "openid.mode" params == Just "id_res") - $ failure $ AuthenticationException "mode is not id_res" + $ failure $ 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 e + | otherwise -> AuthenticationException $ "mode is " ++ m ++ " but we were expecting id_res." ident <- case lookup "openid.identity" params of Just i -> return i Nothing -> From d32d16b693efd3c42f3ddf221a07851c45070e40 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Dec 2010 05:51:22 +0200 Subject: [PATCH 043/182] Remove Realm and Params function names in OpenId --- Web/Authenticate/OpenId.hs | 28 ++++------------------------ 1 file changed, 4 insertions(+), 24 deletions(-) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 0bde99d4..22663091 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,9 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} module Web.Authenticate.OpenId ( getForwardUrl - , getForwardUrlRealm , authenticate - , authenticateParams , AuthenticateException (..) , Identifier (..) ) where @@ -14,7 +12,7 @@ import OpenId2.Discovery (discover, Discovery (..)) import Control.Failure (Failure (failure)) import OpenId2.Types import Web.Authenticate.Internal (qsUrl) -import Control.Monad (unless, liftM) +import Control.Monad (unless) import qualified Data.ByteString.UTF8 as BSU import qualified Data.ByteString.Lazy.UTF8 as BSLU import Network.HTTP.Enumerator @@ -25,16 +23,7 @@ import Control.Arrow ((***)) import Data.List (unfoldr) import Data.Maybe (fromMaybe) -getForwardUrl :: ( MonadIO m - , Failure AuthenticateException m - , Failure HttpException m - ) - => String -- ^ The openid the user provided. - -> String -- ^ The URL for this application\'s complete page. - -> m String -- ^ URL to send the user to. -getForwardUrl a b = getForwardUrlRealm a b Nothing [] - -getForwardUrlRealm +getForwardUrl :: ( MonadIO m , Failure AuthenticateException m , Failure HttpException m @@ -44,7 +33,7 @@ getForwardUrlRealm -> Maybe String -- ^ Optional realm -> [(String, String)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions. -> m String -- ^ URL to send the user to. -getForwardUrlRealm openid' complete mrealm params = do +getForwardUrl openid' complete mrealm params = do let realm = fromMaybe complete mrealm disc <- normalize openid' >>= discover case disc of @@ -67,22 +56,13 @@ getForwardUrlRealm openid' complete mrealm params = do : params authenticate - :: ( MonadIO m - , Failure AuthenticateException m - , Failure HttpException m - ) - => [(String, String)] - -> m Identifier -authenticate = liftM fst . authenticateParams - -authenticateParams :: ( MonadIO m , Failure AuthenticateException m , Failure HttpException m ) => [(String, String)] -> m (Identifier, [(String, String)]) -authenticateParams params = do +authenticate params = do unless (lookup "openid.mode" params == Just "id_res") $ failure $ case lookup "openid.mode" params of Nothing -> AuthenticationException "openid.mode was not found in the params." From 39611958d0d975cbdb1d60a3b05cdedd19a0c248 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 7 Feb 2011 06:56:53 +0200 Subject: [PATCH 044/182] Proper support for OP identifiers in Yadis --- OpenId2/Discovery.hs | 24 +++++++++++++----------- OpenId2/Types.hs | 4 ++++ Web/Authenticate/OpenId.hs | 12 ++++++++---- authenticate.cabal | 2 +- 4 files changed, 26 insertions(+), 16 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index a9ed6e88..dde4d019 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -35,7 +35,7 @@ import Control.Monad (mplus, liftM) import Network.Wai (ciOriginal) data Discovery = Discovery1 String (Maybe String) - | Discovery2 Provider Identifier + | Discovery2 Provider Identifier IdentType deriving Show -- | Attempt to resolve an OpenID endpoint, and user identifier. @@ -48,7 +48,7 @@ discover :: ( MonadIO m discover ident@(Identifier i) = do res1 <- discoverYADIS ident Nothing 10 case res1 of - Just (x, y) -> return $ Discovery2 x y + Just (x, y, z) -> return $ Discovery2 x y z Nothing -> do res2 <- discoverHTML ident case res2 of @@ -65,7 +65,7 @@ discoverYADIS :: ( MonadIO m => Identifier -> Maybe String -> Int -- ^ remaining redirects - -> m (Maybe (Provider,Identifier)) + -> m (Maybe (Provider, Identifier, IdentType)) discoverYADIS _ _ 0 = failure TooManyRedirects discoverYADIS ident mb_loc redirects = do let uri = fromMaybe (identifier ident) mb_loc @@ -90,7 +90,7 @@ discoverYADIS ident mb_loc redirects = do -- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml -- document. -parseYADIS :: Identifier -> XRDS -> Maybe (Provider,Identifier) +parseYADIS :: Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType) parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat where isOpenId svc = do @@ -98,15 +98,15 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc f (x,y) | x `elem` tys = Just y | otherwise = Nothing - lid <- listToMaybe $ mapMaybe f - [ ("http://specs.openid.net/auth/2.0/server", ident) + (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) - , ("http://openid.net/signon/1.0" , localId) - , ("http://openid.net/signon/1.1" , localId) + , ("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) + return (Provider uri, lid, itype) -- HTML-Based Discovery -------------------------------------------------------- @@ -136,7 +136,9 @@ parseHTML ident = resolve resolve2 ls = do prov <- lookup "openid2.provider" ls let lid = maybe ident Identifier $ lookup "openid2.local_id" ls - return $ Discovery2 (Provider prov) lid + -- 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 diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index 66afab4b..ac157344 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -13,6 +13,7 @@ module OpenId2.Types ( Provider (..) , Identifier (..) + , IdentType (..) , AuthenticateException (..) ) where @@ -27,3 +28,6 @@ newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) -- | A valid OpenID identifier. newtype Identifier = Identifier { identifier :: String } deriving (Eq, Ord, Show, Read, Data, Typeable) + +data IdentType = OPIdent | ClaimedIdent + deriving (Eq, Ord, Show, Read, Data, Typeable) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 22663091..73df129c 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -45,12 +45,16 @@ getForwardUrl openid' complete mrealm params = do : ("openid.realm", realm) : ("openid.trust_root", complete) : params - Discovery2 (Provider p) (Identifier i) -> + Discovery2 (Provider p) (Identifier i) itype -> do + let i' = + case itype of + ClaimedIdent -> i + OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select" return $ qsUrl p $ ("openid.ns", "http://specs.openid.net/auth/2.0") : ("openid.mode", "checkid_setup") - : ("openid.claimed_id", i) - : ("openid.identity", i) + : ("openid.claimed_id", i') + : ("openid.identity", i') : ("openid.return_to", complete) : ("openid.realm", realm) : params @@ -79,7 +83,7 @@ authenticate params = do disc <- normalize ident >>= discover let endpoint = case disc of Discovery1 p _ -> p - Discovery2 (Provider p) _ -> p + Discovery2 (Provider p) _ _ -> p let params' = map (BSU.fromString *** BSU.fromString) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params diff --git a/authenticate.cabal b/authenticate.cabal index 66a09147..111779b9 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.8.0 +version: 0.8.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From db6f72995df026638b922e4823c216c0cb51d5ac Mon Sep 17 00:00:00 2001 From: Hiromi Ishii Date: Mon, 7 Mar 2011 16:57:10 +0900 Subject: [PATCH 045/182] Added OAuth Client Support --- Web/Authenticate/OAuth.hs | 222 ++++++++++++++++++++++++++++++++++++++ authenticate.cabal | 11 +- 2 files changed, 231 insertions(+), 2 deletions(-) create mode 100644 Web/Authenticate/OAuth.hs diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs new file mode 100644 index 00000000..eed98ecb --- /dev/null +++ b/Web/Authenticate/OAuth.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Web.Authenticate.OAuth + ( -- | Data types + OAuth(..), SignMethod(..), Credential(..), + -- | Operations for credentials + emptyCredential, insert, delete, inserts, + -- | Signature + signOAuth, + -- | Url & operation for authentication + authorizeUrl, getAccessToken, getTemporaryCredential, + -- | Utility Methods + paramEncode + ) where +import Network.HTTP.Enumerator +import Web.Authenticate.Internal (qsUrl) +import Data.Data +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Maybe +import Control.Applicative +import Network.Wai.Parse +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 +import Network.Wai (ResponseHeader) +import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..)) + + +-- | Data type for OAuth client (consumer). +data OAuth = OAuth { oauthServerName :: String -- ^ Service name + , oauthRequestUri :: String -- ^ URI to request temporary credential + , oauthAccessTokenUri :: String -- ^ Uri to obtain access token + , oauthAuthorizeUri :: String -- ^ Uri to authorize + , oauthSignatureMethod :: SignMethod -- ^ Signature Method + , oauthConsumerKey :: BS.ByteString -- ^ Consumer key + , oauthConsumerSecret :: BS.ByteString -- ^ Consumer Secret + , oauthCallback :: Maybe BS.ByteString -- ^ Callback uri to redirect after authentication + } deriving (Show, Eq, Ord, Read, Data, Typeable) + + +-- | Data type for signature method. +data SignMethod = PLAINTEXT + | HMACSHA1 + | RSASHA1 PrivateKey + deriving (Show, Eq, Ord, Read, Data, Typeable) + +deriving instance Typeable PrivateKey +deriving instance Data PrivateKey +deriving instance Read PrivateKey +deriving instance Ord PrivateKey +deriving instance Eq PrivateKey + +-- | 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 [] + +token, tokenSecret :: Credential -> BS.ByteString +token = fromMaybe "" . lookup "oauth_token" . unCredential +tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential + +data OAuthException = ProtocolException 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 :: OAuth -- ^ OAuth Application + -> IO Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredential oa = do + let req = fromJust $ parseUrl (oauthRequestUri oa) + req' <- signOAuth oa emptyCredential (req { method = "POST" }) + rsp <- httpLbs req' + let dic = parseQueryString . toStrict . responseBody $ rsp + return $ Credential dic + +-- | URL to obtain OAuth verifier. +authorizeUrl :: OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential (Request Token & Secret) + -> String -- ^ URL to authorize +authorizeUrl oa cr = qsUrl (oauthAuthorizeUri oa) [("oauth_token", BS.unpack $ token cr)] + +-- | Get Access token. +getAccessToken :: OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> IO Credential -- ^ Token Credential (Access Token & Secret) +getAccessToken oa cr = do + let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } + rsp <- signOAuth oa cr req >>= httpLbs + let dic = parseQueryString . toStrict . responseBody $ rsp + return $ Credential dic + +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 + +-- | Add OAuth headers & sign to 'Request'. +signOAuth :: OAuth -- ^ OAuth Application + -> Credential -- ^ Credential + -> Request -- ^ Original Request + -> IO Request -- ^ Signed OAuth Request +signOAuth oa crd req = do + crd' <- addTimeStamp =<< addNonce crd + let tok = injectOAuthToCred oa crd' + sign = genSign oa tok req + return $ addAuthHeader (insert "oauth_signature" sign tok) req + +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 :: Credential -> IO Credential +addNonce cred = do + nonce <- replicateM 10 (randomRIO ('a','z')) + return $ insert "oauth_nonce" (BS.pack nonce) cred + +addTimeStamp :: Credential -> IO Credential +addTimeStamp cred = do + stamp <- floor . (`diffUTCTime` baseTime) <$> getCurrentTime :: IO Integer + return $ insert "oauth_timestamp" (BS.pack $ show stamp) cred + +injectOAuthToCred :: OAuth -> Credential -> Credential +injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa) $ + inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa) + , ("oauth_consumer_key", oauthConsumerKey oa) + ] cred + +genSign :: OAuth -> Credential -> Request -> BS.ByteString +genSign oa tok req = + case oauthSignatureMethod oa of + HMACSHA1 -> + let text = getBaseString tok req + key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] + in encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text + PLAINTEXT -> + BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] + RSASHA1 pr -> + encode $ toStrict $ rsassa_pkcs1_v1_5_sign ha_SHA1 pr (getBaseString tok req) + +addAuthHeader :: Credential -> Request -> Request +addAuthHeader (Credential cred) req = + req { requestHeaders = insertMap "Authorization" (renderAuthHeader cred) $ requestHeaders req } + +renderAuthHeader :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString +renderAuthHeader = ("OAuth " `BS.append`). BS.intercalate "," . map (\(a,b) -> BS.concat [paramEncode a, "=\"", paramEncode b, "\""]) . filter ((`notElem` ["oauth_token_secret", "oauth_consumer_secret"]) . fst) + +-- | Encode a string using the percent encoding method for OAuth. +paramEncode :: BS.ByteString -> BS.ByteString +paramEncode = BS.concatMap escape + where + escape 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 + +getBaseString :: Credential -> Request -> BSL.ByteString +getBaseString tok req = + 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 = queryString req + bsBodyQ = if isBodyFormEncoded $ requestHeaders req + then parseQueryString (toStrict $ requestBody req) else [] + bsAuthParams = filter ((`notElem`["oauth_signature","realm","oauth_version", "oauth_token_secret"]).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 + in BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] + +isBodyFormEncoded :: [(ResponseHeader, BS.ByteString)] -> 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 diff --git a/authenticate.cabal b/authenticate.cabal index 111779b9..1dfb5e0a 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.8.0.1 +version: 0.8.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -25,10 +25,17 @@ library utf8-string >= 0.3 && < 0.4, network >= 2.2.1 && < 2.4, xml >= 1.3.7 && < 1.4, - wai >= 0.3 && < 0.4 + wai >= 0.3 && < 0.4, + RSA >= 1.0 && < 1.1, + time >= 1.1 && < 1.2, + base64-bytestring >= 0.1 && < 0.2, + SHA >= 1.4 && < 1.5, + random >= 1.0 && < 1.1, + wai-extra >= 0.3 && < 0.4 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.OpenId.Providers, + Web.Authenticate.OAuth, Web.Authenticate.Facebook other-modules: Web.Authenticate.Internal, OpenId2.Discovery, From 4d87d3b2c6138dc72eecfc95ce21ec9b54d42ff3 Mon Sep 17 00:00:00 2001 From: Hiromi Ishii Date: Mon, 7 Mar 2011 17:04:21 +0900 Subject: [PATCH 046/182] Fixed Haddock notation in OAuth --- Web/Authenticate/OAuth.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index eed98ecb..20f6dc61 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -1,15 +1,15 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Web.Authenticate.OAuth - ( -- | Data types + ( -- * Data types OAuth(..), SignMethod(..), Credential(..), - -- | Operations for credentials + -- * Operations for credentials emptyCredential, insert, delete, inserts, - -- | Signature + -- * Signature signOAuth, - -- | Url & operation for authentication + -- * Url & operation for authentication authorizeUrl, getAccessToken, getTemporaryCredential, - -- | Utility Methods + -- * Utility Methods paramEncode ) where import Network.HTTP.Enumerator From 0b09a4f66bc1dde647bab68ccdf92603a6432cf9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 9 Mar 2011 17:53:59 +0200 Subject: [PATCH 047/182] Added getTokenCredential = getAccessToken --- Web/Authenticate/OAuth.hs | 8 ++++++-- authenticate.cabal | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index 20f6dc61..4e7b71eb 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -8,7 +8,8 @@ module Web.Authenticate.OAuth -- * Signature signOAuth, -- * Url & operation for authentication - authorizeUrl, getAccessToken, getTemporaryCredential, + authorizeUrl, getAccessToken, getTemporaryCredential, + getTokenCredential, -- * Utility Methods paramEncode ) where @@ -97,7 +98,8 @@ authorizeUrl :: OAuth -- ^ OAuth Application authorizeUrl oa cr = qsUrl (oauthAuthorizeUri oa) [("oauth_token", BS.unpack $ token cr)] -- | Get Access token. -getAccessToken :: OAuth -- ^ OAuth Application +getAccessToken, getTokenCredential + :: OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential with oauth_verifier -> IO Credential -- ^ Token Credential (Access Token & Secret) getAccessToken oa cr = do @@ -106,6 +108,8 @@ getAccessToken oa cr = do let dic = parseQueryString . toStrict . responseBody $ rsp return $ Credential dic +getTokenCredential = getAccessToken + insertMap :: Eq a => a -> b -> [(a,b)] -> [(a,b)] insertMap key val = ((key,val):) . filter ((/=key).fst) diff --git a/authenticate.cabal b/authenticate.cabal index 1dfb5e0a..bb3cd6b5 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.8.1 +version: 0.8.2 license: BSD3 license-file: LICENSE author: Michael Snoyman From fad6d1bd3c16ea903476f4b3008a2172eca89105 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Wed, 9 Mar 2011 11:24:59 -0800 Subject: [PATCH 048/182] allow time-1.2 --- authenticate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index bb3cd6b5..1c6cc225 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -27,7 +27,7 @@ library xml >= 1.3.7 && < 1.4, wai >= 0.3 && < 0.4, RSA >= 1.0 && < 1.1, - time >= 1.1 && < 1.2, + time >= 1.1 && < 1.3, base64-bytestring >= 0.1 && < 0.2, SHA >= 1.4 && < 1.5, random >= 1.0 && < 1.1, From eac9ea6e41dce824740a992be6229629326e7519 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 9 Mar 2011 21:32:09 +0200 Subject: [PATCH 049/182] Version bump --- authenticate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index 1c6cc225..41433be7 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.8.2 +version: 0.8.2.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From ae8e028117723f0978973c1b9a89da7c7bda1876 Mon Sep 17 00:00:00 2001 From: Hiromi Ishii Date: Thu, 10 Mar 2011 15:23:49 +0900 Subject: [PATCH 050/182] Changed to specify oauth_version parameter everytime (measure for Twitter's Streaming API) --- Web/Authenticate/OAuth.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index 4e7b71eb..a43e7586 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -168,6 +168,7 @@ injectOAuthToCred :: OAuth -> Credential -> Credential injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa) $ inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa) , ("oauth_consumer_key", oauthConsumerKey oa) + , ("oauth_version", "1.0") ] cred genSign :: OAuth -> Credential -> Request -> BS.ByteString @@ -209,7 +210,7 @@ getBaseString tok req = bsQuery = queryString req bsBodyQ = if isBodyFormEncoded $ requestHeaders req then parseQueryString (toStrict $ requestBody req) else [] - bsAuthParams = filter ((`notElem`["oauth_signature","realm","oauth_version", "oauth_token_secret"]).fst) $ unCredential tok + bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).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 From 5ca48e8524a53a62264df9e3f01f89ac6e24e98f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 10 Mar 2011 10:06:55 +0200 Subject: [PATCH 051/182] Version bump --- authenticate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index 41433be7..8d6fc2a9 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.8.2.1 +version: 0.8.2.2 license: BSD3 license-file: LICENSE author: Michael Snoyman From fb9ec3c4126cba197d3541d92dececaeb58aada2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 28 Mar 2011 06:41:09 +0200 Subject: [PATCH 052/182] Migrate to aeson --- Web/Authenticate/Facebook.hs | 18 ++++++++----- Web/Authenticate/Rpxnow.hs | 50 ++++++++++++++++++++++-------------- authenticate.cabal | 9 ++++--- 3 files changed, 48 insertions(+), 29 deletions(-) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 3571401d..b0945ff6 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -4,14 +4,13 @@ module Web.Authenticate.Facebook where import Network.HTTP.Enumerator import Data.List (intercalate) -import Data.Object -import Data.Object.Json +import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as S import Web.Authenticate.Internal (qsEncode) import Data.Data (Data) import Data.Typeable (Typeable) +import Control.Exception (Exception, throwIO) +import Data.Attoparsec.Lazy (parse, eitherResult) data Facebook = Facebook { facebookClientId :: String @@ -63,8 +62,15 @@ graphUrl (AccessToken s) func = concat , s ] -getGraphData :: AccessToken -> String -> IO StringObject +getGraphData :: AccessToken -> String -> IO (Either String Value) getGraphData at func = do let url = graphUrl at func b <- simpleHttp url - decode $ S.concat $ L.toChunks b + return $ eitherResult $ parse json b + +getGraphData' :: AccessToken -> String -> IO Value +getGraphData' a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return + +data InvalidJsonException = InvalidJsonException String + deriving (Show, Typeable) +instance Exception InvalidJsonException diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index c60f235a..7ce7e018 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -22,8 +22,7 @@ module Web.Authenticate.Rpxnow , AuthenticateException (..) ) where -import Data.Object -import Data.Object.Json +import Data.Aeson import Network.HTTP.Enumerator import "transformers" Control.Monad.IO.Class import Control.Failure @@ -35,20 +34,22 @@ import Control.Exception (throwIO) 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 -- | Information received from Rpxnow after a valid login. data Identifier = Identifier - { identifier :: String - , extraData :: [(String, String)] + { identifier :: Text + , extraData :: [(Text, Text)] } deriving (Eq, Ord, Read, Show, Data, Typeable) -- | Attempt to log a user in. authenticate :: (MonadIO m, Failure HttpException m, - Failure AuthenticateException m, - Failure ObjectExtractError m, - Failure JsonDecodeError m) + Failure AuthenticateException m) => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client. -> m Identifier @@ -76,21 +77,32 @@ authenticate apiKey token = do let b = responseBody res unless (200 <= statusCode res && statusCode res < 300) $ liftIO $ throwIO $ StatusCodeException (statusCode res) b - o <- decode $ S.concat $ L.toChunks b - m <- fromMapping o - stat <- lookupScalar "stat" m - unless (stat == "ok") $ failure $ RpxnowException $ - "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b - parseProfile m + 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 -> failure $ RpxnowException $ + "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b + _ -> failure $ RpxnowException "Now stat value found on Rpxnow response" + case Data.Aeson.Types.parse parseProfile o of + Success x -> return x + Error e -> failure $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e -parseProfile :: (Monad m, Failure ObjectExtractError m) - => [(String, StringObject)] -> m Identifier -parseProfile m = do - profile <- lookupMapping "profile" m - ident <- lookupScalar "identifier" profile +unResult :: Failure AuthenticateException m => AT.Result a -> m a +unResult = either (failure . RpxnowException) return . AT.eitherResult + +parseProfile :: Value -> Data.Aeson.Types.Parser Identifier +parseProfile (Object m) = do + profile <- m .: "profile" + ident <- m .: "identifier" let profile' = mapMaybe go profile return $ Identifier ident profile' where go ("identifier", _) = Nothing - go (k, Scalar v) = Just (k, v) + go (k, String v) = Just (k, v) go _ = Nothing +parseProfile _ = mzero diff --git a/authenticate.cabal b/authenticate.cabal index 8d6fc2a9..7bfe432c 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.8.2.2 +version: 0.9.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -15,8 +15,7 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, - data-object >= 0.3.1 && < 0.4, - data-object-json >= 0.3.1 && < 0.4, + aeson >= 0.3.1.1 && < 0.4, http-enumerator >= 0.3.0 && < 0.4, tagsoup >= 0.6 && < 0.13, failure >= 0.0.0 && < 0.2, @@ -31,7 +30,9 @@ library base64-bytestring >= 0.1 && < 0.2, SHA >= 1.4 && < 1.5, random >= 1.0 && < 1.1, - wai-extra >= 0.3 && < 0.4 + wai-extra >= 0.3 && < 0.4, + text >= 0.5 && < 1.0, + attoparsec >= 0.8.5 && < 0.9 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.OpenId.Providers, From 572df52d034a3d46de99a7e2419c04ff4846b660 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 28 Mar 2011 07:22:53 +0200 Subject: [PATCH 053/182] http-enumerator 0.5 --- OpenId2/Discovery.hs | 12 +++--- Web/Authenticate/Facebook.hs | 5 ++- Web/Authenticate/OAuth.hs | 76 ++++++++++++++++++++++++------------ Web/Authenticate/OpenId.hs | 7 ++-- Web/Authenticate/Rpxnow.hs | 5 ++- authenticate.cabal | 7 +++- 6 files changed, 72 insertions(+), 40 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index dde4d019..298ea885 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -29,10 +29,10 @@ import Network.HTTP.Enumerator import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Char8 as S8 import Control.Arrow (first, (***)) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Failure (Failure (failure)) import Control.Monad (mplus, liftM) -import Network.Wai (ciOriginal) +import qualified Data.CaseInsensitive as CI data Discovery = Discovery1 String (Maybe String) | Discovery2 Provider Identifier IdentType @@ -69,11 +69,11 @@ discoverYADIS :: ( MonadIO m discoverYADIS _ _ 0 = failure TooManyRedirects discoverYADIS ident mb_loc redirects = do let uri = fromMaybe (identifier ident) mb_loc - req <- parseUrl uri - res <- httpLbs req + req <- parseUrl $ S8.pack uri + res <- liftIO $ withManager $ httpLbs req let mloc = fmap S8.unpack $ lookup "x-xrds-location" - $ map (first $ map toLower . S8.unpack . ciOriginal) + $ map (first $ map toLower . S8.unpack . CI.original) $ responseHeaders res let mloc' = if mloc == mb_loc then Nothing else mloc case statusCode res of @@ -117,7 +117,7 @@ discoverHTML :: ( MonadIO m, Failure HttpException m) => Identifier -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) = - (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident + (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (S8.pack ident) -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index b0945ff6..73cc67c1 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -11,6 +11,7 @@ import Data.Data (Data) import Data.Typeable (Typeable) import Control.Exception (Exception, throwIO) import Data.Attoparsec.Lazy (parse, eitherResult) +import qualified Data.ByteString.Char8 as S8 data Facebook = Facebook { facebookClientId :: String @@ -48,7 +49,7 @@ accessTokenUrl fb code = concat getAccessToken :: Facebook -> String -> IO AccessToken getAccessToken fb code = do let url = accessTokenUrl fb code - b <- simpleHttp url + b <- simpleHttp $ S8.pack url let (front, back) = splitAt 13 $ L8.unpack b case front of "access_token=" -> return $ AccessToken back @@ -65,7 +66,7 @@ graphUrl (AccessToken s) func = concat getGraphData :: AccessToken -> String -> IO (Either String Value) getGraphData at func = do let url = graphUrl at func - b <- simpleHttp url + b <- simpleHttp $ S8.pack url return $ eitherResult $ parse json b getGraphData' :: AccessToken -> String -> IO Value diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index a43e7586..d58ff2bc 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -30,9 +30,15 @@ import Data.Digest.Pure.SHA import Data.ByteString.Base64 import Data.Time import Numeric -import Network.Wai (ResponseHeader) import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..)) - +import Network.HTTP.Types (Header) +import Control.Arrow (second) +import qualified Data.ByteString.Char8 as S8 +import Blaze.ByteString.Builder (toByteString) +import Data.Enumerator (($$), run_, Stream (..), continue) +import Data.Monoid (mconcat) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.IORef (newIORef, readIORef, atomicModifyIORef) -- | Data type for OAuth client (consumer). data OAuth = OAuth { oauthServerName :: String -- ^ Service name @@ -85,9 +91,9 @@ fromStrict = BSL.fromChunks . return getTemporaryCredential :: OAuth -- ^ OAuth Application -> IO Credential -- ^ Temporary Credential (Request Token & Secret). getTemporaryCredential oa = do - let req = fromJust $ parseUrl (oauthRequestUri oa) + let req = fromJust $ parseUrl $ S8.pack $ oauthRequestUri oa req' <- signOAuth oa emptyCredential (req { method = "POST" }) - rsp <- httpLbs req' + rsp <- withManager $ httpLbs req' let dic = parseQueryString . toStrict . responseBody $ rsp return $ Credential dic @@ -103,8 +109,8 @@ getAccessToken, getTokenCredential -> Credential -- ^ Temporary Credential with oauth_verifier -> IO Credential -- ^ Token Credential (Access Token & Secret) getAccessToken oa cr = do - let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } - rsp <- signOAuth oa cr req >>= httpLbs + let req = (fromJust $ parseUrl $ S8.pack $ oauthAccessTokenUri oa) { method = "POST" } + rsp <- signOAuth oa cr req >>= withManager . httpLbs let dic = parseQueryString . toStrict . responseBody $ rsp return $ Credential dic @@ -136,12 +142,12 @@ delete key = Credential . deleteMap key . unCredential -- | Add OAuth headers & sign to 'Request'. signOAuth :: OAuth -- ^ OAuth Application -> Credential -- ^ Credential - -> Request -- ^ Original Request - -> IO Request -- ^ Signed OAuth Request + -> Request IO -- ^ Original Request + -> IO (Request IO) -- ^ Signed OAuth Request signOAuth oa crd req = do crd' <- addTimeStamp =<< addNonce crd let tok = injectOAuthToCred oa crd' - sign = genSign oa tok req + sign <- genSign oa tok req return $ addAuthHeader (insert "oauth_signature" sign tok) req baseTime :: UTCTime @@ -171,19 +177,19 @@ injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa , ("oauth_version", "1.0") ] cred -genSign :: OAuth -> Credential -> Request -> BS.ByteString +genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString genSign oa tok req = case oauthSignatureMethod oa of - HMACSHA1 -> - let text = getBaseString tok req - key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] - in encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text + 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 -> - BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] + return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] RSASHA1 pr -> - encode $ toStrict $ rsassa_pkcs1_v1_5_sign ha_SHA1 pr (getBaseString tok req) + liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req) -addAuthHeader :: Credential -> Request -> Request +addAuthHeader :: Credential -> Request a -> Request a addAuthHeader (Credential cred) req = req { requestHeaders = insertMap "Authorization" (renderAuthHeader cred) $ requestHeaders req } @@ -199,24 +205,44 @@ paramEncode = BS.concatMap escape oct = '%' : replicate (2 - length num) '0' ++ num in BS.pack oct -getBaseString :: Credential -> Request -> BSL.ByteString -getBaseString tok req = +getBaseString :: MonadIO m => Credential -> Request m -> m BSL.ByteString +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 = queryString req - bsBodyQ = if isBodyFormEncoded $ requestHeaders req - then parseQueryString (toStrict $ requestBody req) else [] - bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).fst) $ unCredential tok + bsQuery = map (second $ fromMaybe "") $ queryString req + bsBodyQ <- if isBodyFormEncoded $ requestHeaders req + then liftM parseQueryString $ toLBS (requestBody req) + else return [] + let bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).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 - in BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] + -- FIXME it would be much better to use http-types functions here + return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] -isBodyFormEncoded :: [(ResponseHeader, BS.ByteString)] -> Bool +toLBS :: MonadIO m => RequestBody m -> m BS.ByteString +toLBS (RequestBodyLBS l) = return $ toStrict l +toLBS (RequestBodyBS s) = return s +toLBS (RequestBodyBuilder _ b) = return $ toByteString b +toLBS (RequestBodyEnum _ enum) = do + i <- liftIO $ newIORef id + run_ $ enum $$ go i + liftIO $ liftM (toByteString . mconcat . ($ [])) $ readIORef i + where + go i = + continue go' + where + go' (Chunks []) = continue go' + go' (Chunks x) = do + liftIO (atomicModifyIORef i $ \y -> (y . (x ++), ())) + continue go' + go' EOF = return () + +isBodyFormEncoded :: [Header] -> Bool isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type" compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 73df129c..bb5cc508 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -14,10 +14,11 @@ import OpenId2.Types import Web.Authenticate.Internal (qsUrl) import Control.Monad (unless) import qualified Data.ByteString.UTF8 as BSU +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.UTF8 as BSLU import Network.HTTP.Enumerator ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect - , HttpException + , HttpException, withManager ) import Control.Arrow ((***)) import Data.List (unfoldr) @@ -87,9 +88,9 @@ authenticate params = do let params' = map (BSU.fromString *** BSU.fromString) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params - req' <- parseUrl endpoint + req' <- parseUrl $ S8.pack endpoint let req = urlEncodedBody params' req' - rsp <- httpLbsRedirect req + rsp <- liftIO $ withManager $ httpLbsRedirect req let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp case lookup "is_valid" rps of Just "true" -> return (Identifier ident, rps) diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index 7ce7e018..23defbe5 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -71,9 +71,10 @@ authenticate apiKey token = do , requestHeaders = [ ("Content-Type", "application/x-www-form-urlencoded") ] - , requestBody = body + , requestBody = RequestBodyLBS body + , checkCerts = const $ return True } - res <- httpLbsRedirect req + res <- liftIO $ withManager $ httpLbsRedirect req let b = responseBody res unless (200 <= statusCode res && statusCode res < 300) $ liftIO $ throwIO $ StatusCodeException (statusCode res) b diff --git a/authenticate.cabal b/authenticate.cabal index 7bfe432c..05455d66 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -16,7 +16,7 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, aeson >= 0.3.1.1 && < 0.4, - http-enumerator >= 0.3.0 && < 0.4, + http-enumerator >= 0.5.1 && < 0.6, tagsoup >= 0.6 && < 0.13, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, @@ -24,7 +24,7 @@ library utf8-string >= 0.3 && < 0.4, network >= 2.2.1 && < 2.4, xml >= 1.3.7 && < 1.4, - wai >= 0.3 && < 0.4, + case-insensitive >= 0.2 && < 0.3, RSA >= 1.0 && < 1.1, time >= 1.1 && < 1.3, base64-bytestring >= 0.1 && < 0.2, @@ -32,6 +32,9 @@ library random >= 1.0 && < 1.1, wai-extra >= 0.3 && < 0.4, text >= 0.5 && < 1.0, + http-types >= 0.6 && < 0.7, + enumerator >= 0.4.7 && < 0.5, + blaze-builder >= 0.2 && < 0.4, attoparsec >= 0.8.5 && < 0.9 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, From bd9ea53ea8396cb2c849902c5e9b19e9d459f85c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 1 Apr 2011 11:20:48 +0300 Subject: [PATCH 054/182] Move Facebook to Text --- Web/Authenticate/Facebook.hs | 92 +++++++++++++++++++++--------------- facebook.hs | 59 ++++++++++++----------- 2 files changed, 85 insertions(+), 66 deletions(-) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 73cc67c1..2c162f32 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -1,6 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} -module Web.Authenticate.Facebook where +{-# LANGUAGE OverloadedStrings #-} +module Web.Authenticate.Facebook + ( Facebook (..) + , getForwardUrl + , getAccessToken + , getGraphData + ) where import Network.HTTP.Enumerator import Data.List (intercalate) @@ -12,64 +18,72 @@ import Data.Typeable (Typeable) import Control.Exception (Exception, throwIO) import Data.Attoparsec.Lazy (parse, eitherResult) import qualified Data.ByteString.Char8 as S8 +import Data.Text (Text, pack) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Blaze.ByteString.Builder (toByteString, copyByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromText) +import Network.HTTP.Types (renderQueryText) +import Data.Monoid (mappend) +import Data.ByteString (ByteString) data Facebook = Facebook - { facebookClientId :: String - , facebookClientSecret :: String - , facebookRedirectUri :: String + { facebookClientId :: Text + , facebookClientSecret :: Text + , facebookRedirectUri :: Text } deriving (Show, Eq, Read, Ord, Data, Typeable) -newtype AccessToken = AccessToken { unAccessToken :: String } +newtype AccessToken = AccessToken { unAccessToken :: Text } deriving (Show, Eq, Read, Ord, Data, Typeable) -getForwardUrl :: Facebook -> [String] -> String -getForwardUrl fb perms = concat - [ "https://graph.facebook.com/oauth/authorize?client_id=" - , qsEncode $ facebookClientId fb - , "&redirect_uri=" - , qsEncode $ facebookRedirectUri fb - , if null perms - then "" - else "&scope=" ++ qsEncode (intercalate "," perms) - ] +getForwardUrl :: Facebook -> [Text] -> Text +getForwardUrl fb perms = + TE.decodeUtf8 $ toByteString $ + copyByteString "https://graph.facebook.com/oauth/authorize" + `mappend` + renderQueryText True + ( ("client_id", Just $ facebookClientId fb) + : ("redirect_uri", Just $ facebookRedirectUri fb) + : if null perms + then [] + else [("scope", Just $ T.intercalate "," perms)]) -accessTokenUrl :: Facebook -> String -> String -accessTokenUrl fb code = concat - [ "https://graph.facebook.com/oauth/access_token?client_id=" - , qsEncode $ facebookClientId fb - , "&redirect_uri=" - , qsEncode $ facebookRedirectUri fb - , "&client_secret=" - , qsEncode $ facebookClientSecret fb - , "&code=" - , qsEncode code - ] -getAccessToken :: Facebook -> String -> IO AccessToken +accessTokenUrl :: Facebook -> Text -> ByteString +accessTokenUrl fb code = + toByteString $ + copyByteString "https://graph.facebook.com/oauth/access_token" + `mappend` + renderQueryText True + [ ("client_id", Just $ facebookClientId fb) + , ("redirect_uri", Just $ facebookRedirectUri fb) + , ("code", Just code) + ] + +getAccessToken :: Facebook -> Text -> IO AccessToken getAccessToken fb code = do let url = accessTokenUrl fb code - b <- simpleHttp $ S8.pack url + b <- simpleHttp url let (front, back) = splitAt 13 $ L8.unpack b case front of - "access_token=" -> return $ AccessToken back + "access_token=" -> return $ AccessToken $ T.pack back _ -> error $ "Invalid facebook response: " ++ back -graphUrl :: AccessToken -> String -> String -graphUrl (AccessToken s) func = concat - [ "https://graph.facebook.com/" - , func - , "?access_token=" - , s - ] +graphUrl :: AccessToken -> Text -> ByteString +graphUrl (AccessToken s) func = + toByteString $ + copyByteString "https://graph.facebook.com/" + `mappend` fromText func + `mappend` renderQueryText True [("access_token", Just s)] -getGraphData :: AccessToken -> String -> IO (Either String Value) +getGraphData :: AccessToken -> Text -> IO (Either String Value) getGraphData at func = do let url = graphUrl at func - b <- simpleHttp $ S8.pack url + b <- simpleHttp url return $ eitherResult $ parse json b -getGraphData' :: AccessToken -> String -> IO Value +getGraphData' :: AccessToken -> Text -> IO Value getGraphData' a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return data InvalidJsonException = InvalidJsonException String diff --git a/facebook.hs b/facebook.hs index b88459ca..e86e5936 100644 --- a/facebook.hs +++ b/facebook.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE TypeFamilies, QuasiQuotes #-} +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} import Yesod import Web.Authenticate.Facebook -import Data.Object import Data.Maybe (fromMaybe) import Network.HTTP.Enumerator +import Data.Text (pack) +import qualified Data.Aeson as A +import qualified Data.Vector as V +import qualified Data.Map as M +import Data.Text.Encoding (encodeUtf8) data FB = FB Facebook fb :: FB fb = FB $ Facebook "134280699924829" "a7685e10c8977f5435e599aaf1d232eb" - "http://localhost:3000/facebook/" + "http://localhost:3000/facebook" mkYesod "FB" [$parseRoutes| / RootR GET /facebook FacebookR GET @@ -18,40 +22,41 @@ instance Yesod FB where approot _ = "http://localhost:3000" getRootR = do FB f <- getYesod - redirectString RedirectTemporary $ getForwardUrl f ["email"] + let s = encodeUtf8 $ getForwardUrl f ["email"] + redirectString RedirectTemporary s return () getFacebookR = do FB f <- getYesod code <- runFormGet' $ stringInput "code" - at <- liftIO $ getAccessToken f code + at <- liftIO $ getAccessToken f $ pack code mreq <- runFormGet' $ maybeStringInput "req" let req = fromMaybe "me" mreq - so <- liftIO $ getGraphData at req + Right so <- liftIO $ getGraphData at $ pack req let so' = objToHamlet so - hamletToRepHtml [$hamlet| -%form - %input!type=hidden!name=code!value=$string.code$ - Request: $ - %input!type=text!name=req!value=$string.req$ - \ $ - %input!type=submit -%hr -^so'^ + hamletToRepHtml [$hamlet|\ +
+ + \Request: + + \ + +
+\^{so'} |] -main = withHttpEnumerator $ basicHandler 3000 fb +main = warpDebug 3000 fb -objToHamlet :: StringObject -> Hamlet url -objToHamlet (Scalar s) = [$hamlet|$string.s$|] -objToHamlet (Sequence list) = [$hamlet| -%ul - $forall list o - %li ^objToHamlet.o^ +objToHamlet :: A.Value -> Hamlet url +objToHamlet (A.String s) = [$hamlet|#{s}|] +objToHamlet (A.Array list) = [$hamlet| +
    + $forall o <- V.toList list +
  • ^{objToHamlet o} |] -objToHamlet (Mapping pairs) = [$hamlet| -%dl - $forall pairs pair - %dt $string.fst.pair$ - %dd ^objToHamlet.snd.pair^ +objToHamlet (A.Object pairs) = [$hamlet|\ +
    + $forall pair <- M.toList pairs +
    #{fst pair} +
    ^{objToHamlet $ snd pair} |] From 5fa2e390c1c821cc92ab3f76038a40a568a33daf Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Apr 2011 00:35:00 +0300 Subject: [PATCH 055/182] http-enumerator 0.6 --- OpenId2/Discovery.hs | 4 ++-- Web/Authenticate/Facebook.hs | 4 ++-- Web/Authenticate/OAuth.hs | 5 ++--- Web/Authenticate/OpenId.hs | 3 +-- authenticate.cabal | 2 +- 5 files changed, 8 insertions(+), 10 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index 298ea885..f5ed0216 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -69,7 +69,7 @@ discoverYADIS :: ( MonadIO m discoverYADIS _ _ 0 = failure TooManyRedirects discoverYADIS ident mb_loc redirects = do let uri = fromMaybe (identifier ident) mb_loc - req <- parseUrl $ S8.pack uri + req <- parseUrl uri res <- liftIO $ withManager $ httpLbs req let mloc = fmap S8.unpack $ lookup "x-xrds-location" @@ -117,7 +117,7 @@ discoverHTML :: ( MonadIO m, Failure HttpException m) => Identifier -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) = - (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (S8.pack ident) + (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 2c162f32..52862398 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -64,7 +64,7 @@ accessTokenUrl fb code = getAccessToken :: Facebook -> Text -> IO AccessToken getAccessToken fb code = do let url = accessTokenUrl fb code - b <- simpleHttp url + b <- simpleHttp $ S8.unpack url let (front, back) = splitAt 13 $ L8.unpack b case front of "access_token=" -> return $ AccessToken $ T.pack back @@ -80,7 +80,7 @@ graphUrl (AccessToken s) func = getGraphData :: AccessToken -> Text -> IO (Either String Value) getGraphData at func = do let url = graphUrl at func - b <- simpleHttp url + b <- simpleHttp $ S8.unpack url return $ eitherResult $ parse json b getGraphData' :: AccessToken -> Text -> IO Value diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index d58ff2bc..6ed25791 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -33,7 +33,6 @@ import Numeric import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..)) import Network.HTTP.Types (Header) import Control.Arrow (second) -import qualified Data.ByteString.Char8 as S8 import Blaze.ByteString.Builder (toByteString) import Data.Enumerator (($$), run_, Stream (..), continue) import Data.Monoid (mconcat) @@ -91,7 +90,7 @@ fromStrict = BSL.fromChunks . return getTemporaryCredential :: OAuth -- ^ OAuth Application -> IO Credential -- ^ Temporary Credential (Request Token & Secret). getTemporaryCredential oa = do - let req = fromJust $ parseUrl $ S8.pack $ oauthRequestUri oa + let req = fromJust $ parseUrl $ oauthRequestUri oa req' <- signOAuth oa emptyCredential (req { method = "POST" }) rsp <- withManager $ httpLbs req' let dic = parseQueryString . toStrict . responseBody $ rsp @@ -109,7 +108,7 @@ getAccessToken, getTokenCredential -> Credential -- ^ Temporary Credential with oauth_verifier -> IO Credential -- ^ Token Credential (Access Token & Secret) getAccessToken oa cr = do - let req = (fromJust $ parseUrl $ S8.pack $ oauthAccessTokenUri oa) { method = "POST" } + let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } rsp <- signOAuth oa cr req >>= withManager . httpLbs let dic = parseQueryString . toStrict . responseBody $ rsp return $ Credential dic diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index bb5cc508..752dfc3e 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -14,7 +14,6 @@ import OpenId2.Types import Web.Authenticate.Internal (qsUrl) import Control.Monad (unless) import qualified Data.ByteString.UTF8 as BSU -import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.UTF8 as BSLU import Network.HTTP.Enumerator ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect @@ -88,7 +87,7 @@ authenticate params = do let params' = map (BSU.fromString *** BSU.fromString) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params - req' <- parseUrl $ S8.pack endpoint + req' <- parseUrl endpoint let req = urlEncodedBody params' req' rsp <- liftIO $ withManager $ httpLbsRedirect req let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp diff --git a/authenticate.cabal b/authenticate.cabal index 05455d66..b7d6f3c9 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -16,7 +16,7 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, aeson >= 0.3.1.1 && < 0.4, - http-enumerator >= 0.5.1 && < 0.6, + http-enumerator >= 0.6 && < 0.7, tagsoup >= 0.6 && < 0.13, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, From 35b3e31a4538907749ed4de8d18a61a0e6e39ded Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 5 Apr 2011 00:37:15 +0300 Subject: [PATCH 056/182] Drop wai-extra dependency --- Web/Authenticate/OAuth.hs | 8 ++++---- authenticate.cabal | 1 - 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index 6ed25791..cd21f0a4 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -20,7 +20,7 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Maybe import Control.Applicative -import Network.Wai.Parse +import Network.HTTP.Types (parseSimpleQuery) import Control.Exception import Control.Monad import Data.List (sortBy) @@ -93,7 +93,7 @@ getTemporaryCredential oa = do let req = fromJust $ parseUrl $ oauthRequestUri oa req' <- signOAuth oa emptyCredential (req { method = "POST" }) rsp <- withManager $ httpLbs req' - let dic = parseQueryString . toStrict . responseBody $ rsp + let dic = parseSimpleQuery . toStrict . responseBody $ rsp return $ Credential dic -- | URL to obtain OAuth verifier. @@ -110,7 +110,7 @@ getAccessToken, getTokenCredential getAccessToken oa cr = do let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } rsp <- signOAuth oa cr req >>= withManager . httpLbs - let dic = parseQueryString . toStrict . responseBody $ rsp + let dic = parseSimpleQuery . toStrict . responseBody $ rsp return $ Credential dic getTokenCredential = getAccessToken @@ -214,7 +214,7 @@ getBaseString tok req = do bsURI = BS.concat [scheme, "://", host req, bsPort, path req] bsQuery = map (second $ fromMaybe "") $ queryString req bsBodyQ <- if isBodyFormEncoded $ requestHeaders req - then liftM parseQueryString $ toLBS (requestBody req) + then liftM parseSimpleQuery $ toLBS (requestBody req) else return [] let bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).fst) $ unCredential tok allParams = bsQuery++bsBodyQ++bsAuthParams diff --git a/authenticate.cabal b/authenticate.cabal index b7d6f3c9..b8028cb0 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -30,7 +30,6 @@ library base64-bytestring >= 0.1 && < 0.2, SHA >= 1.4 && < 1.5, random >= 1.0 && < 1.1, - wai-extra >= 0.3 && < 0.4, text >= 0.5 && < 1.0, http-types >= 0.6 && < 0.7, enumerator >= 0.4.7 && < 0.5, From 72281c7fa06da42b8b4a3115e1368135df12e08b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 7 Apr 2011 22:28:37 +0300 Subject: [PATCH 057/182] Export AccessToken --- Web/Authenticate/Facebook.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 52862398..09b0520a 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Web.Authenticate.Facebook ( Facebook (..) + , AccessToken (..) , getForwardUrl , getAccessToken , getGraphData From 705528277c26a954e5d2785097e51cc8009a0847 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 7 Apr 2011 23:04:34 +0300 Subject: [PATCH 058/182] OpenId uses Text --- OpenId2/Discovery.hs | 11 +++++---- OpenId2/Normalization.hs | 13 +++++++---- OpenId2/Types.hs | 3 ++- Web/Authenticate/OpenId.hs | 47 +++++++++++++++++++++----------------- 4 files changed, 42 insertions(+), 32 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index f5ed0216..6260dc82 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -33,6 +33,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Failure (Failure (failure)) import Control.Monad (mplus, liftM) import qualified Data.CaseInsensitive as CI +import Data.Text (Text, pack, unpack) data Discovery = Discovery1 String (Maybe String) | Discovery2 Provider Identifier IdentType @@ -53,7 +54,7 @@ discover ident@(Identifier i) = do res2 <- discoverHTML ident case res2 of Just x -> return x - Nothing -> failure $ DiscoveryException i + Nothing -> failure $ DiscoveryException $ unpack i -- YADIS-Based Discovery ------------------------------------------------------- @@ -68,7 +69,7 @@ discoverYADIS :: ( MonadIO m -> m (Maybe (Provider, Identifier, IdentType)) discoverYADIS _ _ 0 = failure TooManyRedirects discoverYADIS ident mb_loc redirects = do - let uri = fromMaybe (identifier ident) mb_loc + let uri = fromMaybe (unpack $ identifier ident) mb_loc req <- parseUrl uri res <- liftIO $ withManager $ httpLbs req let mloc = fmap S8.unpack @@ -95,7 +96,7 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat where isOpenId svc = do let tys = serviceTypes svc - localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc + localId = maybe ident (Identifier . pack) $ listToMaybe $ serviceLocalIDs svc f (x,y) | x `elem` tys = Just y | otherwise = Nothing (lid, itype) <- listToMaybe $ mapMaybe f @@ -117,7 +118,7 @@ discoverHTML :: ( MonadIO m, Failure HttpException m) => Identifier -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) = - (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident + (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (unpack ident) -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. @@ -135,7 +136,7 @@ parseHTML ident = resolve return $ Discovery1 server delegate resolve2 ls = do prov <- lookup "openid2.provider" ls - let lid = maybe ident Identifier $ lookup "openid2.local_id" ls + let lid = maybe ident (Identifier . pack) $ 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 diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs index 2bcaf1c5..21dbfc82 100644 --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -26,12 +26,13 @@ import Network.URI ( uriToString, normalizeCase, normalizeEscape , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment ) +import Data.Text (Text, pack, unpack) -normalize :: Failure AuthenticateException m => String -> m Identifier +normalize :: Failure AuthenticateException m => Text -> m Identifier normalize ident = case normalizeIdentifier $ Identifier ident of Just i -> return i - Nothing -> failure $ NormalizationException ident + Nothing -> failure $ NormalizationException $ unpack ident -- | Normalize an identifier, discarding XRIs. normalizeIdentifier :: Identifier -> Maybe Identifier @@ -42,12 +43,13 @@ normalizeIdentifier = normalizeIdentifier' (const Nothing) -- normalize an XRI. normalizeIdentifier' :: (String -> Maybe String) -> Identifier -> Maybe Identifier -normalizeIdentifier' xri (Identifier str) +normalizeIdentifier' xri (Identifier str') | null str = Nothing - | "xri://" `isPrefixOf` str = Identifier `fmap` xri str - | head str `elem` "=@+$!" = Identifier `fmap` xri str + | "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 @@ -59,6 +61,7 @@ normalizeIdentifier' xri (Identifier str) | otherwise = uriPath uri fmt u = Identifier + $ pack $ normalizePathSegments $ normalizeEscape $ normalizeCase diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs index ac157344..fffe2b33 100644 --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -21,12 +21,13 @@ module OpenId2.Types ( import Data.Data (Data) import Data.Typeable (Typeable) import Web.Authenticate.Internal +import Data.Text (Text) -- | An OpenID provider. newtype Provider = Provider { providerURI :: String } deriving (Eq,Show) -- | A valid OpenID identifier. -newtype Identifier = Identifier { identifier :: String } +newtype Identifier = Identifier { identifier :: Text } deriving (Eq, Ord, Show, Read, Data, Typeable) data IdentType = OPIdent | ClaimedIdent diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 752dfc3e..e8ab39f5 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} module Web.Authenticate.OpenId ( getForwardUrl , authenticate @@ -22,25 +23,28 @@ import Network.HTTP.Enumerator import Control.Arrow ((***)) import Data.List (unfoldr) import Data.Maybe (fromMaybe) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (encodeUtf8) getForwardUrl :: ( MonadIO m , Failure AuthenticateException m , Failure HttpException m ) - => String -- ^ The openid the user provided. - -> String -- ^ The URL for this application\'s complete page. - -> Maybe String -- ^ Optional realm - -> [(String, String)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions. - -> m String -- ^ URL to send the user to. + => 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. + -> m Text -- ^ URL to send the user to. getForwardUrl openid' complete mrealm params = do let realm = fromMaybe complete mrealm disc <- normalize openid' >>= discover case disc of Discovery1 server mdelegate -> - return $ qsUrl server + return $ pack $ qsUrl server + $ map (unpack *** unpack) -- FIXME $ ("openid.mode", "checkid_setup") - : ("openid.identity", fromMaybe openid' mdelegate) + : ("openid.identity", maybe openid' pack mdelegate) : ("openid.return_to", complete) : ("openid.realm", realm) : ("openid.trust_root", complete) @@ -50,22 +54,22 @@ getForwardUrl openid' complete mrealm params = do case itype of ClaimedIdent -> i OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select" - return $ qsUrl p + return $ pack $ qsUrl p $ ("openid.ns", "http://specs.openid.net/auth/2.0") : ("openid.mode", "checkid_setup") - : ("openid.claimed_id", i') - : ("openid.identity", i') - : ("openid.return_to", complete) - : ("openid.realm", realm) - : params + : ("openid.claimed_id", unpack i') + : ("openid.identity", unpack i') + : ("openid.return_to", unpack complete) + : ("openid.realm", unpack realm) + : map (unpack *** unpack) params authenticate :: ( MonadIO m , Failure AuthenticateException m , Failure HttpException m ) - => [(String, String)] - -> m (Identifier, [(String, String)]) + => [(Text, Text)] + -> m (Identifier, [(Text, Text)]) authenticate params = do unless (lookup "openid.mode" params == Just "id_res") $ failure $ case lookup "openid.mode" params of @@ -74,8 +78,8 @@ authenticate params = do | m == "error" -> case lookup "openid.error" params of Nothing -> AuthenticationException "An error occurred, but no error message was provided." - (Just e) -> AuthenticationException e - | otherwise -> AuthenticationException $ "mode is " ++ m ++ " but we were expecting id_res." + (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 -> @@ -84,20 +88,21 @@ authenticate params = do let endpoint = case disc of Discovery1 p _ -> p Discovery2 (Provider p) _ _ -> p - let params' = map (BSU.fromString *** BSU.fromString) + let params' = map (encodeUtf8 *** encodeUtf8) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params req' <- parseUrl endpoint let req = urlEncodedBody params' req' rsp <- liftIO $ withManager $ httpLbsRedirect req - let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp + let rps = parseDirectResponse $ pack $ BSLU.toString $ responseBody rsp -- FIXME case lookup "is_valid" rps of Just "true" -> return (Identifier ident, rps) _ -> failure $ AuthenticationException "OpenID provider did not validate" -- | Turn a response body into a list of parameters. -parseDirectResponse :: String -> [(String, String)] -parseDirectResponse = unfoldr step +parseDirectResponse :: Text -> [(Text, Text)] +parseDirectResponse = + map (pack *** pack) . unfoldr step . unpack where step [] = Nothing step str = case split (== '\n') str of From 480d6d341065e71f8db51bf54059d613a9320f37 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 27 Apr 2011 21:25:50 -0700 Subject: [PATCH 059/182] Add genSign to OAuth exports This decouples the signing process from Requests a bit. Some services require the signature to be somwehere other than in request headers, such as in url parameters. Exposing genSign solves this. --- Web/Authenticate/OAuth.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index cd21f0a4..2fc2e0fe 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -6,7 +6,7 @@ module Web.Authenticate.OAuth -- * Operations for credentials emptyCredential, insert, delete, inserts, -- * Signature - signOAuth, + signOAuth, genSign, -- * Url & operation for authentication authorizeUrl, getAccessToken, getTemporaryCredential, getTokenCredential, From f3997728f6b655898af759029f71a663a5923c3c Mon Sep 17 00:00:00 2001 From: Michael Date: Mon, 2 May 2011 15:35:27 +0300 Subject: [PATCH 060/182] Version bump --- authenticate.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/authenticate.cabal b/authenticate.cabal index b8028cb0..68f0ab89 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.0 +version: 0.9.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -28,7 +28,7 @@ library RSA >= 1.0 && < 1.1, time >= 1.1 && < 1.3, base64-bytestring >= 0.1 && < 0.2, - SHA >= 1.4 && < 1.5, + SHA >= 1.4 && < 1.6, random >= 1.0 && < 1.1, text >= 0.5 && < 1.0, http-types >= 0.6 && < 0.7, From f3d305506c69495e9e86d5dda6acb120a6dcbeb3 Mon Sep 17 00:00:00 2001 From: Hiromi Ishii Date: Thu, 19 May 2011 20:53:09 +0900 Subject: [PATCH 061/182] changed to see Response Status --- Web/Authenticate/OAuth.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index 2fc2e0fe..22d98bf5 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Web.Authenticate.OAuth ( -- * Data types - OAuth(..), SignMethod(..), Credential(..), + OAuth(..), SignMethod(..), Credential(..), OAuthException(..), -- * Operations for credentials emptyCredential, insert, delete, inserts, -- * Signature @@ -38,6 +38,7 @@ import Data.Enumerator (($$), run_, Stream (..), continue) import Data.Monoid (mconcat) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.IORef (newIORef, readIORef, atomicModifyIORef) +import Control.Exception (Exception, throwIO) -- | Data type for OAuth client (consumer). data OAuth = OAuth { oauthServerName :: String -- ^ Service name @@ -75,7 +76,7 @@ token, tokenSecret :: Credential -> BS.ByteString token = fromMaybe "" . lookup "oauth_token" . unCredential tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential -data OAuthException = ProtocolException String +data OAuthException = OAuthException String deriving (Show, Eq, Data, Typeable) instance Exception OAuthException @@ -93,8 +94,11 @@ getTemporaryCredential oa = do let req = fromJust $ parseUrl $ oauthRequestUri oa req' <- signOAuth oa emptyCredential (req { method = "POST" }) rsp <- withManager $ httpLbs req' - let dic = parseSimpleQuery . toStrict . responseBody $ rsp - return $ Credential dic + if statusCode rsp == 200 + then do + let dic = parseSimpleQuery . toStrict . responseBody $ rsp + return $ Credential dic + else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp) -- | URL to obtain OAuth verifier. authorizeUrl :: OAuth -- ^ OAuth Application From 6b639403459a869a1e4ea9cdbe5f3af73c14d534 Mon Sep 17 00:00:00 2001 From: Hiromi Ishii Date: Thu, 19 May 2011 20:58:09 +0900 Subject: [PATCH 062/182] changed to see Response Status --- Web/Authenticate/OAuth.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index 22d98bf5..28e0bd8a 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -114,8 +114,12 @@ getAccessToken, getTokenCredential getAccessToken oa cr = do let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } rsp <- signOAuth oa cr req >>= withManager . httpLbs - let dic = parseSimpleQuery . toStrict . responseBody $ rsp - return $ Credential dic + if statusCode rsp == 200 + then do + let dic = parseSimpleQuery . toStrict . responseBody $ rsp + return $ Credential dic + else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp) + getTokenCredential = getAccessToken From 6232f52aa0930e6bc448fcfb4796e5b2dbcc0b7c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Jun 2011 16:33:38 +0300 Subject: [PATCH 063/182] Fix Facebook code --- Web/Authenticate/Facebook.hs | 1 + authenticate.cabal | 2 +- facebook.hs | 11 ++++++----- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 09b0520a..0769049f 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -60,6 +60,7 @@ accessTokenUrl fb code = [ ("client_id", Just $ facebookClientId fb) , ("redirect_uri", Just $ facebookRedirectUri fb) , ("code", Just code) + , ("client_secret", Just $ facebookClientSecret fb) ] getAccessToken :: Facebook -> Text -> IO AccessToken diff --git a/authenticate.cabal b/authenticate.cabal index 68f0ab89..3a753a3e 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -16,7 +16,7 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, aeson >= 0.3.1.1 && < 0.4, - http-enumerator >= 0.6 && < 0.7, + http-enumerator >= 0.6.5.2 && < 0.7, tagsoup >= 0.6 && < 0.13, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, diff --git a/facebook.hs b/facebook.hs index e86e5936..1495a86a 100644 --- a/facebook.hs +++ b/facebook.hs @@ -22,23 +22,24 @@ instance Yesod FB where approot _ = "http://localhost:3000" getRootR = do FB f <- getYesod - let s = encodeUtf8 $ getForwardUrl f ["email"] + let s = getForwardUrl f ["email"] + liftIO $ print ("Redirecting", s) redirectString RedirectTemporary s return () getFacebookR = do FB f <- getYesod code <- runFormGet' $ stringInput "code" - at <- liftIO $ getAccessToken f $ pack code + at <- liftIO $ getAccessToken f code mreq <- runFormGet' $ maybeStringInput "req" let req = fromMaybe "me" mreq - Right so <- liftIO $ getGraphData at $ pack req + Right so <- liftIO $ getGraphData at req let so' = objToHamlet so hamletToRepHtml [$hamlet|\ - + \Request: - + \
    From 5e59d0165f3143a9445e2d4ef515a16b27c00d4d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Jun 2011 16:36:56 +0300 Subject: [PATCH 064/182] Version bump --- authenticate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index 3a753a3e..e55083b3 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.0.1 +version: 0.9.0.2 license: BSD3 license-file: LICENSE author: Michael Snoyman From 0c0b1334461fd68284db70fe08cb09206ae5d038 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Jun 2011 16:51:21 +0300 Subject: [PATCH 065/182] Version bump --- authenticate.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/authenticate.cabal b/authenticate.cabal index e55083b3..fde92373 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.0.2 +version: 0.9.1 license: BSD3 license-file: LICENSE author: Michael Snoyman From ea33d8e8ac60471d29678251b1ef9243863fa67d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 10 Jun 2011 08:25:45 +0300 Subject: [PATCH 066/182] Fixed facebook tokens --- Web/Authenticate/Facebook.hs | 18 +++++++++--------- authenticate.cabal | 2 +- facebook.hs | 36 +++++++++++++++++++++++------------- 3 files changed, 33 insertions(+), 23 deletions(-) diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index 0769049f..97ace9ec 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -7,19 +7,19 @@ module Web.Authenticate.Facebook , getForwardUrl , getAccessToken , getGraphData + , getGraphData_ ) where import Network.HTTP.Enumerator -import Data.List (intercalate) +import Network.HTTP.Types (parseSimpleQuery) import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as L8 -import Web.Authenticate.Internal (qsEncode) import Data.Data (Data) import Data.Typeable (Typeable) import Control.Exception (Exception, throwIO) import Data.Attoparsec.Lazy (parse, eitherResult) import qualified Data.ByteString.Char8 as S8 -import Data.Text (Text, pack) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Blaze.ByteString.Builder (toByteString, copyByteString) @@ -67,10 +67,10 @@ getAccessToken :: Facebook -> Text -> IO AccessToken getAccessToken fb code = do let url = accessTokenUrl fb code b <- simpleHttp $ S8.unpack url - let (front, back) = splitAt 13 $ L8.unpack b - case front of - "access_token=" -> return $ AccessToken $ T.pack back - _ -> error $ "Invalid facebook response: " ++ back + let params = parseSimpleQuery $ S8.concat $ L8.toChunks b + case lookup "access_token" params of + Just x -> return $ AccessToken $ T.pack $ S8.unpack x + Nothing -> error $ "Invalid facebook response: " ++ L8.unpack b graphUrl :: AccessToken -> Text -> ByteString graphUrl (AccessToken s) func = @@ -85,8 +85,8 @@ getGraphData at func = do b <- simpleHttp $ S8.unpack url return $ eitherResult $ parse json b -getGraphData' :: AccessToken -> Text -> IO Value -getGraphData' a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return +getGraphData_ :: AccessToken -> Text -> IO Value +getGraphData_ a b = getGraphData a b >>= either (throwIO . InvalidJsonException) return data InvalidJsonException = InvalidJsonException String deriving (Show, Typeable) diff --git a/authenticate.cabal b/authenticate.cabal index fde92373..12d43cc7 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.1 +version: 0.9.1.1 license: BSD3 license-file: LICENSE author: Michael Snoyman diff --git a/facebook.hs b/facebook.hs index 1495a86a..686f37b3 100644 --- a/facebook.hs +++ b/facebook.hs @@ -2,40 +2,45 @@ import Yesod import Web.Authenticate.Facebook import Data.Maybe (fromMaybe) -import Network.HTTP.Enumerator -import Data.Text (pack) import qualified Data.Aeson as A import qualified Data.Vector as V import qualified Data.Map as M -import Data.Text.Encoding (encodeUtf8) data FB = FB Facebook +type Handler = GHandler FB FB + fb :: FB -fb = FB $ Facebook "134280699924829" "a7685e10c8977f5435e599aaf1d232eb" - "http://localhost:3000/facebook" -mkYesod "FB" [$parseRoutes| +fb = FB Facebook + { facebookClientId = "154414801293567" + , facebookClientSecret = "f901e124bee0d162c9188f92b939b370" + , facebookRedirectUri = "http://localhost:3000/facebook" + } + +mkYesod "FB" [parseRoutes| / RootR GET /facebook FacebookR GET |] instance Yesod FB where approot _ = "http://localhost:3000" +getRootR :: Handler () getRootR = do FB f <- getYesod let s = getForwardUrl f ["email"] - liftIO $ print ("Redirecting", s) - redirectString RedirectTemporary s - return () + liftIO $ print ("Redirecting" :: String, s) + redirectText RedirectTemporary s +getFacebookR :: Handler RepHtml getFacebookR = do FB f <- getYesod code <- runFormGet' $ stringInput "code" at <- liftIO $ getAccessToken f code + liftIO $ print at mreq <- runFormGet' $ maybeStringInput "req" let req = fromMaybe "me" mreq Right so <- liftIO $ getGraphData at req let so' = objToHamlet so - hamletToRepHtml [$hamlet|\ + hamletToRepHtml [hamlet|\ \Request: @@ -46,18 +51,23 @@ getFacebookR = do \^{so'} |] +main :: IO () main = warpDebug 3000 fb objToHamlet :: A.Value -> Hamlet url -objToHamlet (A.String s) = [$hamlet|#{s}|] -objToHamlet (A.Array list) = [$hamlet| +objToHamlet (A.String s) = [hamlet|#{s}|] +objToHamlet (A.Array list) = [hamlet|
      $forall o <- V.toList list
    • ^{objToHamlet o} |] -objToHamlet (A.Object pairs) = [$hamlet|\ +objToHamlet (A.Object pairs) = [hamlet|\
      $forall pair <- M.toList pairs
      #{fst pair}
      ^{objToHamlet $ snd pair} |] +objToHamlet (A.Number i) = [hamlet|#{show i}|] +objToHamlet (A.Bool True) = [hamlet|true|] +objToHamlet (A.Bool False) = [hamlet|false|] +objToHamlet A.Null = [hamlet|null|] From 56d84c5d8bb31df4eec6eb89dbb44b71a92e19a3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 12 Jun 2011 20:09:53 +0300 Subject: [PATCH 067/182] Missing records in Rpxnow module --- Web/Authenticate/Rpxnow.hs | 2 ++ authenticate.cabal | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index 23defbe5..a7bda581 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -73,6 +73,8 @@ authenticate apiKey token = do ] , requestBody = RequestBodyLBS body , checkCerts = const $ return True + , proxy = Nothing + , rawBody = False } res <- liftIO $ withManager $ httpLbsRedirect req let b = responseBody res diff --git a/authenticate.cabal b/authenticate.cabal index 12d43cc7..dd8eff73 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.1.1 +version: 0.9.1.2 license: BSD3 license-file: LICENSE author: Michael Snoyman From df24f3477500c51e81e12f49a675db8eaa48587a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 13 Jun 2011 07:03:29 +0300 Subject: [PATCH 068/182] Fixed rpxnow JSON code --- Web/Authenticate/Rpxnow.hs | 8 +++++--- authenticate.cabal | 5 +++-- rpxnow.hs | 38 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 46 insertions(+), 5 deletions(-) create mode 100644 rpxnow.hs diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index a7bda581..2c106632 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -38,6 +38,8 @@ import Data.Attoparsec.Lazy (parse) import qualified Data.Attoparsec.Lazy as AT import Data.Text (Text) import qualified Data.Aeson.Types +import qualified Data.Map as Map +import Control.Applicative ((<$>), (<*>)) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier @@ -101,9 +103,9 @@ unResult = either (failure . RpxnowException) return . AT.eitherResult parseProfile :: Value -> Data.Aeson.Types.Parser Identifier parseProfile (Object m) = do profile <- m .: "profile" - ident <- m .: "identifier" - let profile' = mapMaybe go profile - return $ Identifier ident profile' + Identifier + <$> (profile .: "identifier") + <*> return (mapMaybe go (Map.toList profile)) where go ("identifier", _) = Nothing go (k, String v) = Just (k, v) diff --git a/authenticate.cabal b/authenticate.cabal index dd8eff73..bcbc3328 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -1,5 +1,5 @@ name: authenticate -version: 0.9.1.2 +version: 0.9.1.3 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -34,7 +34,8 @@ library http-types >= 0.6 && < 0.7, enumerator >= 0.4.7 && < 0.5, blaze-builder >= 0.2 && < 0.4, - attoparsec >= 0.8.5 && < 0.9 + attoparsec >= 0.8.5 && < 0.9, + containers exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.OpenId.Providers, diff --git a/rpxnow.hs b/rpxnow.hs new file mode 100644 index 00000000..e37d5580 --- /dev/null +++ b/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| +