authenticate 0.9.0.1 → 0.9.0.2
raw patch · 13 files changed
+1128/−1127 lines, 13 filesdep ~http-enumeratorsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: http-enumerator
API changes (from Hackage documentation)
Files
- LICENSE +25/−25
- OpenId2/Discovery.hs +189/−189
- OpenId2/Normalization.hs +68/−68
- OpenId2/Types.hs +34/−34
- OpenId2/XRDS.hs +101/−101
- Setup.lhs +7/−7
- Web/Authenticate/Facebook.hs +93/−92
- Web/Authenticate/Internal.hs +44/−44
- Web/Authenticate/OAuth.hs +252/−252
- Web/Authenticate/OpenId.hs +114/−114
- Web/Authenticate/OpenId/Providers.hs +44/−44
- Web/Authenticate/Rpxnow.hs +109/−109
- authenticate.cabal +48/−48
LICENSE view
@@ -1,25 +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. +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.
OpenId2/Discovery.hs view
@@ -1,189 +1,189 @@-{-# LANGUAGE FlexibleContexts #-} - --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Discovery --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott <trevor@geekgateway.com> --- Stability : --- Portability : --- - -module OpenId2.Discovery ( - -- * Discovery - discover - , Discovery (..) - ) where - --- Friends -import OpenId2.Types -import OpenId2.XRDS - --- Libraries -import Data.Char -import Data.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.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 - deriving Show - --- | Attempt to resolve an OpenID endpoint, and user identifier. -discover :: ( MonadIO m - , Failure AuthenticateException m - , Failure HttpException m - ) - => Identifier - -> m Discovery -discover ident@(Identifier i) = do - res1 <- discoverYADIS ident Nothing 10 - case res1 of - Just (x, y, z) -> return $ Discovery2 x y z - Nothing -> do - res2 <- discoverHTML ident - case res2 of - Just x -> return x - Nothing -> failure $ 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 :: ( MonadIO m - , Failure HttpException m - ) - => Identifier - -> Maybe String - -> Int -- ^ remaining redirects - -> m (Maybe (Provider, Identifier, IdentType)) -discoverYADIS _ _ 0 = failure TooManyRedirects -discoverYADIS ident mb_loc redirects = do - let uri = fromMaybe (unpack $ identifier ident) mb_loc - req <- parseUrl uri - res <- liftIO $ withManager $ httpLbs req - 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 - case statusCode res of - 200 -> - case mloc' of - Just loc -> discoverYADIS ident (Just loc) (redirects - 1) - 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, IdentType) -parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat - where - isOpenId svc = do - let tys = serviceTypes svc - localId = maybe ident (Identifier . pack) $ 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 :: ( MonadIO m, Failure HttpException m) - => Identifier - -> m (Maybe Discovery) -discoverHTML ident'@(Identifier ident) = - (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (unpack ident) - --- | Parse out an OpenID endpoint and an actual identifier from an HTML --- document. -parseHTML :: Identifier -> String -> Maybe Discovery -parseHTML ident = resolve - . filter isOpenId - . map (dropQuotes *** dropQuotes) - . linkTags - . htmlTags - where - isOpenId (rel,_) = "openid" `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 . 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 - 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 - 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) - -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 +{-# LANGUAGE FlexibleContexts #-}++--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Discovery+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module OpenId2.Discovery (+ -- * Discovery+ discover+ , Discovery (..)+ ) where++-- Friends+import OpenId2.Types+import OpenId2.XRDS++-- Libraries+import Data.Char+import Data.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.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+ deriving Show++-- | Attempt to resolve an OpenID endpoint, and user identifier.+discover :: ( MonadIO m+ , Failure AuthenticateException m+ , Failure HttpException m+ )+ => Identifier+ -> m Discovery+discover ident@(Identifier i) = do+ res1 <- discoverYADIS ident Nothing 10+ case res1 of+ Just (x, y, z) -> return $ Discovery2 x y z+ Nothing -> do+ res2 <- discoverHTML ident+ case res2 of+ Just x -> return x+ Nothing -> failure $ 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 :: ( MonadIO m+ , Failure HttpException m+ )+ => Identifier+ -> Maybe String+ -> Int -- ^ remaining redirects+ -> m (Maybe (Provider, Identifier, IdentType))+discoverYADIS _ _ 0 = failure TooManyRedirects+discoverYADIS ident mb_loc redirects = do+ let uri = fromMaybe (unpack $ identifier ident) mb_loc+ req <- parseUrl uri+ res <- liftIO $ withManager $ httpLbs req+ 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+ case statusCode res of+ 200 ->+ case mloc' of+ Just loc -> discoverYADIS ident (Just loc) (redirects - 1)+ 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, IdentType)+parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat+ where+ isOpenId svc = do+ let tys = serviceTypes svc+ localId = maybe ident (Identifier . pack) $ 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 :: ( MonadIO m, Failure HttpException m)+ => Identifier+ -> m (Maybe Discovery)+discoverHTML ident'@(Identifier ident) =+ (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (unpack ident)++-- | Parse out an OpenID endpoint and an actual identifier from an HTML+-- document.+parseHTML :: Identifier -> String -> Maybe Discovery+parseHTML ident = resolve+ . filter isOpenId+ . map (dropQuotes *** dropQuotes)+ . linkTags+ . htmlTags+ where+ isOpenId (rel,_) = "openid" `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 . 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+ 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+ 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)++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
OpenId2/Normalization.hs view
@@ -1,68 +1,68 @@-{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Normalization --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott <trevor@geekgateway.com> --- Stability : --- Portability : --- - -module OpenId2.Normalization - ( normalize - ) where - --- Friends -import OpenId2.Types - --- Libraries -import Control.Applicative -import Control.Monad -import Data.List -import Control.Failure (Failure (..)) -import Network.URI - ( uriToString, normalizeCase, normalizeEscape - , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment - ) -import Data.Text (Text, pack, unpack) - -normalize :: Failure AuthenticateException m => Text -> m Identifier -normalize ident = - case normalizeIdentifier $ Identifier ident of - Just i -> return i - Nothing -> failure $ 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 [] +{-# LANGUAGE FlexibleContexts #-}+--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Normalization+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability : +-- Portability : +--++module OpenId2.Normalization+ ( normalize+ ) where++-- Friends+import OpenId2.Types++-- Libraries+import Control.Applicative+import Control.Monad+import Data.List+import Control.Failure (Failure (..))+import Network.URI+ ( uriToString, normalizeCase, normalizeEscape+ , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment+ )+import Data.Text (Text, pack, unpack)++normalize :: Failure AuthenticateException m => Text -> m Identifier+normalize ident =+ case normalizeIdentifier $ Identifier ident of+ Just i -> return i+ Nothing -> failure $ 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 []
OpenId2/Types.hs view
@@ -1,34 +1,34 @@-{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Types --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott <trevor@geekgateway.com> --- Stability : --- Portability : --- - -module OpenId2.Types ( - Provider (..) - , Identifier (..) - , IdentType (..) - , AuthenticateException (..) - ) where - --- Libraries -import Data.Data (Data) -import Data.Typeable (Typeable) -import Web.Authenticate.Internal -import Data.Text (Text) - --- | An OpenID provider. -newtype Provider = Provider { providerURI :: String } 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) +{-# LANGUAGE DeriveDataTypeable #-}+--------------------------------------------------------------------------------+-- |+-- Module : Network.OpenID.Types+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability : +-- Portability : +--++module OpenId2.Types (+ Provider (..)+ , Identifier (..)+ , IdentType (..)+ , AuthenticateException (..)+ ) where++-- Libraries+import Data.Data (Data)+import Data.Typeable (Typeable)+import Web.Authenticate.Internal+import Data.Text (Text)++-- | An OpenID provider.+newtype Provider = Provider { providerURI :: String } 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)
OpenId2/XRDS.hs view
@@ -1,101 +1,101 @@- --------------------------------------------------------------------------------- --- | --- Module : Text.XRDS --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott <trevor@geekgateway.com> --- Stability : --- Portability : --- - -module OpenId2.XRDS ( - -- * Types - XRDS - , Service(..) - - -- * Parsing - , parseXRDS - ) where - --- Libraries -import Control.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 ------------------------------------------------------------------- - --- | 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 - _ -> [] - --- 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 - } ++--------------------------------------------------------------------------------+-- |+-- Module : Text.XRDS+-- Copyright : (c) Trevor Elliott, 2008+-- License : BSD3+--+-- Maintainer : Trevor Elliott <trevor@geekgateway.com>+-- Stability :+-- Portability :+--++module OpenId2.XRDS (+ -- * Types+ XRDS+ , Service(..)++ -- * Parsing+ , parseXRDS+ ) where++-- Libraries+import Control.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 -------------------------------------------------------------------++-- | 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+ _ -> []++-- 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+ }
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
Web/Authenticate/Facebook.hs view
@@ -1,92 +1,93 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -module Web.Authenticate.Facebook - ( Facebook (..) - , AccessToken (..) - , getForwardUrl - , getAccessToken - , getGraphData - ) where - -import Network.HTTP.Enumerator -import Data.List (intercalate) -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 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 :: Text - , facebookClientSecret :: Text - , facebookRedirectUri :: Text - } - deriving (Show, Eq, Read, Ord, Data, Typeable) - -newtype AccessToken = AccessToken { unAccessToken :: Text } - deriving (Show, Eq, Read, Ord, Data, Typeable) - -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 -> 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.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 - -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 -> Text -> IO (Either String Value) -getGraphData at func = do - let url = graphUrl at func - 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 - -data InvalidJsonException = InvalidJsonException String - deriving (Show, Typeable) -instance Exception InvalidJsonException +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Authenticate.Facebook+ ( Facebook (..)+ , AccessToken (..)+ , getForwardUrl+ , getAccessToken+ , getGraphData+ ) where++import Network.HTTP.Enumerator+import Data.List (intercalate)+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 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 :: Text+ , facebookClientSecret :: Text+ , facebookRedirectUri :: Text+ }+ deriving (Show, Eq, Read, Ord, Data, Typeable)++newtype AccessToken = AccessToken { unAccessToken :: Text }+ deriving (Show, Eq, Read, Ord, Data, Typeable)++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 -> 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)+ , ("client_secret", Just $ facebookClientSecret fb)+ ]++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++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 -> Text -> IO (Either String Value)+getGraphData at func = do+ let url = graphUrl at func+ 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++data InvalidJsonException = InvalidJsonException String+ deriving (Show, Typeable)+instance Exception InvalidJsonException
Web/Authenticate/Internal.hs view
@@ -1,44 +1,44 @@-{-# 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 - delim = if '?' `elem` url then '&' else '?' - -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 +{-# 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+ delim = if '?' `elem` url then '&' else '?'++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
Web/Authenticate/OAuth.hs view
@@ -1,252 +1,252 @@-{-# 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, genSign, - -- * Url & operation for authentication - authorizeUrl, getAccessToken, getTemporaryCredential, - getTokenCredential, - -- * 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.HTTP.Types (parseSimpleQuery) -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 Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..)) -import Network.HTTP.Types (Header) -import Control.Arrow (second) -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 - , 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 <- withManager $ httpLbs req' - let dic = parseSimpleQuery . 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, getTokenCredential - :: 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 >>= withManager . httpLbs - let dic = parseSimpleQuery . 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) - -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 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 - 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) - , ("oauth_version", "1.0") - ] cred - -genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString -genSign oa tok req = - case oauthSignatureMethod oa of - HMACSHA1 -> do - text <- getBaseString tok req - let key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] - return $ encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text - PLAINTEXT -> - return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] - RSASHA1 pr -> - liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req) - -addAuthHeader :: Credential -> Request a -> Request a -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 :: 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 = map (second $ fromMaybe "") $ queryString req - bsBodyQ <- if isBodyFormEncoded $ requestHeaders 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 - bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple - $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams - -- FIXME it would be much better to use http-types functions here - return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] - -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 -compareTuple (a,b) (c,d) = - case compare a c of - LT -> LT - EQ -> compare b d - GT -> GT +{-# 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, genSign,+ -- * Url & operation for authentication+ authorizeUrl, getAccessToken, getTemporaryCredential,+ getTokenCredential,+ -- * 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.HTTP.Types (parseSimpleQuery)+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 Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..))+import Network.HTTP.Types (Header)+import Control.Arrow (second)+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+ , 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 <- withManager $ httpLbs req'+ let dic = parseSimpleQuery . 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, getTokenCredential+ :: 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 >>= withManager . httpLbs+ let dic = parseSimpleQuery . 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)++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 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+ 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)+ , ("oauth_version", "1.0")+ ] cred++genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString+genSign oa tok req =+ case oauthSignatureMethod oa of+ HMACSHA1 -> do+ text <- getBaseString tok req+ let key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]+ return $ encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text+ PLAINTEXT ->+ return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]+ RSASHA1 pr ->+ liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req)++addAuthHeader :: Credential -> Request a -> Request a+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 :: 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 = map (second $ fromMaybe "") $ queryString req+ bsBodyQ <- if isBodyFormEncoded $ requestHeaders 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+ bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple+ $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams+ -- FIXME it would be much better to use http-types functions here+ return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]++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+compareTuple (a,b) (c,d) =+ case compare a c of+ LT -> LT+ EQ -> compare b d+ GT -> GT
Web/Authenticate/OpenId.hs view
@@ -1,114 +1,114 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -module Web.Authenticate.OpenId - ( getForwardUrl - , authenticate - , AuthenticateException (..) - , Identifier (..) - ) where - -import Control.Monad.IO.Class -import OpenId2.Normalization (normalize) -import OpenId2.Discovery (discover, Discovery (..)) -import Control.Failure (Failure (failure)) -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, withManager - ) -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 - ) - => 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 $ pack $ qsUrl server - $ map (unpack *** unpack) -- FIXME - $ ("openid.mode", "checkid_setup") - : ("openid.identity", maybe openid' pack mdelegate) - : ("openid.return_to", complete) - : ("openid.realm", realm) - : ("openid.trust_root", complete) - : params - 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 $ pack $ qsUrl p - $ ("openid.ns", "http://specs.openid.net/auth/2.0") - : ("openid.mode", "checkid_setup") - : ("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 - ) - => [(Text, Text)] - -> m (Identifier, [(Text, Text)]) -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." - (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 -> - failure $ AuthenticationException "Missing identity" - disc <- normalize ident >>= discover - let endpoint = case disc of - Discovery1 p _ -> p - Discovery2 (Provider p) _ _ -> p - 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 $ 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 :: 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 +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Authenticate.OpenId+ ( getForwardUrl+ , authenticate+ , AuthenticateException (..)+ , Identifier (..)+ ) where++import Control.Monad.IO.Class+import OpenId2.Normalization (normalize)+import OpenId2.Discovery (discover, Discovery (..))+import Control.Failure (Failure (failure))+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, withManager+ )+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+ )+ => 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 $ pack $ qsUrl server+ $ map (unpack *** unpack) -- FIXME+ $ ("openid.mode", "checkid_setup")+ : ("openid.identity", maybe openid' pack mdelegate)+ : ("openid.return_to", complete)+ : ("openid.realm", realm)+ : ("openid.trust_root", complete)+ : params+ 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 $ pack $ qsUrl p+ $ ("openid.ns", "http://specs.openid.net/auth/2.0")+ : ("openid.mode", "checkid_setup")+ : ("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+ )+ => [(Text, Text)]+ -> m (Identifier, [(Text, Text)])+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."+ (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 ->+ failure $ AuthenticationException "Missing identity"+ disc <- normalize ident >>= discover+ let endpoint = case disc of+ Discovery1 p _ -> p+ Discovery2 (Provider p) _ _ -> p+ 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 $ 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 :: 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
Web/Authenticate/OpenId/Providers.hs view
@@ -1,44 +1,44 @@--- | OpenIDs for a number of common OPs. When a function takes a 'String' --- parameter, that 'String' is the username. -module Web.Authenticate.OpenId.Providers - ( google - , yahoo - , livejournal - , myspace - , wordpress - , blogger - , verisign - , typepad - , myopenid - , claimid - ) where - -google :: String -google = "https://www.google.com/accounts/o8/id" - -yahoo :: String -yahoo = "http://me.yahoo.com/" - -livejournal :: String -> String -livejournal u = concat ["http://", u, ".livejournal.com/"] - -myspace :: String -> String -myspace = (++) "http://www.myspace.com/" - -wordpress :: String -> String -wordpress u = concat ["http://", u, ".wordpress.com/"] - -blogger :: String -> String -blogger u = concat ["http://", u, ".blogger.com/"] - -verisign :: String -> String -verisign u = concat ["http://", u, ".pip.verisignlabs.com/"] - -typepad :: String -> String -typepad u = concat ["http://", u, ".typepad.com/"] - -myopenid :: String -> String -myopenid u = concat ["http://", u, ".myopenid.com/"] - -claimid :: String -> String -claimid = (++) "http://claimid.com/" +-- | 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/"
Web/Authenticate/Rpxnow.hs view
@@ -1,109 +1,109 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} ---------------------------------------------------------- --- --- Module : Web.Authenticate.Rpxnow --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman <michael@snoyman.com> --- Stability : Unstable --- Portability : portable --- --- Facilitates authentication with "http://rpxnow.com/". --- ---------------------------------------------------------- -module Web.Authenticate.Rpxnow - ( Identifier (..) - , authenticate - , AuthenticateException (..) - ) where - -import Data.Aeson -import Network.HTTP.Enumerator -import "transformers" Control.Monad.IO.Class -import Control.Failure -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) -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 :: 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) - => String -- ^ API key given by RPXNOW. - -> String -- ^ Token passed by client. - -> m Identifier -authenticate apiKey token = do - 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 = RequestBodyLBS body - , checkCerts = const $ return True - } - res <- liftIO $ withManager $ httpLbsRedirect req - let b = responseBody res - unless (200 <= statusCode res && statusCode res < 300) $ - liftIO $ throwIO $ StatusCodeException (statusCode res) b - 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 - -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, String v) = Just (k, v) - go _ = Nothing -parseProfile _ = mzero +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-}+---------------------------------------------------------+--+-- Module : Web.Authenticate.Rpxnow+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Facilitates authentication with "http://rpxnow.com/".+--+---------------------------------------------------------+module Web.Authenticate.Rpxnow+ ( Identifier (..)+ , authenticate+ , AuthenticateException (..)+ ) where++import Data.Aeson+import Network.HTTP.Enumerator+import "transformers" Control.Monad.IO.Class+import Control.Failure+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)+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 :: 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)+ => String -- ^ API key given by RPXNOW.+ -> String -- ^ Token passed by client.+ -> m Identifier+authenticate apiKey token = do+ 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 = RequestBodyLBS body+ , checkCerts = const $ return True+ }+ res <- liftIO $ withManager $ httpLbsRedirect req+ let b = responseBody res+ unless (200 <= statusCode res && statusCode res < 300) $+ liftIO $ throwIO $ StatusCodeException (statusCode res) b+ 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++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, String v) = Just (k, v)+ go _ = Nothing+parseProfile _ = mzero
authenticate.cabal view
@@ -1,48 +1,48 @@-name: authenticate -version: 0.9.0.1 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman <michael@snoyman.com> -maintainer: Michael Snoyman <michael@snoyman.com> -synopsis: Authentication methods for Haskell web applications. -description: Focus is on third-party authentication methods, such as OpenID, - rpxnow and Facebook. -category: Web -stability: Stable -cabal-version: >= 1.2 -build-type: Simple -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, - 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, - case-insensitive >= 0.2 && < 0.3, - RSA >= 1.0 && < 1.1, - time >= 1.1 && < 1.3, - base64-bytestring >= 0.1 && < 0.2, - SHA >= 1.4 && < 1.6, - random >= 1.0 && < 1.1, - 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, - Web.Authenticate.OpenId.Providers, - Web.Authenticate.OAuth, - Web.Authenticate.Facebook - other-modules: Web.Authenticate.Internal, - OpenId2.Discovery, - OpenId2.Normalization, - OpenId2.Types, - OpenId2.XRDS - ghc-options: -Wall +name: authenticate+version: 0.9.0.2+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: Authentication methods for Haskell web applications.+description: Focus is on third-party authentication methods, such as OpenID,+ rpxnow and Facebook.+category: Web+stability: Stable+cabal-version: >= 1.2+build-type: Simple+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.5.2 && < 0.7,+ 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,+ case-insensitive >= 0.2 && < 0.3,+ RSA >= 1.0 && < 1.1,+ time >= 1.1 && < 1.3,+ base64-bytestring >= 0.1 && < 0.2,+ SHA >= 1.4 && < 1.6,+ random >= 1.0 && < 1.1,+ 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,+ Web.Authenticate.OpenId.Providers,+ Web.Authenticate.OAuth,+ Web.Authenticate.Facebook+ other-modules: Web.Authenticate.Internal,+ OpenId2.Discovery,+ OpenId2.Normalization,+ OpenId2.Types,+ OpenId2.XRDS+ ghc-options: -Wall