authenticate-1.3.2.11/0000755000000000000000000000000012445507654012615 5ustar0000000000000000authenticate-1.3.2.11/authenticate.cabal0000644000000000000000000000414512445507654016263 0ustar0000000000000000name: authenticate version: 1.3.2.11 license: BSD3 license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani maintainer: Michael Snoyman synopsis: Authentication methods for Haskell web applications. description: API docs and the README are available at . category: Web stability: Stable cabal-version: >= 1.6 build-type: Simple homepage: http://github.com/yesodweb/authenticate extra-source-files: README.md ChangeLog.md flag network-uri description: Get Network.URI from the network-uri package default: True library build-depends: base >= 4 && < 5 , aeson >= 0.5 , http-conduit >= 1.5 , transformers >= 0.1 , bytestring >= 0.9 , case-insensitive >= 0.2 , text , http-types >= 0.6 , xml-conduit >= 1.0 , blaze-builder , attoparsec , containers , unordered-containers , conduit >= 0.5 , tagstream-conduit >= 0.5.5 , resourcet , monad-control exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.BrowserId, Web.Authenticate.OpenId.Providers other-modules: Web.Authenticate.Internal, OpenId2.Discovery, OpenId2.Normalization, OpenId2.Types, OpenId2.XRDS ghc-options: -Wall if flag(network-uri) build-depends: network-uri >= 2.6 else build-depends: network < 2.6 source-repository head type: git location: git://github.com/yesodweb/authenticate.git authenticate-1.3.2.11/ChangeLog.md0000644000000000000000000000002612445507654014764 0ustar0000000000000000No changes logged yet authenticate-1.3.2.11/LICENSE0000644000000000000000000000253012445507654013622 0ustar0000000000000000The 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. authenticate-1.3.2.11/README.md0000644000000000000000000000030012445507654014065 0ustar0000000000000000## authenticate Focus is on third-party authentication methods, such as OpenID and BrowserID. Note: Facebook support is now provided by [the fb package](http://www.stackage.org/package/fb). authenticate-1.3.2.11/Setup.lhs0000644000000000000000000000016212445507654014424 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain authenticate-1.3.2.11/OpenId2/0000755000000000000000000000000012445507654014055 5ustar0000000000000000authenticate-1.3.2.11/OpenId2/Discovery.hs0000644000000000000000000001376112445507654016370 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | -- Module : Network.OpenID.Discovery -- Copyright : (c) Trevor Elliott, 2008 -- License : BSD3 -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- module OpenId2.Discovery ( -- * Discovery discover , Discovery (..) ) where -- Friends import OpenId2.Types import OpenId2.XRDS -- Libraries import Data.Char import Data.Maybe import Network.HTTP.Conduit import qualified Data.ByteString.Char8 as S8 import Control.Arrow (first) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad (mplus, liftM) import qualified Data.CaseInsensitive as CI import Data.Text (Text, unpack) import Data.Text.Lazy (toStrict) import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Control.Applicative ((<$>), (<*>)) import Network.HTTP.Types (status200) import Control.Exception (throwIO) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Resource (MonadResource) import Data.Conduit ((=$), ($$), yield) import Text.HTML.TagStream.Text (tokenStream, Token) import Text.HTML.TagStream.Types (Token' (TagOpen)) import qualified Data.Conduit.List as CL data Discovery = Discovery1 Text (Maybe Text) | Discovery2 Provider Identifier IdentType deriving Show -- | Attempt to resolve an OpenID endpoint, and user identifier. discover :: (MonadBaseControl IO m, MonadIO m, MonadResource m) => Identifier -> Manager -> m Discovery discover ident@(Identifier i) manager = do res1 <- discoverYADIS ident Nothing 10 manager case res1 of Just (x, y, z) -> return $ Discovery2 x y z Nothing -> do res2 <- discoverHTML ident manager case res2 of Just x -> return x Nothing -> liftIO $ throwIO $ DiscoveryException $ unpack i -- YADIS-Based Discovery ------------------------------------------------------- -- | Attempt a YADIS based discovery, given a valid identifier. The result is -- an OpenID endpoint, and the actual identifier for the user. discoverYADIS :: (MonadResource m, MonadBaseControl IO m) => Identifier -> Maybe String -> Int -- ^ remaining redirects -> Manager -> m (Maybe (Provider, Identifier, IdentType)) discoverYADIS _ _ 0 _ = liftIO $ throwIO $ TooManyRedirects #if MIN_VERSION_http_conduit(1,6,0) [] #endif discoverYADIS ident mb_loc redirects manager = do let uri = fromMaybe (unpack $ identifier ident) mb_loc req <- liftIO $ parseUrl uri res <- httpLbs req #if MIN_VERSION_http_conduit(1, 9, 0) { checkStatus = \_ _ _ -> Nothing #else { checkStatus = \_ _ -> Nothing #endif } manager let mloc = fmap S8.unpack $ lookup "x-xrds-location" $ map (first $ map toLower . S8.unpack . CI.original) $ responseHeaders res let mloc' = if mloc == mb_loc then Nothing else mloc if responseStatus res == status200 then case mloc' of Just loc -> discoverYADIS ident (Just loc) (redirects - 1) manager Nothing -> do let mdoc = parseXRDS $ responseBody res case mdoc of Just doc -> return $ parseYADIS ident doc Nothing -> return Nothing else return Nothing -- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml -- document. parseYADIS :: Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType) parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat where isOpenId svc = do let tys = serviceTypes svc localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc f (x,y) | x `elem` tys = Just y | otherwise = Nothing (lid, itype) <- listToMaybe $ mapMaybe f [ ("http://specs.openid.net/auth/2.0/server", (ident, OPIdent)) -- claimed identifiers , ("http://specs.openid.net/auth/2.0/signon", (localId, ClaimedIdent)) , ("http://openid.net/signon/1.0" , (localId, ClaimedIdent)) , ("http://openid.net/signon/1.1" , (localId, ClaimedIdent)) ] uri <- listToMaybe $ serviceURIs svc return (Provider uri, lid, itype) -- HTML-Based Discovery -------------------------------------------------------- -- | Attempt to discover an OpenID endpoint, from an HTML document. The result -- will be an endpoint on success, and the actual identifier of the user. discoverHTML :: (MonadResource m, MonadBaseControl IO m) => Identifier -> Manager -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) manager = do req <- liftIO $ parseUrl $ unpack ident lbs <- liftM responseBody $ httpLbs req manager return $ parseHTML ident' . toStrict . decodeUtf8With lenientDecode $ lbs -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. parseHTML :: Identifier -> Text -> Maybe Discovery parseHTML ident text0 = do ls <- yield text0 $$ tokenStream =$ CL.mapMaybe linkTag =$ CL.filter isOpenId =$ CL.consume resolve ls where isOpenId (rel, _x) = "openid" `T.isPrefixOf` rel resolve1 ls = do server <- lookup "openid.server" ls let delegate = lookup "openid.delegate" ls return $ Discovery1 server delegate resolve2 ls = do prov <- lookup "openid2.provider" ls let lid = maybe ident Identifier $ lookup "openid2.local_id" ls -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only -- result in a claimed identifier. return $ Discovery2 (Provider prov) lid ClaimedIdent resolve ls = resolve2 ls `mplus` resolve1 ls -- | Filter out link tags from a list of html tags. linkTag :: Token -> Maybe (Text, Text) linkTag (TagOpen "link" as _) = (,) <$> lookup "rel" as <*> lookup "href" as linkTag _x = Nothing authenticate-1.3.2.11/OpenId2/Types.hs0000644000000000000000000000160412445507654015516 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} -------------------------------------------------------------------------------- -- | -- Module : Network.OpenID.Types -- Copyright : (c) Trevor Elliott, 2008 -- License : BSD3 -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- module OpenId2.Types ( Provider (..) , Identifier (..) , IdentType (..) , AuthenticateException (..) ) where -- Libraries import Data.Data (Data) import Data.Typeable (Typeable) import Web.Authenticate.Internal import Data.Text (Text) -- | An OpenID provider. newtype Provider = Provider { providerURI :: Text } deriving (Eq,Show) -- | A valid OpenID identifier. newtype Identifier = Identifier { identifier :: Text } deriving (Eq, Ord, Show, Read, Data, Typeable) data IdentType = OPIdent | ClaimedIdent deriving (Eq, Ord, Show, Read, Data, Typeable) authenticate-1.3.2.11/OpenId2/XRDS.hs0000644000000000000000000000422612445507654015175 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | -- Module : Text.XRDS -- Copyright : (c) Trevor Elliott, 2008 -- License : BSD3 -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- module OpenId2.XRDS ( -- * Types XRDS , Service(..) -- * Parsing , parseXRDS ) where -- Libraries import Control.Monad ((>=>)) import Data.Maybe (listToMaybe) import Text.XML (parseLBS, def) import Text.XML.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute) import qualified Data.ByteString.Lazy as L import Data.Text (Text) import qualified Data.Text.Read -- Types ----------------------------------------------------------------------- type XRDS = [XRD] type XRD = [Service] data Service = Service { serviceTypes :: [Text] , serviceMediaTypes :: [Text] , serviceURIs :: [Text] , serviceLocalIDs :: [Text] , servicePriority :: Maybe Int } deriving Show parseXRDS :: L.ByteString -> Maybe XRDS parseXRDS str = either (const Nothing) (Just . parseXRDS' . fromDocument) (parseLBS def str) parseXRDS' :: Cursor -> [[Service]] parseXRDS' = element "{xri://$xrds}XRDS" &/ element "{xri://$xrd*($v*2.0)}XRD" &| parseXRD parseXRD :: Cursor -> [Service] parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService parseService :: Cursor -> [Service] parseService c = if null types then [] else [Service { serviceTypes = types , serviceMediaTypes = mtypes , serviceURIs = uris , serviceLocalIDs = localids , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe }] where types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content readMaybe t = case Data.Text.Read.signed Data.Text.Read.decimal t of Right (i, "") -> Just i _ -> Nothing authenticate-1.3.2.11/OpenId2/Normalization.hs0000644000000000000000000000414412445507654017242 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -------------------------------------------------------------------------------- -- | -- Module : Network.OpenID.Normalization -- Copyright : (c) Trevor Elliott, 2008 -- License : BSD3 -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- module OpenId2.Normalization ( normalize ) where -- Friends import OpenId2.Types -- Libraries import Control.Applicative import Control.Monad import Data.List import Network.URI ( uriToString, normalizeCase, normalizeEscape , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment ) import Data.Text (Text, pack, unpack) import Control.Monad.IO.Class import Control.Exception (throwIO) normalize :: MonadIO m => Text -> m Identifier normalize ident = case normalizeIdentifier $ Identifier ident of Just i -> return i Nothing -> liftIO $ throwIO $ NormalizationException $ unpack ident -- | Normalize an identifier, discarding XRIs. normalizeIdentifier :: Identifier -> Maybe Identifier normalizeIdentifier = normalizeIdentifier' (const Nothing) -- | Normalize the user supplied identifier, using a supplied function to -- normalize an XRI. normalizeIdentifier' :: (String -> Maybe String) -> Identifier -> Maybe Identifier normalizeIdentifier' xri (Identifier str') | null str = Nothing | "xri://" `isPrefixOf` str = (Identifier . pack) `fmap` xri str | head str `elem` "=@+$!" = (Identifier . pack) `fmap` xri str | otherwise = fmt `fmap` (url >>= norm) where str = unpack str' url = parseURI str <|> parseURI ("http://" ++ str) norm uri = validScheme >> return u where scheme' = uriScheme uri validScheme = guard (scheme' == "http:" || scheme' == "https:") u = uri { uriFragment = "", uriPath = path' } path' | null (uriPath uri) = "/" | otherwise = uriPath uri fmt u = Identifier $ pack $ normalizePathSegments $ normalizeEscape $ normalizeCase $ uriToString (const "") u [] authenticate-1.3.2.11/Web/0000755000000000000000000000000012445507654013332 5ustar0000000000000000authenticate-1.3.2.11/Web/Authenticate/0000755000000000000000000000000012445507654015750 5ustar0000000000000000authenticate-1.3.2.11/Web/Authenticate/Internal.hs0000644000000000000000000000064112445507654020061 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Web.Authenticate.Internal ( AuthenticateException (..) ) where import Data.Typeable (Typeable) import Control.Exception (Exception) data AuthenticateException = RpxnowException String | NormalizationException String | DiscoveryException String | AuthenticationException String deriving (Show, Typeable) instance Exception AuthenticateException authenticate-1.3.2.11/Web/Authenticate/Rpxnow.hs0000644000000000000000000000665412445507654017614 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------- -- -- Module : Web.Authenticate.Rpxnow -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : Unstable -- Portability : portable -- -- Facilitates authentication with "http://rpxnow.com/". -- --------------------------------------------------------- module Web.Authenticate.Rpxnow ( Identifier (..) , authenticate , AuthenticateException (..) ) where import Data.Aeson import Network.HTTP.Conduit import Control.Monad.IO.Class import Data.Maybe import Control.Monad import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Web.Authenticate.Internal import Data.Data (Data) import Data.Typeable (Typeable) import Data.Attoparsec.Lazy (parse) import qualified Data.Attoparsec.Lazy as AT import Data.Text (Text) import qualified Data.Aeson.Types import qualified Data.HashMap.Lazy as Map import Control.Applicative ((<$>), (<*>)) import Control.Exception (throwIO) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Resource (MonadResource) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier { identifier :: Text , extraData :: [(Text, Text)] } deriving (Eq, Ord, Read, Show, Data, Typeable) -- | Attempt to log a user in. authenticate :: (MonadResource m, MonadBaseControl IO m) => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client. -> Manager -> m Identifier authenticate apiKey token manager = do let body = L.fromChunks [ "apiKey=" , S.pack apiKey , "&token=" , S.pack token ] req' <- liftIO $ parseUrl "https://rpxnow.com" let req = req' { method = "POST" , path = "api/v2/auth_info" , requestHeaders = [ ("Content-Type", "application/x-www-form-urlencoded") ] , requestBody = RequestBodyLBS body } res <- httpLbs req manager let b = responseBody res o <- unResult $ parse json b --m <- fromMapping o let mstat = flip Data.Aeson.Types.parse o $ \v -> case v of Object m -> m .: "stat" _ -> mzero case mstat of Success "ok" -> return () Success stat -> liftIO $ throwIO $ RpxnowException $ "Rpxnow login not accepted: " ++ stat ++ "\n" ++ L.unpack b _ -> liftIO $ throwIO $ RpxnowException "Now stat value found on Rpxnow response" case Data.Aeson.Types.parse parseProfile o of Success x -> return x Error e -> liftIO $ throwIO $ RpxnowException $ "Unable to parse Rpxnow response: " ++ e unResult :: MonadIO m => AT.Result a -> m a unResult = either (liftIO . throwIO . RpxnowException) return . AT.eitherResult parseProfile :: Value -> Data.Aeson.Types.Parser Identifier parseProfile (Object m) = do profile <- m .: "profile" Identifier <$> (profile .: "identifier") <*> return (mapMaybe go (Map.toList profile)) where go ("identifier", _) = Nothing go (k, String v) = Just (k, v) go _ = Nothing parseProfile _ = mzero authenticate-1.3.2.11/Web/Authenticate/BrowserId.hs0000644000000000000000000000301712445507654020205 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Web.Authenticate.BrowserId ( browserIdJs , checkAssertion ) where import Data.Text (Text) import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, Manager, method, urlEncodedBody) import Data.Aeson (json, Value (Object, String)) import Data.Attoparsec.Lazy (parse, maybeResult) import qualified Data.HashMap.Lazy as Map import Data.Text.Encoding (encodeUtf8) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Resource (MonadResource) -- | Location of the Javascript file hosted by browserid.org browserIdJs :: Text browserIdJs = "https://login.persona.org/include.js" checkAssertion :: (MonadResource m, MonadBaseControl IO m) => Text -- ^ audience -> Text -- ^ assertion -> Manager -> m (Maybe Text) checkAssertion audience assertion manager = do req' <- liftIO $ parseUrl "https://verifier.login.persona.org/verify" let req = urlEncodedBody [ ("audience", encodeUtf8 audience) , ("assertion", encodeUtf8 assertion) ] req' { method = "POST" } res <- httpLbs req manager let lbs = responseBody res return $ maybeResult (parse json lbs) >>= getEmail where getEmail (Object o) = case (Map.lookup "status" o, Map.lookup "email" o) of (Just (String "okay"), Just (String e)) -> Just e _ -> Nothing getEmail _ = Nothing authenticate-1.3.2.11/Web/Authenticate/OpenId.hs0000644000000000000000000001441212445507654017464 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Web.Authenticate.OpenId ( -- * Functions getForwardUrl , authenticate , authenticateClaimed -- * Types , AuthenticateException (..) , Identifier (..) -- ** Response , OpenIdResponse , oirOpLocal , oirParams , oirClaimed ) where import Control.Monad.IO.Class import OpenId2.Normalization (normalize) import OpenId2.Discovery (discover, Discovery (..)) import OpenId2.Types import Control.Monad (unless) import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Lazy (toStrict) import Network.HTTP.Conduit ( parseUrl, urlEncodedBody, responseBody, httpLbs , Manager ) import Control.Arrow ((***), second) import Data.List (unfoldr) import Data.Maybe (fromMaybe) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Blaze.ByteString.Builder (toByteString) import Network.HTTP.Types (renderQueryText) import Control.Exception (throwIO) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Resource (MonadResource) getForwardUrl :: (MonadResource m, MonadBaseControl IO m) => Text -- ^ The openid the user provided. -> Text -- ^ The URL for this application\'s complete page. -> Maybe Text -- ^ Optional realm -> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions. -> Manager -> m Text -- ^ URL to send the user to. getForwardUrl openid' complete mrealm params manager = do let realm = fromMaybe complete mrealm claimed <- normalize $ T.strip openid' disc <- discover claimed manager let helper s q = return $ T.concat [ s , if "?" `T.isInfixOf` s then "&" else "?" , decodeUtf8 (toByteString $ renderQueryText False $ map (second Just) q) ] case disc of Discovery1 server mdelegate -> helper server $ ("openid.mode", "checkid_setup") : ("openid.identity", maybe (identifier claimed) id mdelegate) : ("openid.return_to", complete) : ("openid.realm", realm) : ("openid.trust_root", complete) : params Discovery2 (Provider p) (Identifier i) itype -> do let (claimed', identity') = case itype of ClaimedIdent -> (identifier claimed, i) OPIdent -> let x = "http://specs.openid.net/auth/2.0/identifier_select" in (x, x) helper p $ ("openid.ns", "http://specs.openid.net/auth/2.0") : ("openid.mode", "checkid_setup") : ("openid.claimed_id", claimed') : ("openid.identity", identity') : ("openid.return_to", complete) : ("openid.realm", realm) : params authenticate :: (MonadBaseControl IO m, MonadResource m, MonadIO m) => [(Text, Text)] -> Manager -> m (Identifier, [(Text, Text)]) authenticate ps m = do x <- authenticateClaimed ps m return (oirOpLocal x, oirParams x) {-# DEPRECATED authenticate "Use authenticateClaimed" #-} data OpenIdResponse = OpenIdResponse { oirOpLocal :: Identifier , oirParams :: [(Text, Text)] , oirClaimed :: Maybe Identifier } authenticateClaimed :: (MonadBaseControl IO m, MonadResource m, MonadIO m) => [(Text, Text)] -> Manager -> m OpenIdResponse authenticateClaimed params manager = do unless (lookup "openid.mode" params == Just "id_res") $ liftIO $ throwIO $ case lookup "openid.mode" params of Nothing -> AuthenticationException "openid.mode was not found in the params." (Just m) | m == "error" -> case lookup "openid.error" params of Nothing -> AuthenticationException "An error occurred, but no error message was provided." (Just e) -> AuthenticationException $ unpack e | otherwise -> AuthenticationException $ "mode is " ++ unpack m ++ " but we were expecting id_res." ident <- case lookup "openid.identity" params of Just i -> return i Nothing -> liftIO $ throwIO $ AuthenticationException "Missing identity" discOP <- normalize ident >>= flip discover manager let endpoint d = case d of Discovery1 p _ -> p Discovery2 (Provider p) _ _ -> p let params' = map (encodeUtf8 *** encodeUtf8) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params req' <- liftIO $ parseUrl $ unpack $ endpoint discOP let req = urlEncodedBody params' req' rsp <- httpLbs req manager let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp claimed <- case lookup "openid.claimed_id" params of Nothing -> return Nothing Just claimed' -> do -- need to validate that this provider can speak for the given -- claimed identifier claimedN <- normalize claimed' discC <- discover claimedN manager return $ if endpoint discOP == endpoint discC then Just claimedN else Nothing case lookup "is_valid" rps of Just "true" -> return OpenIdResponse { oirOpLocal = Identifier ident , oirParams = rps , oirClaimed = claimed } _ -> liftIO $ throwIO $ AuthenticationException "OpenID provider did not validate" -- | Turn a response body into a list of parameters. parseDirectResponse :: Text -> [(Text, Text)] parseDirectResponse = map (pack *** pack) . unfoldr step . unpack where step [] = Nothing step str = case split (== '\n') str of (ps,rest) -> Just (split (== ':') ps,rest) split :: (a -> Bool) -> [a] -> ([a],[a]) split p as = case break p as of (xs,_:ys) -> (xs,ys) pair -> pair authenticate-1.3.2.11/Web/Authenticate/OpenId/0000755000000000000000000000000012445507654017126 5ustar0000000000000000authenticate-1.3.2.11/Web/Authenticate/OpenId/Providers.hs0000644000000000000000000000207012445507654021436 0ustar0000000000000000-- | OpenIDs for a number of common OPs. When a function takes a 'String' -- parameter, that 'String' is the username. module Web.Authenticate.OpenId.Providers ( google , yahoo , livejournal , myspace , wordpress , blogger , verisign , typepad , myopenid , claimid ) where google :: String google = "https://www.google.com/accounts/o8/id" yahoo :: String yahoo = "http://me.yahoo.com/" livejournal :: String -> String livejournal u = concat ["http://", u, ".livejournal.com/"] myspace :: String -> String myspace = (++) "http://www.myspace.com/" wordpress :: String -> String wordpress u = concat ["http://", u, ".wordpress.com/"] blogger :: String -> String blogger u = concat ["http://", u, ".blogger.com/"] verisign :: String -> String verisign u = concat ["http://", u, ".pip.verisignlabs.com/"] typepad :: String -> String typepad u = concat ["http://", u, ".typepad.com/"] myopenid :: String -> String myopenid u = concat ["http://", u, ".myopenid.com/"] claimid :: String -> String claimid = (++) "http://claimid.com/"