authenticate 0.11.0.1 → 0.11.1
raw patch · 15 files changed
+1235/−1218 lines, 15 filesdep ~http-conduitsetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: http-conduit
API changes (from Hackage documentation)
+ Web.Authenticate.OAuth: newCredential :: ByteString -> ByteString -> Credential
+ Web.Authenticate.OAuth: newOAuth :: OAuth
+ Web.Authenticate.OAuth: oauthRealm :: OAuth -> Maybe ByteString
- Web.Authenticate.OAuth: OAuth :: String -> String -> String -> String -> SignMethod -> ByteString -> ByteString -> Maybe ByteString -> OAuth
+ Web.Authenticate.OAuth: OAuth :: String -> String -> String -> String -> SignMethod -> ByteString -> ByteString -> Maybe ByteString -> Maybe ByteString -> OAuth
Files
- LICENSE +25/−25
- OpenId2/Discovery.hs +145/−144
- OpenId2/Normalization.hs +68/−68
- OpenId2/Types.hs +34/−34
- OpenId2/XRDS.hs +77/−77
- Setup.lhs +7/−7
- Web/Authenticate/BrowserId.hs +35/−35
- Web/Authenticate/Facebook.hs +115/−115
- Web/Authenticate/Internal.hs +15/−15
- Web/Authenticate/Kerberos.hs +72/−72
- Web/Authenticate/OAuth.hs +317/−298
- Web/Authenticate/OpenId.hs +116/−116
- Web/Authenticate/OpenId/Providers.hs +44/−44
- Web/Authenticate/Rpxnow.hs +107/−110
- authenticate.cabal +58/−58
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,144 +1,145 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- | --- 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 - -import Debug.Trace --- Libraries -import Data.Char -import Data.Maybe -import Network.HTTP.Conduit -import qualified Data.ByteString.Char8 as S8 -import Control.Arrow (first) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Failure (Failure (failure)) -import Control.Monad (mplus, liftM) -import qualified Data.CaseInsensitive as CI -import Data.Text (Text, unpack) -import Data.Text.Lazy (toStrict) -import qualified Data.Text as T -import Data.Text.Lazy.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Text.HTML.TagSoup (parseTags, Tag (TagOpen)) -import Control.Applicative ((<$>), (<*>)) - -data Discovery = Discovery1 Text (Maybe Text) - | Discovery2 Provider Identifier IdentType - deriving Show - --- | Attempt to resolve an OpenID endpoint, and user identifier. -discover :: Identifier -> IO 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 :: Identifier - -> Maybe String - -> Int -- ^ remaining redirects - -> IO (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 $ 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 $ 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 :: Identifier -> IO (Maybe Discovery) -discoverHTML ident'@(Identifier ident) = - (parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident) - --- | Parse out an OpenID endpoint and an actual identifier from an HTML --- document. -parseHTML :: Identifier -> Text -> Maybe Discovery -parseHTML ident = resolve - . filter isOpenId - . mapMaybe linkTag - . parseTags - where - isOpenId (rel, _x) = "openid" `T.isPrefixOf` rel - resolve1 ls = do - server <- lookup "openid.server" ls - let delegate = lookup "openid.delegate" ls - return $ Discovery1 server delegate - resolve2 ls = do - prov <- lookup "openid2.provider" ls - let lid = maybe ident Identifier $ lookup "openid2.local_id" ls - -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only - -- result in a claimed identifier. - return $ Discovery2 (Provider prov) lid ClaimedIdent - resolve ls = resolve2 ls `mplus` resolve1 ls - - --- | Filter out link tags from a list of html tags. -linkTag :: Tag Text -> Maybe (Text, Text) -linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x -linkTag _x = Nothing +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++--------------------------------------------------------------------------------+-- |+-- 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++import Debug.Trace+-- Libraries+import Data.Char+import Data.Maybe+import Network.HTTP.Conduit+import qualified Data.ByteString.Char8 as S8+import Control.Arrow (first)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Failure (Failure (failure))+import Control.Monad (mplus, liftM)+import qualified Data.CaseInsensitive as CI+import Data.Text (Text, unpack)+import Data.Text.Lazy (toStrict)+import qualified Data.Text as T+import Data.Text.Lazy.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Text.HTML.TagSoup (parseTags, Tag (TagOpen))+import Control.Applicative ((<$>), (<*>))+import Network.HTTP.Types (status200)++data Discovery = Discovery1 Text (Maybe Text)+ | Discovery2 Provider Identifier IdentType+ deriving Show++-- | Attempt to resolve an OpenID endpoint, and user identifier.+discover :: Identifier -> IO 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 :: Identifier+ -> Maybe String+ -> Int -- ^ remaining redirects+ -> IO (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 { checkStatus = \_ _ -> Nothing }+ let mloc = fmap S8.unpack+ $ lookup "x-xrds-location"+ $ map (first $ map toLower . S8.unpack . CI.original)+ $ responseHeaders res+ let mloc' = if mloc == mb_loc then Nothing else mloc+ if statusCode res == status200+ then+ case mloc' of+ Just loc -> discoverYADIS ident (Just loc) (redirects - 1)+ Nothing -> do+ let mdoc = parseXRDS $ responseBody res+ case mdoc of+ Just doc -> return $ parseYADIS ident doc+ Nothing -> return Nothing+ else return Nothing+++-- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml+-- document.+parseYADIS :: Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType)+parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat+ where+ isOpenId svc = do+ let tys = serviceTypes svc+ localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc+ f (x,y) | x `elem` tys = Just y+ | otherwise = Nothing+ (lid, itype) <- listToMaybe $ mapMaybe f+ [ ("http://specs.openid.net/auth/2.0/server", (ident, OPIdent))+ -- claimed identifiers+ , ("http://specs.openid.net/auth/2.0/signon", (localId, ClaimedIdent))+ , ("http://openid.net/signon/1.0" , (localId, ClaimedIdent))+ , ("http://openid.net/signon/1.1" , (localId, ClaimedIdent))+ ]+ uri <- listToMaybe $ serviceURIs svc+ return (Provider uri, lid, itype)+++-- HTML-Based Discovery --------------------------------------------------------++-- | Attempt to discover an OpenID endpoint, from an HTML document. The result+-- will be an endpoint on success, and the actual identifier of the user.+discoverHTML :: Identifier -> IO (Maybe Discovery)+discoverHTML ident'@(Identifier ident) =+ (parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident)++-- | Parse out an OpenID endpoint and an actual identifier from an HTML+-- document.+parseHTML :: Identifier -> Text -> Maybe Discovery+parseHTML ident = resolve+ . filter isOpenId+ . mapMaybe linkTag+ . parseTags+ where+ isOpenId (rel, _x) = "openid" `T.isPrefixOf` rel+ resolve1 ls = do+ server <- lookup "openid.server" ls+ let delegate = lookup "openid.delegate" ls+ return $ Discovery1 server delegate+ resolve2 ls = do+ prov <- lookup "openid2.provider" ls+ let lid = maybe ident Identifier $ lookup "openid2.local_id" ls+ -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only+ -- result in a claimed identifier.+ return $ Discovery2 (Provider prov) lid ClaimedIdent+ resolve ls = resolve2 ls `mplus` resolve1 ls+++-- | Filter out link tags from a list of html tags.+linkTag :: Tag Text -> Maybe (Text, Text)+linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x+linkTag _x = Nothing
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 :: Text } deriving (Eq,Show) - --- | A valid OpenID identifier. -newtype Identifier = Identifier { identifier :: Text } - deriving (Eq, Ord, Show, Read, Data, Typeable) - -data IdentType = OPIdent | ClaimedIdent - deriving (Eq, Ord, Show, Read, Data, Typeable) +{-# 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 :: Text } deriving (Eq,Show)++-- | A valid OpenID identifier.+newtype Identifier = Identifier { identifier :: Text }+ deriving (Eq, Ord, Show, Read, Data, Typeable)++data IdentType = OPIdent | ClaimedIdent+ deriving (Eq, Ord, Show, Read, Data, Typeable)
OpenId2/XRDS.hs view
@@ -1,77 +1,77 @@-{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- | --- 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.Monad ((>=>)) -import Data.Maybe (listToMaybe) -import Text.XML (parseLBS, def) -import Text.XML.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute) -import qualified Data.ByteString.Lazy as L -import Data.Text (Text) -import qualified Data.Text.Read - --- Types ----------------------------------------------------------------------- - -type XRDS = [XRD] - -type XRD = [Service] - -data Service = Service - { serviceTypes :: [Text] - , serviceMediaTypes :: [Text] - , serviceURIs :: [Text] - , serviceLocalIDs :: [Text] - , servicePriority :: Maybe Int - } deriving Show - -parseXRDS :: L.ByteString -> Maybe XRDS -parseXRDS str = - either - (const Nothing) - (Just . parseXRDS' . fromDocument) - (parseLBS def str) - -parseXRDS' :: Cursor -> [[Service]] -parseXRDS' = element "{xri://$xrds}XRDS" &/ - element "{xri://$xrd*($v*2.0)}XRD" &| - parseXRD - -parseXRD :: Cursor -> [Service] -parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService - -parseService :: Cursor -> [Service] -parseService c = - if null types then [] else [Service - { serviceTypes = types - , serviceMediaTypes = mtypes - , serviceURIs = uris - , serviceLocalIDs = localids - , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe - }] - where - types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content - mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content - uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content - localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content - readMaybe t = - case Data.Text.Read.signed Data.Text.Read.decimal t of - Right (i, "") -> Just i - _ -> Nothing +{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- 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.Monad ((>=>))+import Data.Maybe (listToMaybe)+import Text.XML (parseLBS, def)+import Text.XML.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute)+import qualified Data.ByteString.Lazy as L+import Data.Text (Text)+import qualified Data.Text.Read++-- Types -----------------------------------------------------------------------++type XRDS = [XRD]++type XRD = [Service]++data Service = Service+ { serviceTypes :: [Text]+ , serviceMediaTypes :: [Text]+ , serviceURIs :: [Text]+ , serviceLocalIDs :: [Text]+ , servicePriority :: Maybe Int+ } deriving Show++parseXRDS :: L.ByteString -> Maybe XRDS+parseXRDS str =+ either+ (const Nothing)+ (Just . parseXRDS' . fromDocument)+ (parseLBS def str)++parseXRDS' :: Cursor -> [[Service]]+parseXRDS' = element "{xri://$xrds}XRDS" &/+ element "{xri://$xrd*($v*2.0)}XRD" &|+ parseXRD++parseXRD :: Cursor -> [Service]+parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService++parseService :: Cursor -> [Service]+parseService c =+ if null types then [] else [Service+ { serviceTypes = types+ , serviceMediaTypes = mtypes+ , serviceURIs = uris+ , serviceLocalIDs = localids+ , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe+ }]+ where+ types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content+ mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content+ uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content+ localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content+ readMaybe t =+ case Data.Text.Read.signed Data.Text.Read.decimal t of+ Right (i, "") -> Just i+ _ -> Nothing
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/BrowserId.hs view
@@ -1,35 +1,35 @@-{-# LANGUAGE OverloadedStrings #-} -module Web.Authenticate.BrowserId - ( browserIdJs - , checkAssertion - ) where - -import Data.Text (Text) -import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, withManager, method, urlEncodedBody) -import Data.Aeson (json, Value (Object, String)) -import Data.Attoparsec.Lazy (parse, maybeResult) -import qualified Data.HashMap.Lazy as Map -import Data.Text.Encoding (encodeUtf8) - --- | Location of the Javascript file hosted by browserid.org -browserIdJs :: Text -browserIdJs = "https://browserid.org/include.js" - -checkAssertion :: Text -- ^ audience - -> Text -- ^ assertion - -> IO (Maybe Text) -checkAssertion audience assertion = do - req' <- parseUrl "https://browserid.org/verify" - let req = urlEncodedBody - [ ("audience", encodeUtf8 audience) - , ("assertion", encodeUtf8 assertion) - ] req' { method = "POST" } - res <- withManager $ httpLbs req - let lbs = responseBody res - return $ maybeResult (parse json lbs) >>= getEmail - where - getEmail (Object o) = - case (Map.lookup "status" o, Map.lookup "email" o) of - (Just (String "okay"), Just (String e)) -> Just e - _ -> Nothing - getEmail _ = Nothing +{-# LANGUAGE OverloadedStrings #-}+module Web.Authenticate.BrowserId+ ( browserIdJs+ , checkAssertion+ ) where++import Data.Text (Text)+import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, withManager, method, urlEncodedBody)+import Data.Aeson (json, Value (Object, String))+import Data.Attoparsec.Lazy (parse, maybeResult)+import qualified Data.HashMap.Lazy as Map+import Data.Text.Encoding (encodeUtf8)++-- | Location of the Javascript file hosted by browserid.org+browserIdJs :: Text+browserIdJs = "https://browserid.org/include.js"++checkAssertion :: Text -- ^ audience+ -> Text -- ^ assertion+ -> IO (Maybe Text)+checkAssertion audience assertion = do+ req' <- parseUrl "https://browserid.org/verify"+ let req = urlEncodedBody+ [ ("audience", encodeUtf8 audience)+ , ("assertion", encodeUtf8 assertion)+ ] req' { method = "POST" }+ res <- withManager $ httpLbs req+ let lbs = responseBody res+ return $ maybeResult (parse json lbs) >>= getEmail+ where+ getEmail (Object o) =+ case (Map.lookup "status" o, Map.lookup "email" o) of+ (Just (String "okay"), Just (String e)) -> Just e+ _ -> Nothing+ getEmail _ = Nothing
Web/Authenticate/Facebook.hs view
@@ -1,115 +1,115 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -module Web.Authenticate.Facebook - ( Facebook (..) - , AccessToken (..) - , getForwardUrlParams - , getForwardUrlWithState - , getForwardUrl - , getAccessToken - , getGraphData - , getGraphData_ - , getLogoutUrl - ) where - -import Network.HTTP.Conduit -import Network.HTTP.Types (parseSimpleQuery) -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as L8 -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) -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) -import Control.Arrow ((***)) - -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) - -getForwardUrlParams :: Facebook -> [(Text, Text)] -> Text -getForwardUrlParams fb params = - TE.decodeUtf8 $ toByteString $ - copyByteString "https://graph.facebook.com/oauth/authorize" - `mappend` - renderQueryText True - ( ("client_id", Just $ facebookClientId fb) - : ("redirect_uri", Just $ facebookRedirectUri fb) - : map (id *** Just) params) - --- Internal function used to simplify getForwardUrl & getForwardUrlWithState -getForwardUrlWithExtra_ :: Facebook -> [Text] -> [(Text, Text)] -> Text -getForwardUrlWithExtra_ fb perms extra = getForwardUrlParams fb $ (if null perms - then id - else (("scope", T.intercalate "," perms):)) extra - -getForwardUrlWithState :: Facebook -> [Text] -> Text -> Text -getForwardUrlWithState fb perms state = getForwardUrlWithExtra_ fb perms [("state", state)] - -getForwardUrl :: Facebook -> [Text] -> Text -getForwardUrl fb perms = getForwardUrlWithExtra_ fb 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 params = parseSimpleQuery $ S8.concat $ L8.toChunks b - case lookup "access_token" params of - Just x -> return $ AccessToken $ T.pack $ S8.unpack x - Nothing -> error $ "Invalid facebook response: " ++ L8.unpack b - -graphUrl :: AccessToken -> Text -> ByteString -graphUrl (AccessToken s) func = - 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 - --- | Logs out the user from their Facebook session. -getLogoutUrl :: AccessToken - -> Text -- ^ URL the user should be directed to in your site domain. - -> Text -- ^ Logout URL in @https://www.facebook.com/@. -getLogoutUrl (AccessToken s) next = - TE.decodeUtf8 $ toByteString $ - copyByteString "https://www.facebook.com/logout.php" - `mappend` renderQueryText True [("next", Just next), ("access_token", Just s)] +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Authenticate.Facebook+ ( Facebook (..)+ , AccessToken (..)+ , getForwardUrlParams+ , getForwardUrlWithState+ , getForwardUrl+ , getAccessToken+ , getGraphData+ , getGraphData_+ , getLogoutUrl+ ) where++import Network.HTTP.Conduit+import Network.HTTP.Types (parseSimpleQuery)+import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as L8+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)+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)+import Control.Arrow ((***))++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)++getForwardUrlParams :: Facebook -> [(Text, Text)] -> Text+getForwardUrlParams fb params =+ TE.decodeUtf8 $ toByteString $+ copyByteString "https://graph.facebook.com/oauth/authorize"+ `mappend`+ renderQueryText True+ ( ("client_id", Just $ facebookClientId fb)+ : ("redirect_uri", Just $ facebookRedirectUri fb)+ : map (id *** Just) params)++-- Internal function used to simplify getForwardUrl & getForwardUrlWithState+getForwardUrlWithExtra_ :: Facebook -> [Text] -> [(Text, Text)] -> Text+getForwardUrlWithExtra_ fb perms extra = getForwardUrlParams fb $ (if null perms+ then id+ else (("scope", T.intercalate "," perms):)) extra++getForwardUrlWithState :: Facebook -> [Text] -> Text -> Text+getForwardUrlWithState fb perms state = getForwardUrlWithExtra_ fb perms [("state", state)]++getForwardUrl :: Facebook -> [Text] -> Text+getForwardUrl fb perms = getForwardUrlWithExtra_ fb 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 params = parseSimpleQuery $ S8.concat $ L8.toChunks b+ case lookup "access_token" params of+ Just x -> return $ AccessToken $ T.pack $ S8.unpack x+ Nothing -> error $ "Invalid facebook response: " ++ L8.unpack b++graphUrl :: AccessToken -> Text -> ByteString+graphUrl (AccessToken s) func =+ 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++-- | Logs out the user from their Facebook session.+getLogoutUrl :: AccessToken+ -> Text -- ^ URL the user should be directed to in your site domain.+ -> Text -- ^ Logout URL in @https://www.facebook.com/@.+getLogoutUrl (AccessToken s) next =+ TE.decodeUtf8 $ toByteString $+ copyByteString "https://www.facebook.com/logout.php"+ `mappend` renderQueryText True [("next", Just next), ("access_token", Just s)]
Web/Authenticate/Internal.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE DeriveDataTypeable #-} -module Web.Authenticate.Internal - ( AuthenticateException (..) - ) where - -import Data.Typeable (Typeable) -import Control.Exception (Exception) - -data AuthenticateException = - RpxnowException String - | NormalizationException String - | DiscoveryException String - | AuthenticationException String - deriving (Show, Typeable) -instance Exception AuthenticateException +{-# LANGUAGE DeriveDataTypeable #-}+module Web.Authenticate.Internal+ ( AuthenticateException (..)+ ) where++import Data.Typeable (Typeable)+import Control.Exception (Exception)++data AuthenticateException =+ RpxnowException String+ | NormalizationException String+ | DiscoveryException String+ | AuthenticationException String+ deriving (Show, Typeable)+instance Exception AuthenticateException
Web/Authenticate/Kerberos.hs view
@@ -1,72 +1,72 @@-{-# LANGUAGE OverloadedStrings #-} --- | Module for using a kerberos authentication service. --- --- Please note that all configuration should have been done --- manually on the machine prior to running the code. --- --- On linux machines the configuration might be in /etc/krb5.conf. --- It's worth checking if the Kerberos service provider (e.g. your university) --- already provide a complete configuration file. --- --- Be certain that you can manually login from a shell by typing --- --- > kinit username --- --- If you fill in your password and the program returns no error code, --- then your kerberos configuration is setup properly. --- Only then can this module be of any use. -module Web.Authenticate.Kerberos - ( loginKerberos - , KerberosAuthResult(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.Maybe (fromJust) -import Control.Monad (msum, guard) -import System.Process (readProcessWithExitCode) -import System.Timeout (timeout) -import System.Exit (ExitCode(..)) - --- | Occurreable results of a Kerberos login -data KerberosAuthResult = Ok - | NoSuchUser - | WrongPassword - | TimeOut - | UnknownError Text - -instance Show KerberosAuthResult where - show Ok = "Login sucessful" - show NoSuchUser = "Wrong username" - show WrongPassword = "Wrong password" - show TimeOut = "kinit respone timeout" - show (UnknownError msg) = "Unkown error: " ++ T.unpack msg - - --- Given the errcode and stderr, return error-value -interpretError :: Int -> Text -> KerberosAuthResult -interpretError _ errmsg = fromJust . msum $ - ["Client not found in Kerberos database while getting" --> NoSuchUser, - "Preauthentication failed while getting" --> WrongPassword, - Just $ UnknownError errmsg] - where - substr --> kError = guard (substr `T.isInfixOf` errmsg) >> Just kError - --- | Given the username and password, try login to Kerberos service -loginKerberos :: Text -- ^ Username - -> Text -- ^ Password - -> IO KerberosAuthResult -loginKerberos username password = do - timedFetch <- timeout (10*1000000) fetch - case timedFetch of - Just res -> return res - Nothing -> return TimeOut - where - fetch :: IO KerberosAuthResult - fetch = do - (exitCode, _out, err) <- readProcessWithExitCode - "kinit" [T.unpack username] (T.unpack password) - case exitCode of - ExitSuccess -> return Ok - ExitFailure x -> return $ interpretError x (T.pack err) - +{-# LANGUAGE OverloadedStrings #-}+-- | Module for using a kerberos authentication service.+--+-- Please note that all configuration should have been done+-- manually on the machine prior to running the code.+--+-- On linux machines the configuration might be in /etc/krb5.conf.+-- It's worth checking if the Kerberos service provider (e.g. your university)+-- already provide a complete configuration file.+--+-- Be certain that you can manually login from a shell by typing+--+-- > kinit username+--+-- If you fill in your password and the program returns no error code,+-- then your kerberos configuration is setup properly.+-- Only then can this module be of any use.+module Web.Authenticate.Kerberos+ ( loginKerberos+ , KerberosAuthResult(..)+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import Data.Maybe (fromJust)+import Control.Monad (msum, guard)+import System.Process (readProcessWithExitCode)+import System.Timeout (timeout)+import System.Exit (ExitCode(..))++-- | Occurreable results of a Kerberos login+data KerberosAuthResult = Ok+ | NoSuchUser+ | WrongPassword+ | TimeOut+ | UnknownError Text++instance Show KerberosAuthResult where+ show Ok = "Login sucessful"+ show NoSuchUser = "Wrong username"+ show WrongPassword = "Wrong password"+ show TimeOut = "kinit respone timeout"+ show (UnknownError msg) = "Unkown error: " ++ T.unpack msg+++-- Given the errcode and stderr, return error-value+interpretError :: Int -> Text -> KerberosAuthResult+interpretError _ errmsg = fromJust . msum $+ ["Client not found in Kerberos database while getting" --> NoSuchUser,+ "Preauthentication failed while getting" --> WrongPassword,+ Just $ UnknownError errmsg]+ where+ substr --> kError = guard (substr `T.isInfixOf` errmsg) >> Just kError++-- | Given the username and password, try login to Kerberos service+loginKerberos :: Text -- ^ Username+ -> Text -- ^ Password+ -> IO KerberosAuthResult+loginKerberos username password = do+ timedFetch <- timeout (10*1000000) fetch+ case timedFetch of+ Just res -> return res+ Nothing -> return TimeOut+ where+ fetch :: IO KerberosAuthResult+ fetch = do+ (exitCode, _out, err) <- readProcessWithExitCode+ "kinit" [T.unpack username] (T.unpack password)+ case exitCode of+ ExitSuccess -> return Ok+ ExitFailure x -> return $ interpretError x (T.pack err)+
Web/Authenticate/OAuth.hs view
@@ -1,298 +1,317 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -module Web.Authenticate.OAuth - ( -- * Data types - OAuth(..), SignMethod(..), Credential(..), OAuthException(..), - -- * Operations for credentials - emptyCredential, insert, delete, inserts, - -- * Signature - signOAuth, genSign, - -- * Url & operation for authentication - authorizeUrl, getAccessToken, getTemporaryCredential, - getTokenCredential, getTemporaryCredentialWithScope, - getAccessTokenProxy, getTemporaryCredentialProxy, - getTokenCredentialProxy, - getAccessToken', getTemporaryCredential', - -- * Utility Methods - paramEncode, addScope, addMaybeProxy - ) where -import Network.HTTP.Conduit -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 Blaze.ByteString.Builder (toByteString) -import Control.Monad.IO.Class (MonadIO) -import Network.HTTP.Types (renderSimpleQuery) -import Data.Conduit (ResourceIO, runResourceT, ($$), ($=), Source) -import qualified Data.Conduit.List as CL -import Data.Conduit.Blaze (builderToByteString) -import Blaze.ByteString.Builder (Builder) - --- | 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 = OAuthException 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 = getTemporaryCredential' id - --- | Get temporary credential for requesting access token with Scope parameter. -getTemporaryCredentialWithScope :: BS.ByteString -- ^ Scope parameter string - -> OAuth -- ^ OAuth Application - -> IO Credential -- ^ Temporay Credential (Request Token & Secret). -getTemporaryCredentialWithScope = getTemporaryCredential' . addScope - -addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m -addScope scope req | BS.null scope = req - | otherwise = urlEncodedBody [("scope", scope)] req - --- | Get temporary credential for requesting access token via the proxy. -getTemporaryCredentialProxy :: Maybe Proxy -- ^ Proxy - -> OAuth -- ^ OAuth Application - -> IO Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredentialProxy p = getTemporaryCredential' $ addMaybeProxy p - -getTemporaryCredential' :: (Request IO -> Request IO) -- ^ Request Hook - -> OAuth -- ^ OAuth Application - -> IO Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredential' hook oa = do - let req = fromJust $ parseUrl $ oauthRequestUri oa - crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential - req' <- signOAuth oa crd $ hook (req { method = "POST" }) - rsp <- withManager . httpLbs $ req' - if statusCode rsp == 200 - then do - let dic = parseSimpleQuery . toStrict . responseBody $ rsp - return $ Credential dic - else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp) - --- | URL to obtain OAuth verifier. -authorizeUrl :: OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential (Request Token & Secret) - -> String -- ^ URL to authorize -authorizeUrl oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True queries) - where queries = case oauthCallback oa of - Nothing -> [("oauth_token", token cr)] - Just callback -> [("oauth_token", token cr), ("oauth_callback", callback)] - --- | Get Access token. -getAccessToken, getTokenCredential - :: OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential with oauth_verifier - -> IO Credential -- ^ Token Credential (Access Token & Secret) -getAccessToken = getAccessToken' id - --- | Get Access token via the proxy. -getAccessTokenProxy, getTokenCredentialProxy - :: Maybe Proxy -- ^ Proxy - -> OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential with oauth_verifier - -> IO Credential -- ^ Token Credential (Access Token & Secret) -getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p - -getAccessToken' :: (Request IO -> Request IO) -- ^ Request Hook - -> OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential with oauth_verifier - -> IO Credential -- ^ Token Credential (Access Token & Secret) -getAccessToken' hook oa cr = do - let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } - rsp <- withManager . httpLbs =<< signOAuth oa cr req - if statusCode rsp == 200 - then do - let dic = parseSimpleQuery . toStrict . responseBody $ rsp - return $ Credential dic - else throwIO . OAuthException $ "Gaining OAuth Token Credential Failed: " ++ BSL.unpack (responseBody rsp) - - -getTokenCredential = getAccessToken -getTokenCredentialProxy = getAccessTokenProxy - -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 = - inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa) - , ("oauth_consumer_key", oauthConsumerKey oa) - , ("oauth_version", "1.0") - ] cred - -genSign :: ResourceIO 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 ((`elem` ["realm", "oauth_token", "oauth_verifier", "oauth_consumer_key", "oauth_signature_method", "oauth_timestamp", "oauth_nonce", "oauth_version", "oauth_callback", "oauth_signature"]) . fst) - --- | Encode a string using the percent encoding method for OAuth. -paramEncode :: BS.ByteString -> BS.ByteString -paramEncode = BS.concatMap escape - where - escape c | isAscii 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 :: ResourceIO 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 = parseSimpleQuery $ queryString req - bsBodyQ <- if isBodyFormEncoded $ requestHeaders req - then liftM parseSimpleQuery $ toLBS (requestBody req) - else return [] - let bsAuthParams = filter ((`elem`["oauth_consumer_key","oauth_token", "oauth_version","oauth_signature_method","oauth_timestamp", "oauth_nonce", "oauth_verifier", "oauth_version","oauth_callback"]).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 - -- parameter encoding method in OAuth is slight different from ordinary one. - -- So this is OK. - return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] - -toLBS :: ResourceIO m => RequestBody m -> m BS.ByteString -toLBS (RequestBodyLBS l) = return $ toStrict l -toLBS (RequestBodyBS s) = return s -toLBS (RequestBodyBuilder _ b) = return $ toByteString b -toLBS (RequestBodySource _ src) = toLBS' src -toLBS (RequestBodySourceChunked src) = toLBS' src - -toLBS' :: ResourceIO m => Source m Builder -> m BS.ByteString -toLBS' src = fmap BS.concat $ runResourceT $ src $= builderToByteString $$ CL.consume - -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 - -addMaybeProxy :: Maybe Proxy -> Request m -> Request m -addMaybeProxy p req = req { proxy = p } +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Web.Authenticate.OAuth+ ( -- * Data types+ OAuth(..), newOAuth, SignMethod(..), Credential(..), OAuthException(..),+ -- * Operations for credentials+ newCredential, emptyCredential, insert, delete, inserts,+ -- * Signature+ signOAuth, genSign,+ -- * Url & operation for authentication+ authorizeUrl, getAccessToken, getTemporaryCredential,+ getTokenCredential, getTemporaryCredentialWithScope,+ getAccessTokenProxy, getTemporaryCredentialProxy,+ getTokenCredentialProxy, + getAccessToken', getTemporaryCredential',+ -- * Utility Methods+ paramEncode, addScope, addMaybeProxy+ ) where+import Network.HTTP.Conduit+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 Blaze.ByteString.Builder (toByteString)+import Control.Monad.IO.Class (MonadIO)+import Network.HTTP.Types (renderSimpleQuery, status200)+import Data.Conduit (ResourceIO, runResourceT, ($$), ($=), Source)+import qualified Data.Conduit.List as CL+import Data.Conduit.Blaze (builderToByteString)+import Blaze.ByteString.Builder (Builder)++-- | Data type for OAuth client (consumer).+-- The default values apply when you use 'newOAuth'+data OAuth = OAuth { oauthServerName :: String -- ^ Service name (You MUST specify)+ , oauthRequestUri :: String -- ^ URI to request temporary credential (You MUST specify)+ , oauthAccessTokenUri :: String -- ^ Uri to obtain access token (You MUST specify)+ , oauthAuthorizeUri :: String -- ^ Uri to authorize (You MUST specify)+ , oauthSignatureMethod :: SignMethod -- ^ Signature Method (default: 'HMACSHA1')+ , oauthConsumerKey :: BS.ByteString -- ^ Consumer key (You MUST specify)+ , oauthConsumerSecret :: BS.ByteString -- ^ Consumer Secret (You MUST specify)+ , oauthCallback :: Maybe BS.ByteString -- ^ Callback uri to redirect after authentication (default: 'Nothing')+ , oauthRealm :: Maybe BS.ByteString -- ^ Optional authorization realm (default: 'Nothing')+ } deriving (Show, Eq, Ord, Read, Data, Typeable)++-- | Default value for OAuth datatype.+-- You must specify at least oauthServerName, URIs and Tokens.+newOAuth :: OAuth+newOAuth = OAuth { oauthSignatureMethod = HMACSHA1+ , oauthCallback = Nothing+ , oauthRealm = Nothing+ }++-- | 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 []++-- | Convenient function to create 'Credential' with OAuth Token and Token Secret.+newCredential :: BS.ByteString -- ^ value for oauth_token+ -> BS.ByteString -- ^ value for oauth_token_secret+ -> Credential+newCredential tok sec = Credential [("oauth_token", tok), ("oauth_token_secret", sec)]++token, tokenSecret :: Credential -> BS.ByteString+token = fromMaybe "" . lookup "oauth_token" . unCredential+tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential++data OAuthException = OAuthException 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 = getTemporaryCredential' id++-- | Get temporary credential for requesting access token with Scope parameter.+getTemporaryCredentialWithScope :: BS.ByteString -- ^ Scope parameter string+ -> OAuth -- ^ OAuth Application+ -> IO Credential -- ^ Temporay Credential (Request Token & Secret).+getTemporaryCredentialWithScope = getTemporaryCredential' . addScope++addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m+addScope scope req | BS.null scope = req+ | otherwise = urlEncodedBody [("scope", scope)] req++-- | Get temporary credential for requesting access token via the proxy.+getTemporaryCredentialProxy :: Maybe Proxy -- ^ Proxy+ -> OAuth -- ^ OAuth Application+ -> IO Credential -- ^ Temporary Credential (Request Token & Secret).+getTemporaryCredentialProxy p = getTemporaryCredential' $ addMaybeProxy p++getTemporaryCredential' :: (Request IO -> Request IO) -- ^ Request Hook+ -> OAuth -- ^ OAuth Application+ -> IO Credential -- ^ Temporary Credential (Request Token & Secret).+getTemporaryCredential' hook oa = do+ let req = fromJust $ parseUrl $ oauthRequestUri oa+ crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential+ req' <- signOAuth oa crd $ hook (req { method = "POST" }) + rsp <- withManager . httpLbs $ req'+ if statusCode rsp == status200+ then do+ let dic = parseSimpleQuery . toStrict . responseBody $ rsp+ return $ Credential dic+ else throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp)++-- | URL to obtain OAuth verifier.+authorizeUrl :: OAuth -- ^ OAuth Application+ -> Credential -- ^ Temporary Credential (Request Token & Secret)+ -> String -- ^ URL to authorize+authorizeUrl oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True queries)+ where queries = case oauthCallback oa of+ Nothing -> [("oauth_token", token cr)]+ Just callback -> [("oauth_token", token cr), ("oauth_callback", callback)]++-- | Get Access token.+getAccessToken, getTokenCredential+ :: OAuth -- ^ OAuth Application+ -> Credential -- ^ Temporary Credential with oauth_verifier+ -> IO Credential -- ^ Token Credential (Access Token & Secret)+getAccessToken = getAccessToken' id++-- | Get Access token via the proxy.+getAccessTokenProxy, getTokenCredentialProxy+ :: Maybe Proxy -- ^ Proxy+ -> OAuth -- ^ OAuth Application+ -> Credential -- ^ Temporary Credential with oauth_verifier+ -> IO Credential -- ^ Token Credential (Access Token & Secret)+getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p++getAccessToken' :: (Request IO -> Request IO) -- ^ Request Hook+ -> OAuth -- ^ OAuth Application+ -> Credential -- ^ Temporary Credential with oauth_verifier+ -> IO Credential -- ^ Token Credential (Access Token & Secret)+getAccessToken' hook oa cr = do+ let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }+ rsp <- withManager . httpLbs =<< signOAuth oa cr req+ if statusCode rsp == status200+ then do+ let dic = parseSimpleQuery . toStrict . responseBody $ rsp+ return $ Credential dic+ else throwIO . OAuthException $ "Gaining OAuth Token Credential Failed: " ++ BSL.unpack (responseBody rsp)+++getTokenCredential = getAccessToken+getTokenCredentialProxy = getAccessTokenProxy++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 prefix (insert "oauth_signature" sign tok) req+ where+ prefix = case oauthRealm oa of+ Nothing -> "OAuth "+ Just v -> "OAuth realm=\"" `BS.append` v `BS.append` "\","++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 =+ inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa)+ , ("oauth_consumer_key", oauthConsumerKey oa)+ , ("oauth_version", "1.0")+ ] cred++genSign :: ResourceIO 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 :: BS.ByteString -> Credential -> Request a -> Request a+addAuthHeader prefix (Credential cred) req =+ req { requestHeaders = insertMap "Authorization" (renderAuthHeader prefix cred) $ requestHeaders req }++renderAuthHeader :: BS.ByteString -> [(BS.ByteString, BS.ByteString)] -> BS.ByteString+renderAuthHeader prefix = (prefix `BS.append`). BS.intercalate "," . map (\(a,b) -> BS.concat [paramEncode a, "=\"", paramEncode b, "\""]) . filter ((`elem` ["oauth_token", "oauth_verifier", "oauth_consumer_key", "oauth_signature_method", "oauth_timestamp", "oauth_nonce", "oauth_version", "oauth_callback", "oauth_signature"]) . fst)++-- | Encode a string using the percent encoding method for OAuth.+paramEncode :: BS.ByteString -> BS.ByteString+paramEncode = BS.concatMap escape+ where+ escape c | isAscii 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 :: ResourceIO 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 = parseSimpleQuery $ queryString req+ bsBodyQ <- if isBodyFormEncoded $ requestHeaders req+ then liftM parseSimpleQuery $ toLBS (requestBody req)+ else return []+ let bsAuthParams = filter ((`elem`["oauth_consumer_key","oauth_token", "oauth_version","oauth_signature_method","oauth_timestamp", "oauth_nonce", "oauth_verifier", "oauth_version","oauth_callback"]).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+ -- parameter encoding method in OAuth is slight different from ordinary one.+ -- So this is OK.+ return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]++toLBS :: ResourceIO m => RequestBody m -> m BS.ByteString+toLBS (RequestBodyLBS l) = return $ toStrict l+toLBS (RequestBodyBS s) = return s+toLBS (RequestBodyBuilder _ b) = return $ toByteString b+toLBS (RequestBodySource _ src) = toLBS' src+toLBS (RequestBodySourceChunked src) = toLBS' src++toLBS' :: ResourceIO m => Source m Builder -> m BS.ByteString+toLBS' src = fmap BS.concat $ runResourceT $ src $= builderToByteString $$ CL.consume++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++addMaybeProxy :: Maybe Proxy -> Request m -> Request m+addMaybeProxy p req = req { proxy = p }
Web/Authenticate/OpenId.hs view
@@ -1,116 +1,116 @@-{-# 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 Control.Monad (unless) -import Data.Text.Lazy.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Data.Text.Lazy (toStrict) -import Network.HTTP.Conduit - ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect - , HttpException, withManager - ) -import Control.Arrow ((***), second) -import Data.List (unfoldr) -import Data.Maybe (fromMaybe) -import Data.Text (Text, pack, unpack) -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Blaze.ByteString.Builder (toByteString) -import Network.HTTP.Types (renderQueryText) -import Data.Monoid (mappend) - -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 <- liftIO $ normalize openid' >>= discover - let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q) - case disc of - Discovery1 server mdelegate -> helper server - $ ("openid.mode", "checkid_setup") - : ("openid.identity", maybe openid' id 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" - helper p - $ ("openid.ns", "http://specs.openid.net/auth/2.0") - : ("openid.mode", "checkid_setup") - : ("openid.claimed_id", i') - : ("openid.identity", i') - : ("openid.return_to", complete) - : ("openid.realm", realm) - : params - -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 <- liftIO $ 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 $ unpack endpoint - let req = urlEncodedBody params' req' - rsp <- liftIO $ withManager $ httpLbsRedirect req - let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp - 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 Control.Monad (unless)+import Data.Text.Lazy.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Text.Lazy (toStrict)+import Network.HTTP.Conduit+ ( parseUrl, urlEncodedBody, responseBody, httpLbs+ , HttpException, withManager+ )+import Control.Arrow ((***), second)+import Data.List (unfoldr)+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Blaze.ByteString.Builder (toByteString)+import Network.HTTP.Types (renderQueryText)+import Data.Monoid (mappend)++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 <- liftIO $ normalize openid' >>= discover+ let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q)+ case disc of+ Discovery1 server mdelegate -> helper server+ $ ("openid.mode", "checkid_setup")+ : ("openid.identity", maybe openid' id 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"+ helper p+ $ ("openid.ns", "http://specs.openid.net/auth/2.0")+ : ("openid.mode", "checkid_setup")+ : ("openid.claimed_id", i')+ : ("openid.identity", i')+ : ("openid.return_to", complete)+ : ("openid.realm", realm)+ : params++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 <- liftIO $ 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 $ unpack endpoint+ let req = urlEncodedBody params' req'+ rsp <- liftIO $ withManager $ httpLbs req+ let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp+ 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,110 +1,107 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# 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.Conduit -import 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 -#if MIN_VERSION_aeson(0, 4, 0) -import qualified Data.HashMap.Lazy as Map -#else -import qualified Data.Map as Map -#endif -import Control.Applicative ((<$>), (<*>)) - --- | 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 - ] - req' <- parseUrl "https://rpxnow.com" - let req = - req' - { method = "POST" - , path = "api/v2/auth_info" - , requestHeaders = - [ ("Content-Type", "application/x-www-form-urlencoded") - ] - , requestBody = RequestBodyLBS body - } - res <- 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" - Identifier - <$> (profile .: "identifier") - <*> return (mapMaybe go (Map.toList profile)) - where - go ("identifier", _) = Nothing - go (k, String v) = Just (k, v) - go _ = Nothing -parseProfile _ = mzero +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# 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.Conduit+import 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 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+#if MIN_VERSION_aeson(0, 4, 0)+import qualified Data.HashMap.Lazy as Map+#else+import qualified Data.Map as Map+#endif+import Control.Applicative ((<$>), (<*>))++-- | 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+ ]+ req' <- parseUrl "https://rpxnow.com"+ let req =+ req'+ { method = "POST"+ , path = "api/v2/auth_info"+ , requestHeaders =+ [ ("Content-Type", "application/x-www-form-urlencoded")+ ]+ , requestBody = RequestBodyLBS body+ }+ res <- liftIO $ withManager $ httpLbs req+ let b = responseBody res+ o <- unResult $ parse json b+ --m <- fromMapping o+ let mstat = flip Data.Aeson.Types.parse o $ \v ->+ case v of+ Object m -> m .: "stat"+ _ -> mzero+ case mstat of+ Success "ok" -> return ()+ Success stat -> 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"+ Identifier+ <$> (profile .: "identifier")+ <*> return (mapMaybe go (Map.toList profile))+ where+ go ("identifier", _) = Nothing+ go (k, String v) = Just (k, v)+ go _ = Nothing+parseProfile _ = mzero
authenticate.cabal view
@@ -1,58 +1,58 @@-name: authenticate -version: 0.11.0.1 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman, Hiromi Ishii, Arash Rouhani -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.6 -build-type: Simple -homepage: http://github.com/yesodweb/authenticate - -library - build-depends: base >= 4 && < 5, - aeson >= 0.5, - http-conduit >= 1.0 && < 1.1, - tagsoup >= 0.12 && < 0.13, - failure >= 0.0.0 && < 0.2, - transformers >= 0.1 && < 0.3, - bytestring >= 0.9 && < 0.10, - network >= 2.2.1 && < 2.4, - case-insensitive >= 0.2, - RSA >= 1.0 && < 1.1, - time >= 1.1, - 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, - xml-conduit >= 0.5 && < 0.6, - blaze-builder >= 0.2 && < 0.4, - attoparsec >= 0.9, - tls >= 0.7 && < 0.9, - containers, - unordered-containers, - process >= 1.0.1.1 && < 1.2, - conduit >= 0.0 && < 0.1, - blaze-builder-conduit >= 0.0 && < 0.1 - exposed-modules: Web.Authenticate.Rpxnow, - Web.Authenticate.OpenId, - Web.Authenticate.BrowserId, - Web.Authenticate.OpenId.Providers, - Web.Authenticate.OAuth, - Web.Authenticate.Facebook - Web.Authenticate.Kerberos - other-modules: Web.Authenticate.Internal, - OpenId2.Discovery, - OpenId2.Normalization, - OpenId2.Types, - OpenId2.XRDS - ghc-options: -Wall - -source-repository head - type: git - location: git://github.com/yesodweb/authenticate.git +name: authenticate+version: 0.11.1+license: BSD3+license-file: LICENSE+author: Michael Snoyman, Hiromi Ishii, Arash Rouhani+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.6+build-type: Simple+homepage: http://github.com/yesodweb/authenticate++library+ build-depends: base >= 4 && < 5,+ aeson >= 0.5,+ http-conduit >= 1.1 && < 1.2,+ tagsoup >= 0.12 && < 0.13,+ failure >= 0.0.0 && < 0.2,+ transformers >= 0.1 && < 0.3,+ bytestring >= 0.9 && < 0.10,+ network >= 2.2.1 && < 2.4,+ case-insensitive >= 0.2,+ RSA >= 1.0 && < 1.1,+ time >= 1.1,+ 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,+ xml-conduit >= 0.5 && < 0.6,+ blaze-builder >= 0.2 && < 0.4,+ attoparsec >= 0.9,+ tls >= 0.7 && < 0.9,+ containers,+ unordered-containers,+ process >= 1.0.1.1 && < 1.2,+ conduit >= 0.0 && < 0.1,+ blaze-builder-conduit >= 0.0 && < 0.1+ exposed-modules: Web.Authenticate.Rpxnow,+ Web.Authenticate.OpenId,+ Web.Authenticate.BrowserId,+ Web.Authenticate.OpenId.Providers,+ Web.Authenticate.OAuth,+ Web.Authenticate.Facebook+ Web.Authenticate.Kerberos+ other-modules: Web.Authenticate.Internal,+ OpenId2.Discovery,+ OpenId2.Normalization,+ OpenId2.Types,+ OpenId2.XRDS+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/yesodweb/authenticate.git