authenticate 0.9.0 → 0.9.0.1
raw patch · 13 files changed
+1127/−1127 lines, 13 filesdep ~SHAsetup-changedPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependency ranges changed: SHA
API changes (from Hackage documentation)
+ Web.Authenticate.OAuth: genSign :: MonadIO m => OAuth -> Credential -> Request m -> m ByteString
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 +92/−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,92 @@-{-# 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) + ] + +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,- -- * 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-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.5,- 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.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