haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Slimmed down code

Browse Source
This commit is contained in:
Michael Snoyman 2010-10-05 09:05:36 +02:00
parent 17b5406fce
commit 0da51855ec
7 changed files with 46 additions and 234 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
OpenId2/Discovery.hs
View File

@ -34,15 +34,14 @@ import Control.Failure (Failure (failure))
-- | Attempt to resolve an OpenID endpoint, and user identifier.
discover :: (MonadIO m, Failure OpenIdException m)
=> Resolver IO
-> Identifier
=> Identifier
-> m (Provider, Identifier)
discover resolve ident@(Identifier i) = do
res1 <- liftIO $ discoverYADIS resolve ident Nothing
discover ident@(Identifier i) = do
res1 <- liftIO $ discoverYADIS ident Nothing
case res1 of
Just x -> return x
Nothing -> do
res2 <- liftIO $ discoverHTML resolve ident
res2 <- liftIO $ discoverHTML ident
case res2 of
Just x -> return x
Nothing -> failure $ DiscoveryException i
@ -51,11 +50,10 @@ discover resolve ident@(Identifier i) = do
-- | Attempt a YADIS based discovery, given a valid identifier. The result is
-- an OpenID endpoint, and the actual identifier for the user.
discoverYADIS :: Resolver IO
-> Identifier
discoverYADIS :: Identifier
-> Maybe String
-> IO (Maybe (Provider,Identifier))
discoverYADIS resolve ident mb_loc = do
discoverYADIS ident mb_loc = do
let uri = fromMaybe (getIdentifier ident) mb_loc
req <- parseUrl uri
res <- httpLbs req
@ -65,7 +63,7 @@ discoverYADIS resolve ident mb_loc = do
case statusCode res of
200 ->
case mloc of
Just loc -> discoverYADIS resolve ident (Just $ S8.unpack loc)
Just loc -> discoverYADIS ident (Just $ S8.unpack loc)
Nothing -> do
let mdoc = parseXRDS $ BSLU.toString $ responseBody res
case mdoc of
@ -91,16 +89,16 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
, ("http://openid.net/signon/1.0" , localId)
, ("http://openid.net/signon/1.1" , localId)
]
uri <- parseProvider =<< listToMaybe (serviceURIs svc)
return (uri,lid)
uri <- listToMaybe $ serviceURIs svc
return (Provider uri, lid)
-- 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 :: Resolver IO -> Identifier -> IO (Maybe (Provider,Identifier))
discoverHTML resolve ident'@(Identifier ident) =
discoverHTML :: Identifier -> IO (Maybe (Provider,Identifier))
discoverHTML ident'@(Identifier ident) =
parseHTML ident' . BSLU.toString <$> simpleHttp ident
-- | Parse out an OpenID endpoint and an actual identifier from an HTML
@ -113,9 +111,9 @@ parseHTML ident = resolve
where
isOpenId (rel,_) = "openid" `isPrefixOf` rel
resolve ls = do
prov <- parseProvider =<< lookup "openid2.provider" ls
prov <- lookup "openid2.provider" ls
let lid = maybe ident Identifier $ lookup "openid2.local_id" ls
return (prov,lid)
return (Provider prov,lid)
-- | Filter out link tags from a list of html tags.

94
OpenId2/HTTP.hs
View File

@ -1,94 +0,0 @@
--------------------------------------------------------------------------------
-- |
-- Module : Network.OpenID.HTTP
-- Copyright : (c) Trevor Elliott, 2008
-- License : BSD3
--
-- Maintainer : Trevor Elliott <trevor@geekgateway.com>
-- Stability :
-- Portability :
--
module OpenId2.HTTP (
-- * Request Interface
makeRequest
-- * Request/Response Parsing and Formatting
, parseDirectResponse
, formatParams
, formatDirectParams
, escapeParam
, addParams
, parseParams
) where
-- friends
import OpenId2.Types
--import Network.OpenID.Utils
-- libraries
import Data.List
import Network.BSD
import Network.Socket
import Network.URI hiding (query)
import Network.HTTP.Enumerator
-- | Perform an http request.
-- If the Bool parameter is set to True, redirects from the server will be
-- followed.
makeRequest :: Bool -> Resolver IO
makeRequest follow = if follow then httpLbsRedirect else httpLbs
-- Parsing and Formatting ------------------------------------------------------
-- | Turn a response body into a list of parameters.
parseDirectResponse :: String -> Params
parseDirectResponse = unfoldr step
where
step [] = Nothing
step str = case split (== '\n') str of
(ps,rest) -> Just (split (== ':') ps,rest)
-- | Format OpenID parameters as a query string
formatParams :: Params -> String
formatParams = intercalate "&" . map f
where f (x,y) = x ++ "=" ++ escapeParam y
-- | Format OpenID parameters as a direct response
formatDirectParams :: Params -> String
formatDirectParams = concatMap f
where f (x,y) = x ++ ":" ++ y ++ "\n"
-- | Escape for the query string of a URI
escapeParam :: String -> String
escapeParam = escapeURIString isUnreserved
-- | Add Parameters to a URI
addParams :: Params -> URI -> URI
addParams ps uri = uri { uriQuery = query }
where
f (k,v) = (k,v)
ps' = map f ps
query = '?' : formatParams (parseParams (uriQuery uri) ++ ps')
-- | Parse OpenID parameters out of a url string
parseParams :: String -> Params
parseParams xs = case split (== '?') xs of
(_,bs) -> unfoldr step bs
where
step [] = Nothing
step bs = case split (== '&') bs of
(as,rest) -> case split (== '=') as of
(k,v) -> Just ((k, unEscapeString v),rest)
split :: (a -> Bool) -> [a] -> ([a],[a])
split p as = case break p as of
(xs,_:ys) -> (xs,ys)
pair -> pair

12
OpenId2/Normalization.hs
View File

@ -21,8 +21,8 @@ import OpenId2.Types
import Control.Applicative
import Control.Monad
import Data.List
import Network.URI hiding (scheme,path)
import Control.Failure (Failure (..))
import Network.URI
normalize :: Failure OpenIdException m => String -> m Identifier
normalize ident =
@ -49,11 +49,11 @@ normalizeIdentifier' xri (Identifier 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
scheme' = uriScheme uri
validScheme = guard (scheme' == "http:" || scheme' == "https:")
u = uri { uriFragment = "", uriPath = path' }
path' | null (uriPath uri) = "/"
| otherwise = uriPath uri
fmt u = Identifier
$ normalizePathSegments

96
OpenId2/Types.hs
View File

@ -11,28 +11,12 @@
--
module OpenId2.Types (
AssocType(..)
, SessionType(..)
, Association(..)
, Params
, ReturnTo
, Realm
, Resolver
, Provider (..)
, parseProvider
, showProvider
, modifyProvider
, Identifier(..)
, Error(..)
, assocString
Provider (..)
, Identifier (..)
, OpenIdException (..)
) where
-- Libraries
import Data.List
import Data.Word
import Network.URI
import Network.HTTP.Enumerator (Request, Response)
import Control.Exception (Exception)
import Data.Typeable (Typeable)
@ -43,83 +27,9 @@ data OpenIdException =
deriving (Show, Typeable)
instance Exception OpenIdException
--------------------------------------------------------------------------------
-- Types
-- | Supported association types
data AssocType = HmacSha1 | HmacSha256
deriving (Read,Show)
assocString :: AssocType -> String
assocString HmacSha1 = "HMAC-SHA1"
assocString HmacSha256 = "HMAC-SHA256"
{-
instance Show AssocType where
show HmacSha1 = "HMAC-SHA1"
show HmacSha256 = "HMAC-SHA256"
instance Read AssocType where
readsPrec _ str | "HMAC-SHA1" `isPrefixOf` str = [(HmacSha1 ,drop 9 str)]
| "HMAC-SHA256" `isPrefixOf` str = [(HmacSha256, drop 11 str)]
| otherwise = []
-}
-- | Session types for association establishment
data SessionType = NoEncryption | DhSha1 | DhSha256
instance Show SessionType where
show NoEncryption = "no-encryption"
show DhSha1 = "DH-SHA1"
show DhSha256 = "DH-SHA256"
instance Read SessionType where
readsPrec _ str
| "no-encryption" `isPrefixOf` str = [(NoEncryption, drop 13 str)]
| "DH-SHA1" `isPrefixOf` str = [(DhSha1, drop 7 str)]
| "DH-SHA256" `isPrefixOf` str = [(DhSha256, drop 9 str)]
| otherwise = []
-- | An association with a provider.
data Association = Association
{ assocExpiresIn :: Int
, assocHandle :: String
, assocMacKey :: [Word8]
, assocType :: AssocType
} deriving (Show,Read)
-- | Parameter lists for communication with the server
type Params = [(String,String)]
-- | A return to path
type ReturnTo = String
-- | A realm of uris for a provider to inform a user about
type Realm = String
-- | A way to resolve an HTTP request
type Resolver m = Request -> m Response
-- | An OpenID provider.
newtype Provider = Provider { providerURI :: URI } deriving (Eq,Show)
-- | Parse a provider
parseProvider :: String -> Maybe Provider
parseProvider = fmap Provider . parseURI
-- | Show a provider
showProvider :: Provider -> String
showProvider (Provider uri) = uriToString (const "") uri []
-- | Modify the URI in a provider
modifyProvider :: (URI -> URI) -> Provider -> Provider
modifyProvider f (Provider uri) = Provider (f uri)
newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)
-- | A valid OpenID identifier.
newtype Identifier = Identifier { getIdentifier :: String }
deriving (Eq,Show,Read)
-- | Errors
newtype Error = Error String deriving Show

17
OpenId2/XRDS.hs
View File

@ -12,13 +12,9 @@
module OpenId2.XRDS (
-- * Types
XRDS, XRD
XRDS
, Service(..)
-- * Utility Functions
, isUsable
, hasType
-- * Parsing
, parseXRDS
) where
@ -48,11 +44,6 @@ data Service = Service
-- Utilities -------------------------------------------------------------------
-- | Check to see if an XRDS service description is usable.
isUsable :: XRDS -> Bool
isUsable = not . null . concat
-- | Generate a tag name predicate, that ignores prefix and namespace.
tag :: String -> Element -> Bool
tag n el = qName (elName el) == n
@ -76,12 +67,6 @@ getText el = case elContent el of
[Text cd] -> cdData cd
_ -> []
-- | Generate a predicate over Service Types.
hasType :: String -> Service -> Bool
hasType ty svc = ty `elem` serviceTypes svc
-- Parsing ---------------------------------------------------------------------

32
Web/Authenticate/OpenId2.hs
View File

@ -8,7 +8,6 @@ module Web.Authenticate.OpenId2
import Control.Monad.IO.Class
import OpenId2.Normalization (normalize)
import OpenId2.Discovery (discover)
import OpenId2.HTTP (makeRequest, parseDirectResponse)
import Control.Failure (Failure (failure))
import OpenId2.Types (OpenIdException (..), Identifier (Identifier),
Provider (Provider))
@ -16,17 +15,18 @@ import Web.Authenticate.Internal (qsUrl)
import Control.Monad (unless)
import qualified Data.ByteString.UTF8 as BSU
import qualified Data.ByteString.Lazy.UTF8 as BSLU
import Network.HTTP.Enumerator (parseUrl, urlEncodedBody, responseBody)
import Network.HTTP.Enumerator
(parseUrl, urlEncodedBody, responseBody, httpLbsRedirect)
import Control.Arrow ((***))
import Data.List (unfoldr)
getForwardUrl :: (MonadIO m, Failure OpenIdException m)
=> String -- ^ The openid the user provided.
-> String -- ^ The URL for this application\'s complete page.
-> m String -- ^ URL to send the user to.
getForwardUrl openid' complete = do
let resolve = makeRequest True
(Provider p, Identifier i) <- normalize openid' >>= discover resolve
return $ qsUrl (show p)
(Provider p, Identifier i) <- normalize openid' >>= discover
return $ qsUrl p
[ ("openid.ns", "http://specs.openid.net/auth/2.0")
, ("openid.mode", "checkid_setup")
, ("openid.claimed_id", i)
@ -49,15 +49,29 @@ authenticate params = do
Just e -> return e
Nothing ->
failure $ AuthenticationException "Missing op_endpoint"
(Provider p, Identifier i) <- normalize ident >>= discover
unless (endpoint == p) $
failure $ AuthenticationException "endpoint does not match discovery"
let params' = map (BSU.fromString *** BSU.fromString)
$ ("openid.mode", "check_authentication")
: filter (\(k, _) -> k /= "openid.mode") params
req' <- liftIO $ parseUrl endpoint
let req = urlEncodedBody params' req'
rsp <- liftIO $ makeRequest True req
rsp <- liftIO $ httpLbsRedirect req
let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp
case lookup "is_valid" rps of
Just "true" -> return ident
Nothing ->
failure $ AuthenticationException "OpenID provider did not validate"
-- FIXME check if endpoint is valid for given identity
_ -> failure $ AuthenticationException "OpenID provider did not validate"
-- | Turn a response body into a list of parameters.
parseDirectResponse :: String -> [(String, String)]
parseDirectResponse = unfoldr step
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

1
authenticate.cabal
View File

@ -31,7 +31,6 @@ library
Web.Authenticate.Facebook
other-modules: Web.Authenticate.Internal,
OpenId2.Discovery,
OpenId2.HTTP,
OpenId2.Normalization,
OpenId2.Types,
OpenId2.XRDS