authenticate-1.3.3.2/0000755000000000000000000000000012736676642012545 5ustar0000000000000000authenticate-1.3.3.2/authenticate.cabal0000644000000000000000000000414312736676642016211 0ustar0000000000000000name: authenticate version: 1.3.3.2 license: MIT 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.3.2/ChangeLog.md0000644000000000000000000000035312736676642014717 0ustar0000000000000000## 1.3.3.2 * Support for http-conduit-2.2.0 [#47](https://github.com/yesodweb/authenticate/issues/47) ## 1.3.3.1 * License update [#46](https://github.com/yesodweb/authenticate/issues/46) ## 1.3.3 Deprecated Google OpenID support authenticate-1.3.3.2/LICENSE0000644000000000000000000000207512736676642013556 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. authenticate-1.3.3.2/README.md0000644000000000000000000000030012736676642014015 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.3.2/Setup.lhs0000644000000000000000000000016212736676642014354 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain authenticate-1.3.3.2/OpenId2/0000755000000000000000000000000012736676642014005 5ustar0000000000000000authenticate-1.3.3.2/OpenId2/Discovery.hs0000644000000000000000000001435012736676642016313 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 _ = #if MIN_VERSION_http_conduit(2, 2, 0) error "discoverYADIS: Too many redirects" #else liftIO $ throwIO $ TooManyRedirects #if MIN_VERSION_http_conduit(1,6,0) [] #endif #endif discoverYADIS ident mb_loc redirects manager = do let uri = fromMaybe (unpack $ identifier ident) mb_loc #if MIN_VERSION_http_conduit(2, 2, 0) req <- liftIO $ parseRequest uri #else req <- liftIO $ parseUrl uri #endif res <- httpLbs req #if !MIN_VERSION_http_conduit(2, 2, 0) #if MIN_VERSION_http_conduit(1, 9, 0) { checkStatus = \_ _ _ -> Nothing #else { checkStatus = \_ _ -> Nothing #endif } #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.3.2/OpenId2/Normalization.hs0000644000000000000000000000414412736676642017172 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.3.2/OpenId2/Types.hs0000644000000000000000000000160412736676642015446 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.3.2/OpenId2/XRDS.hs0000644000000000000000000000422612736676642015125 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.3.2/Web/0000755000000000000000000000000012736676642013262 5ustar0000000000000000authenticate-1.3.3.2/Web/Authenticate/0000755000000000000000000000000012736676642015700 5ustar0000000000000000authenticate-1.3.3.2/Web/Authenticate/BrowserId.hs0000644000000000000000000000301712736676642020135 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.3.2/Web/Authenticate/Internal.hs0000644000000000000000000000064112736676642020011 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.3.2/Web/Authenticate/OpenId.hs0000644000000000000000000001441212736676642017414 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.3.2/Web/Authenticate/Rpxnow.hs0000644000000000000000000000665412736676642017544 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.3.2/Web/Authenticate/OpenId/0000755000000000000000000000000012736676642017056 5ustar0000000000000000authenticate-1.3.3.2/Web/Authenticate/OpenId/Providers.hs0000644000000000000000000000217512736676642021374 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" {-# DEPRECATED google "Google no longer provides OpenID support" #-} 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/"