authenticate 0.11.0 → 0.11.0.1
raw patch · 15 files changed
+1218/−1219 lines, 15 filessetup-changed
Files
- LICENSE +25/−25
- OpenId2/Discovery.hs +144/−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 +298/−299
- Web/Authenticate/OpenId.hs +116/−116
- Web/Authenticate/OpenId/Providers.hs +44/−44
- Web/Authenticate/Rpxnow.hs +110/−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,144 @@-{-# 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 ((<$>), (<*>)) + +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
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,299 +1,298 @@-{-# 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 Control.Arrow (second)-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 = map (second $ fromMaybe "") $ 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(..), 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 }
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, 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
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,110 @@-{-# 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 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
authenticate.cabal view
@@ -1,58 +1,58 @@-name: authenticate-version: 0.11.0-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.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