diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -1,144 +1,145 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Discovery --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -module OpenId2.Discovery ( - -- * Discovery - discover - , Discovery (..) - ) where - --- Friends -import OpenId2.Types -import OpenId2.XRDS - -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 +-- 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 diff --git a/OpenId2/Normalization.hs b/OpenId2/Normalization.hs --- a/OpenId2/Normalization.hs +++ b/OpenId2/Normalization.hs @@ -1,68 +1,68 @@ -{-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Normalization --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -module OpenId2.Normalization - ( normalize - ) where - --- Friends -import OpenId2.Types - --- Libraries -import Control.Applicative -import Control.Monad -import Data.List -import 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 +-- 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 [] diff --git a/OpenId2/Types.hs b/OpenId2/Types.hs --- a/OpenId2/Types.hs +++ b/OpenId2/Types.hs @@ -1,34 +1,34 @@ -{-# LANGUAGE DeriveDataTypeable #-} --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Types --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -module OpenId2.Types ( - Provider (..) - , Identifier (..) - , IdentType (..) - , AuthenticateException (..) - ) where - --- Libraries -import Data.Data (Data) -import Data.Typeable (Typeable) -import Web.Authenticate.Internal -import Data.Text (Text) - --- | An OpenID provider. -newtype Provider = Provider { providerURI :: Text } deriving (Eq,Show) - --- | A valid OpenID identifier. -newtype Identifier = Identifier { identifier :: Text } - deriving (Eq, Ord, Show, Read, Data, Typeable) - -data IdentType = OPIdent | ClaimedIdent - deriving (Eq, Ord, Show, Read, Data, Typeable) +{-# LANGUAGE DeriveDataTypeable #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Network.OpenID.Types +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.Types ( + Provider (..) + , Identifier (..) + , IdentType (..) + , AuthenticateException (..) + ) where + +-- Libraries +import Data.Data (Data) +import Data.Typeable (Typeable) +import Web.Authenticate.Internal +import Data.Text (Text) + +-- | An OpenID provider. +newtype Provider = Provider { providerURI :: Text } deriving (Eq,Show) + +-- | A valid OpenID identifier. +newtype Identifier = Identifier { identifier :: Text } + deriving (Eq, Ord, Show, Read, Data, Typeable) + +data IdentType = OPIdent | ClaimedIdent + deriving (Eq, Ord, Show, Read, Data, Typeable) diff --git a/OpenId2/XRDS.hs b/OpenId2/XRDS.hs --- a/OpenId2/XRDS.hs +++ b/OpenId2/XRDS.hs @@ -1,77 +1,77 @@ -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- | --- Module : Text.XRDS --- Copyright : (c) Trevor Elliott, 2008 --- License : BSD3 --- --- Maintainer : Trevor Elliott --- Stability : --- Portability : --- - -module OpenId2.XRDS ( - -- * Types - XRDS - , Service(..) - - -- * Parsing - , parseXRDS - ) where - --- Libraries -import Control.Monad ((>=>)) -import Data.Maybe (listToMaybe) -import Text.XML (parseLBS, def) -import Text.XML.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute) -import qualified Data.ByteString.Lazy as L -import Data.Text (Text) -import qualified Data.Text.Read - --- Types ----------------------------------------------------------------------- - -type XRDS = [XRD] - -type XRD = [Service] - -data Service = Service - { serviceTypes :: [Text] - , serviceMediaTypes :: [Text] - , serviceURIs :: [Text] - , serviceLocalIDs :: [Text] - , servicePriority :: Maybe Int - } deriving Show - -parseXRDS :: L.ByteString -> Maybe XRDS -parseXRDS str = - either - (const Nothing) - (Just . parseXRDS' . fromDocument) - (parseLBS def str) - -parseXRDS' :: Cursor -> [[Service]] -parseXRDS' = element "{xri://$xrds}XRDS" &/ - element "{xri://$xrd*($v*2.0)}XRD" &| - parseXRD - -parseXRD :: Cursor -> [Service] -parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService - -parseService :: Cursor -> [Service] -parseService c = - if null types then [] else [Service - { serviceTypes = types - , serviceMediaTypes = mtypes - , serviceURIs = uris - , serviceLocalIDs = localids - , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe - }] - where - types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content - mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content - uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content - localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content - readMaybe t = - case Data.Text.Read.signed Data.Text.Read.decimal t of - Right (i, "") -> Just i - _ -> Nothing +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Text.XRDS +-- Copyright : (c) Trevor Elliott, 2008 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- Stability : +-- Portability : +-- + +module OpenId2.XRDS ( + -- * Types + XRDS + , Service(..) + + -- * Parsing + , parseXRDS + ) where + +-- Libraries +import Control.Monad ((>=>)) +import Data.Maybe (listToMaybe) +import Text.XML (parseLBS, def) +import Text.XML.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute) +import qualified Data.ByteString.Lazy as L +import Data.Text (Text) +import qualified Data.Text.Read + +-- Types ----------------------------------------------------------------------- + +type XRDS = [XRD] + +type XRD = [Service] + +data Service = Service + { serviceTypes :: [Text] + , serviceMediaTypes :: [Text] + , serviceURIs :: [Text] + , serviceLocalIDs :: [Text] + , servicePriority :: Maybe Int + } deriving Show + +parseXRDS :: L.ByteString -> Maybe XRDS +parseXRDS str = + either + (const Nothing) + (Just . parseXRDS' . fromDocument) + (parseLBS def str) + +parseXRDS' :: Cursor -> [[Service]] +parseXRDS' = element "{xri://$xrds}XRDS" &/ + element "{xri://$xrd*($v*2.0)}XRD" &| + parseXRD + +parseXRD :: Cursor -> [Service] +parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService + +parseService :: Cursor -> [Service] +parseService c = + if null types then [] else [Service + { serviceTypes = types + , serviceMediaTypes = mtypes + , serviceURIs = uris + , serviceLocalIDs = localids + , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe + }] + where + types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content + mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content + uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content + localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content + readMaybe t = + case Data.Text.Read.signed Data.Text.Read.decimal t of + Right (i, "") -> Just i + _ -> Nothing diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/Web/Authenticate/BrowserId.hs b/Web/Authenticate/BrowserId.hs --- a/Web/Authenticate/BrowserId.hs +++ b/Web/Authenticate/BrowserId.hs @@ -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 diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -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)] diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs --- a/Web/Authenticate/Internal.hs +++ b/Web/Authenticate/Internal.hs @@ -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 diff --git a/Web/Authenticate/Kerberos.hs b/Web/Authenticate/Kerberos.hs --- a/Web/Authenticate/Kerberos.hs +++ b/Web/Authenticate/Kerberos.hs @@ -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) + diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -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 } diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -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 diff --git a/Web/Authenticate/OpenId/Providers.hs b/Web/Authenticate/OpenId/Providers.hs --- a/Web/Authenticate/OpenId/Providers.hs +++ b/Web/Authenticate/OpenId/Providers.hs @@ -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/" diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -1,110 +1,107 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} ---------------------------------------------------------- --- --- Module : Web.Authenticate.Rpxnow --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Unstable --- Portability : portable --- --- Facilitates authentication with "http://rpxnow.com/". --- ---------------------------------------------------------- -module Web.Authenticate.Rpxnow - ( Identifier (..) - , authenticate - , AuthenticateException (..) - ) where - -import Data.Aeson -import Network.HTTP.Conduit -import Control.Monad.IO.Class -import 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 +-- 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 diff --git a/authenticate.cabal b/authenticate.cabal --- a/authenticate.cabal +++ b/authenticate.cabal @@ -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 -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 +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