openid 0.1.4.6 → 0.2.0.0
raw patch · 10 files changed
+372/−214 lines, 10 filesdep +openiddep −nano-hmacdep ~HTTPdep ~HsOpenSSLdep ~basenew-component:exe:openid-test
Dependencies added: openid
Dependencies removed: nano-hmac
Dependency ranges changed: HTTP, HsOpenSSL, base, bytestring, containers, monadLib, network, time, xml
Files
- examples/Makefile +0/−21
- examples/easy.hs +0/−41
- examples/test.hs +5/−5
- openid.cabal +32/−19
- src/Data/Digest/OpenSSL/AlternativeHMAC.hsc +82/−0
- src/Network/OpenID.hs +2/−0
- src/Network/OpenID/AttributeExchange.hs +158/−0
- src/Network/OpenID/Authentication.hs +40/−7
- src/Network/OpenID/Easy.hs +0/−106
- src/Network/OpenID/SSL.hs +53/−15
− examples/Makefile
@@ -1,21 +0,0 @@-GHC=ghc -odir $(ODIR) -hidir $(ODIR) -W-ODIR=.ghc-HSC2HS=hsc2hs-SRC=../src--all : $(ODIR) test--$(ODIR) :- mkdir $(ODIR)--test : $(ODIR)/DH.hs test.hs- $(GHC) -lcrypto -lssl --make test -i$(SRC) $(ODIR)/DH.hs -Wall--$(ODIR)/DH.hs : $(SRC)/Codec/Encryption/DH.hsc- $(HSC2HS) $< -o $@--clean :- $(RM) -r $(ODIR)- $(RM) test--.PHONY : all clean depend
− examples/easy.hs
@@ -1,41 +0,0 @@-import qualified Network.OpenID.Easy as ID-import System.Environment (getArgs)--main = do- -- default set of error handlers just fail on errors- let config = ID.config- - -- ident is the string the user would usually type in a textbox themselves- -- returnTo is the uri the user will be forwarded to after authentication- [ident,returnTo] <- getArgs- - -- authenticate with the remote provider and collect the information- -- necessary to verify the identity- session <- ID.auth config ident returnTo- - -- At this point, session data can be written to a file or a database as a- -- string with show and read back later once the user arrives back at the- -- forwarded page. The Session type derives Read and Show.- - -- The session has records for the normalized identity and provider strings.- putStrLn $ "Normalized Ident: " ++ ID.sIdentity session- putStrLn $ "Provider: " ++ ID.sProvider session- - -- Forward the user along to the authentication uri, or else just copy/paste- -- this link in this command-line demonstration.- putStrLn $ "Forward: " ++ ID.sAuthURI session- - -- Use the uri the user landed back at for the verify step.- -- In a real web application, you'd read this from something like the- -- environment's REQUEST_URI.- putStrLn "Paste the uri you were returned to:"- uri <- getLine- - -- Verify the credentials. The query parameters from the uri are parsed to- -- make sure everything checks out.- -- This step will fail by calling the config's verifyError if the user can't- -- be verified.- ID.verify config session uri- - -- Success!- putStrLn $ "Verified as '" ++ ID.sIdentity session ++ "'!"
examples/test.hs view
@@ -1,12 +1,12 @@ -import MonadLib-import Network.OpenID.HTTP+import Network.OpenID +import MonadLib import Network.Socket import System.Environment+import OpenSSL -main = withSocketsDo $ do- sslInit+main = withSocketsDo $ withOpenSSL $ do [ident,check] <- getArgs case normalizeIdentifier (Identifier ident) of Nothing -> putStrLn "Unable to normalize identifier"@@ -22,7 +22,7 @@ case eam of Left err -> putStrLn $ "associate: " ++ show err Right am -> do- let au = authenticationURI am Setup p i check Nothing+ let au = authenticationURI am Setup p i check Nothing Nothing print au line <- getLine let params = parseParams line
openid.cabal view
@@ -1,6 +1,6 @@ name: openid-version: 0.1.4.6-cabal-version: >= 1.6+version: 0.2.0.0+cabal-version: >= 1.8 synopsis: An implementation of the OpenID-2.0 spec. description: An implementation of the OpenID-2.0 spec. category: Network@@ -12,48 +12,61 @@ license-file: LICENSE build-type: Simple tested-with: GHC == 6.12.1-extra-source-files: examples/Makefile, examples/test.hs examples/easy.hs +flag examples+ default: False+ description: Build an example program flag split-base default: True description: Use the new split base package. +source-repository head+ type: git+ location: git://github.com/elliottt/hsopenid.git+ library- if flag(split-base)- build-depends: base >= 3 && < 10,- bytestring == 0.9.1.*,- containers >= 0.2 && < 0.4- else- build-depends: base < 3- build-depends: HTTP >= 4000.0.5 && < 4000.1,- monadLib == 3.6.*,- nano-hmac == 0.2.*,- network == 2.2.*,- time == 1.1.*,- xml == 1.3.*,- HsOpenSSL == 0.8.*+ build-depends: base >= 4.0.0.0 && < 5.0.0.0,+ bytestring >= 0.9.1.0 && < 0.10.0.0,+ containers >= 0.2.0.0 && < 0.4.1.0,+ HTTP >= 4000.0.9 && < 4000.2,+ monadLib >= 3.6.0.0 && < 3.7.0.0,+ network >= 2.2.0.0 && < 2.3.0.0,+ time >= 1.1.0.0 && < 1.3.0.0,+ xml >= 1.3.0.0 && < 1.4.0.0,+ HsOpenSSL >= 0.9.0.0 && < 0.11.0.0 hs-source-dirs: src exposed-modules: Codec.Binary.Base64, Codec.Encryption.DH,+ Data.Digest.OpenSSL.AlternativeHMAC, Data.Digest.OpenSSL.SHA, Network.OpenID, Network.OpenID.Association, Network.OpenID.Association.Manager, Network.OpenID.Association.Map,+ Network.OpenID.AttributeExchange, Network.OpenID.Authentication, Network.OpenID.Discovery, Network.OpenID.HTTP, Network.OpenID.Normalization,+ Network.OpenID.SSL Network.OpenID.Types, Network.OpenID.Utils,- Network.OpenID.Easy, Text.XRDS- other-modules: Network.OpenID.SSL- ghc-options: -W+ ghc-options: -Wall extensions: EmptyDataDecls, FlexibleContexts, FlexibleInstances, ForeignFunctionInterface, GeneralizedNewtypeDeriving, MultiParamTypeClasses++executable openid-test+ main-is: examples/test.hs++ if flag(examples)+ buildable: True+ build-depends: base, openid, monadLib, network, HsOpenSSL++ else+ buildable: False
+ src/Data/Digest/OpenSSL/AlternativeHMAC.hsc view
@@ -0,0 +1,82 @@+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}++module Data.Digest.OpenSSL.AlternativeHMAC+ ( hmac+ , unsafeHMAC+ , showHMAC+ , CryptoHashFunction()+ , sha+ , sha1+ , sha224+ , sha256+ , sha384+ , sha512+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Numeric (showHex)+import System.IO.Unsafe++import OpenSSL.EVP.Digest++#include <openssl/objects.h>+#include <openssl/evp.h>++-- Types -----------------------------------------------------------------------++newtype CryptoHashFunction = CryptoHashFunction String++-- | Name of the SHA digest, used by getDigestByName+sha :: CryptoHashFunction+sha = CryptoHashFunction (#const_str SN_sha)++-- | Name of the SHA1 digest, used by getDigestByName+sha1 :: CryptoHashFunction+sha1 = CryptoHashFunction (#const_str SN_sha1)++-- | Name of the SHA224 digest, used by getDigestByName+sha224 :: CryptoHashFunction+sha224 = CryptoHashFunction (#const_str SN_sha224)++-- | Name of the SHA256 digest, used by getDigestByName+sha256 :: CryptoHashFunction+sha256 = CryptoHashFunction (#const_str SN_sha256)++-- | Name of the SHA384 digest, used by getDigestByName+sha384 :: CryptoHashFunction+sha384 = CryptoHashFunction (#const_str SN_sha384)++-- | Name of the SHA384 digest, used by getDigestByName+sha512 :: CryptoHashFunction+sha512 = CryptoHashFunction (#const_str SN_sha512)++++-- | Get the hex-string representation of an HMAC+showHMAC :: ByteString -- ^ the HMAC+ -> String -- ^ the hex-string representation+showHMAC bs =+ concatMap draw $ BS.unpack bs+ where+ draw :: (Integral a) => a -> String+ draw w = case showHex w [] of+ [x] -> ['0', x]+ x -> x++-- | Wrapper/rendering function for hmac+unsafeHMAC :: CryptoHashFunction -- ^ the name of the digest+ -> ByteString -- ^ the HMAC key+ -> ByteString -- ^ the data to be signed+ -> String -- ^ the hex-representation of the resulting HMAC+unsafeHMAC h k i = unsafePerformIO (hmac h k i)++hmac :: CryptoHashFunction+ -> ByteString+ -> ByteString+ -> IO String+hmac (CryptoHashFunction s) k i =+ getDigestByName s >>= \ mbDigest ->+ case mbDigest of+ Nothing -> fail "no digest"+ Just d -> return $ showHMAC $ hmacBS d k i
src/Network/OpenID.hs view
@@ -12,6 +12,7 @@ module Network.OpenID ( module Network.OpenID.Association+ , module Network.OpenID.AttributeExchange , module Network.OpenID.Authentication , module Network.OpenID.Discovery , module Network.OpenID.HTTP@@ -22,6 +23,7 @@ -- Friends import Network.OpenID.Association+import Network.OpenID.AttributeExchange import Network.OpenID.Authentication import Network.OpenID.Discovery import Network.OpenID.HTTP
+ src/Network/OpenID/AttributeExchange.hs view
@@ -0,0 +1,158 @@+module Network.OpenID.AttributeExchange (+ AXFieldTy(..),+ AXFieldVal,+ axName, axSpec, axTyFromName,++ axEmailRequired,+ axExtParams,+ axExtParams',+ getAxFields+) where++import Control.Applicative+import Control.Monad (guard)+import Network.OpenID.Types++import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)+import Data.List (intercalate, nub, isPrefixOf)++defaultAlias :: String+defaultAlias = "ax"++extNamespace, extNamespacePrefix, extMode_fetchRequest :: String+extNamespace = "http://openid.net/srv/ax/1.0"+extNamespacePrefix = "http://openid.net/srv/ax/1." +extMode_fetchRequest = "fetch_request"++-- | Some common, useful Attribute Exchange specs.+data AXFieldTy+ = AXBirthdate+ | AXEmail+ | AXFirstName+ | AXFullName+ | AXGender+ | AXLanguage+ | AXLastName+ | AXNickname+ deriving (Eq, Show, Ord, Read)+++axName :: AXFieldTy -> String+axName AXBirthdate = "birthdate"+axName AXEmail = "email"+axName AXFirstName = "firstname"+axName AXFullName = "fullname"+axName AXGender = "gender"+axName AXLanguage = "language"+axName AXLastName = "lastname"+axName AXNickname = "friendly"++axSpec :: AXFieldTy -> String+axSpec AXBirthdate = "http://axschema.org/birthDate"+axSpec AXEmail = "http://axschema.org/contact/email"+axSpec AXFirstName = "http://axschema.org/namePerson/first"+axSpec AXFullName = "http://axschema.org/namePerson"+axSpec AXGender = "http://axschema.org/person/gender"+axSpec AXLanguage = "http://axschema.org/pref/language"+axSpec AXLastName = "http://axschema.org/namePerson/last"+axSpec AXNickname = "http://axschema.org/namePerson/friendly"++axTyFromName :: String -> Maybe AXFieldTy+axTyFromName "birthdate" = Just AXBirthdate+axTyFromName "email" = Just AXEmail+axTyFromName "firstname" = Just AXFirstName+axTyFromName "fullname" = Just AXFullName+axTyFromName "gender" = Just AXGender+axTyFromName "language" = Just AXLanguage+axTyFromName "lastname" = Just AXLastName+axTyFromName "friendly" = Just AXNickname+axTyFromName _ = Nothing+++-- | Used to store responses.+type AXFieldVal = (AXFieldTy, String)+++-- | The simplest use case is to request the user's email. This would be+-- used to replace traditional verification emails.+axEmailRequired :: Params+axEmailRequired = axExtParams [AXEmail]+++-- | Use these functions to roll your own list of fields to request when+-- you send an auth request+axExtParams :: [AXFieldTy] -- ^ params we want them to send in the+ -- "id_res" mode verification+ -> Params+axExtParams = axExtParams' defaultAlias+++-- | specify the alias as well as the list of requested fields+axExtParams' :: String -- ^ alias. it doesn't really matter+ -- what this is as long as we're+ -- consistent+ -> [AXFieldTy] -- ^ params we require in the "id_res"+ -- mode verification+ -> Params+axExtParams' alias extsRequired =+ [ ("openid.ns." ++ alias, extNamespace)+ , ("openid." ++ alias ++ ".mode", extMode_fetchRequest)+ , ("openid." ++ alias ++ ".required", formatRequiredVal extsRequired')+ ] ++ exts+ where+ exts = map (formatRequestField alias) extsRequired'+ extsRequired' = nub extsRequired+++formatRequestField :: String -> AXFieldTy -> (String, String)+formatRequestField alias field =+ ("openid." ++ alias ++ ".type." ++ axName field, axSpec field)+++formatRequiredVal :: [AXFieldTy] -> String+formatRequiredVal =+ intercalate "," . map axName+++-- | Retrieve the requested fields from the HTTP request params. Keep+-- | in mind the spec does not require that the OpenID Provider return+-- | any of our requested fields, even on a successful verification.+getAxFields :: Params -> [AXFieldVal]+getAxFields ps =+ fromMaybe [] fieldsMb+ where+ fieldsMb :: Maybe [AXFieldVal]+ fieldsMb = getAxFields' ps <$> aliasMb++ aliasMb :: Maybe String+ aliasMb = listToMaybe $ mapMaybe getAxAlias ps+++getAxFields' :: Params -> String -> [AXFieldVal]+getAxFields' ps alias =+ mapMaybe getAxFieldTypes' ps+ where+ getAxFieldTypes' :: (String, String) -> Maybe AXFieldVal+ getAxFieldTypes' (n,v) = do+ guard (valueAliasPrefix `isPrefixOf` n)+ ty <- axTyFromName $ drop (length valueAliasPrefix) n+ return (ty,v)++ valueAliasPrefix = "openid." ++ alias ++ ".value."+++-- the server will return a response of the form+-- openid.ALIAS.value.email: "foobar"+-- openid.ALIAS.type.email: "http://axschema.org/contact/email"+-- ...+--+-- the value of the alias may vary from request to request, depending+-- on how many extensions are enabled, but we haven't seen them vary+-- the fields. for example, if we requested the email, with the field+-- alias "email" in the request then it comes back under value.email+-- and type.email. the other libraries I've seen assume this as well+-- so we'll just go with that.+getAxAlias :: (String, String) -> Maybe String+getAxAlias (n,v) = do+ guard ("openid.ns." `isPrefixOf` n && extNamespacePrefix `isPrefixOf` v)+ return (drop (length "openid.ns.") n)
src/Network/OpenID/Authentication.hs view
@@ -26,6 +26,7 @@ import Network.OpenID.HTTP import Network.OpenID.Types import Network.OpenID.Utils+import qualified Data.Digest.OpenSSL.AlternativeHMAC as HMAC -- libraries import Data.List@@ -33,9 +34,7 @@ import Network.HTTP import Network.URI import Numeric- import qualified Data.ByteString as BS-import qualified Data.Digest.OpenSSL.HMAC as HMAC --------------------------------------------------------------------------------@@ -78,11 +77,44 @@ -------------------------------------------------------------------------------- -- Authentication --- | Generate an authentication URL-authenticationURI :: AssociationManager am- => am -> CheckIdMode -> Provider -> Identifier -> ReturnTo- -> Maybe Realm -> URI-authenticationURI am mode prov ident rt mb_realm =+-- | Generate an authentication URL. The params field allows you to+-- | specify any extensions, for example, AttributeExchange.+authenticationURI :: AssociationManager am =>++ am -- ^ Your pre-established assocations++ -> CheckIdMode -- ^ Use this if you want to try to+ -- use OpenID's Immediate mode. Some+ -- providers won't ever let this+ -- mode succeed, whereas some won't+ -- even prompt the user in Setup+ -- mode and go straight for the+ -- redirect. It is safe to use the+ -- Setup mode only.++ -> Provider -- ^ The OpenID provider's (e.g+ -- Google or Yahoo) OpenID URI++ -> Identifier -- ^ The identity URI you are trying+ -- to verify. Please note that a+ -- number of providers no longer+ -- encode their services' usernames+ -- into the URI.++ -> ReturnTo -- ^ After the user verifies that+ -- they are indeed "them" with the+ -- OpenID provider, where should+ -- said provider redirect them?++ -> Maybe Params -- ^ Additional params for OpenID+ -- extensions. You can use this to+ -- verify a user's email using+ -- Attribute Extensions.++ -> Maybe Realm++ -> URI+authenticationURI am mode prov ident rt mb_exts mb_realm = addParams params (providerURI prov) where params = [ ("openid.ns", openidNS)@@ -91,6 +123,7 @@ , ("openid.identity", getIdentifier ident) , ("openid.return_to", rt) ] ++ ah +++ maybe [] id mb_exts ++ maybe [] (\r -> [("openid.realm", r)]) mb_realm ah = case findAssociation am prov of Nothing -> []
− src/Network/OpenID/Easy.hs
@@ -1,106 +0,0 @@------------------------------------------------------------------------------------- |--- Module : Network.OpenID.Easy--- Copyright : (c) James Halliday, 2009--- License : BSD3------ Maintainer : James Halliday <substack@gmail.com>--- Stability : --- Portability : -----module Network.OpenID.Easy (- Config(..),- Session(..),- auth, verify, config, readSession-) where--import Network.OpenID-import Network.Socket (withSocketsDo)- --- | Provides configuration settings for verify and auth. For now, this is just--- the errors which may be thrown by either.-data Config = Config {- verifyError :: String -> IO (),- normalizeError :: IO Session,- discoverError, associateError :: String -> IO Session-}---- | Provide default configuration with error handlers that just fail with a--- useful message when errors happen. This behavior is what most people would--- probably end up writing themselves anyways.-config :: Config-config = Config {- normalizeError = fail "Unable to normalize identifier",- discoverError = fail . ("Discovery Error: " ++),- associateError = fail . ("Associate Error: " ++),- verifyError = fail . ("Verify Error: " ++)-}---- | Wrap up all the data necessary to do a verify into one place, plus some--- extra useful stuff.-data Session = Session {- -- | the authentication uri to send the client off to- sAuthURI :: String,- -- | the OpenID provider as a string- sProvider :: String,- -- | the normalized OpenID identity as a string- sIdentity :: String,- -- | the uri the client will come back to after authenticating- sReturnTo :: String,- -- | the association map manager thing used internally- sAssocMap :: AssociationMap-} deriving (Read,Show)--readSession :: String -> Session-readSession = read---- | Given a configuration, identity, and return uri,--- contact the remote provider to create a Session object encapsulating the--- useful bits of data to pass along to verify and also to pick out the--- normalized identity from.-auth :: Config -> String -> String -> IO Session-auth config ident returnTo = withSocketsDo $ do- -- this bit is heavily based on the old examples/test.hs- case normalizeIdentifier (Identifier ident) of- Nothing -> normalizeError config- Just normalizedIdent -> do- let resolve = makeRequest True- rpi <- discover resolve normalizedIdent- case rpi of- Left err -> discoverError config $ show err- Right (provider,identifier) -> do- -- either an error or an association manager- eam <- associate emptyAssociationMap True resolve provider- case eam of- Left err -> associateError config $ show err- Right am ->- return $ Session {- sAuthURI = show $ authenticationURI- am Setup provider identifier returnTo Nothing,- sProvider = show $ providerURI provider,- sIdentity = getIdentifier identifier,- sReturnTo = returnTo,- sAssocMap = am- }---- use this to resolve stuff in auth and verify-resolver :: Resolver IO-resolver = makeRequest True---- | Given a configuration, a Session generated by auth, and the uri that the--- client came back on from the provider, make sure the client properly--- authenticated by running verifyError on failure to verify the credentials.-verify :: Config -> Session -> String -> IO ()-verify config session uri = do- let- params = parseParams uri- verified <- verifyAuthentication- (sAssocMap session)- params- (sReturnTo session)- resolver- case verified of- Left err -> verifyError config $ show err- Right _ -> return ()
src/Network/OpenID/SSL.hs view
@@ -16,6 +16,7 @@ ) where import OpenSSL.Session as Session+import Control.Exception as E import Network.Socket import Network.Stream import qualified Data.ByteString as B@@ -26,27 +27,64 @@ data SSLHandle = SSLHandle SSLContext SSL -wrap m = Right `fmap` m `catch` handler- where handler = return . Left . ErrorMisc . show+wrap m = Right `fmap` m `Prelude.catch` handler+ where+ handler err = return $ Left $ ErrorMisc $ "write: " ++ show err +wrapRead m = Right `fmap` m `catches` handlers+ where+ handlers :: [Handler (Either ConnError String)]+ handlers =+ [ Handler ((\_ -> return $ Right "")+ :: (ConnectionAbruptlyTerminated -> IO (Either ConnError String)))+ , Handler ((\x -> return $ Left $ ErrorMisc $ "read: " ++ show x)+ :: (SomeException -> IO (Either ConnError String)))+ ]++-- The problem is that the OpenSSL library doesn't know that in some+-- cases, the HTTP server will rudely close its side of the write+-- socket once a complete HTTP response has been transmitted. In fact,+-- the server will also terminate its read end once we've sent a+-- complete header, but the HTTP driver doesn't seem to mind about+-- that bit. All this seems to be standard practice (regardless of+-- whether it is considered correct by SSL or not), so we should just+-- treat it as an EOF.+-- +-- In the meantime, the Network.HTTP driver will stop reading on an+-- empty input (NOT an empty line terminated by a "\n"), so we should+-- return that.+ instance Stream SSLHandle where- readLine sh = wrap (upd `fmap` sslReadWhile (/= c) sh)+ readLine sh =+ wrapRead (upd `fmap` sslReadWhile (/= c) sh) where- c = toEnum (fromEnum '\n')+ c = toEnum (fromEnum '\n') upd bs = map (toEnum . fromEnum) bs ++ "\n"- readBlock (SSLHandle _ ssl) n = wrap $ (map w2c . B.unpack) <$> Session.read ssl n- writeBlock (SSLHandle _ ssl) bs = wrap $ Session.write ssl $ B.pack $ map c2w $ bs- close (SSLHandle _ ssl) = Session.shutdown ssl Bidirectional `catch` \_ -> return () + readBlock (SSLHandle _ ssl) n =+ wrapRead ((map w2c . B.unpack) <$> Session.read ssl n)++ writeBlock (SSLHandle _ ssl) bs+ | not (null bs) = wrap $ Session.write ssl $ B.pack $ map c2w $ bs+ | otherwise = return $ Right ()++ -- should this really ignore all exceptions?+ close (SSLHandle _ ssl) = Session.shutdown ssl Bidirectional+ `E.catch` ((\_ -> return ()) :: SomeException -> IO ())++ closeOnEnd _ _ = return ()+ sslConnect :: Socket -> IO (Maybe SSLHandle)-sslConnect sock = do- catch (do- ctx <- Session.context- ssl <- Session.connection ctx sock- Session.connect ssl- return $ Just $ SSLHandle ctx ssl- )- (\_ -> return Nothing)+sslConnect sock = body `E.catch` handler+ where+ body = do+ ctx <- Session.context+ ssl <- Session.connection ctx sock+ Session.connect ssl+ return $ Just $ SSLHandle ctx ssl++ handler :: SomeException -> IO (Maybe SSLHandle)+ handler _ = return Nothing sslReadWhile :: (Word8 -> Bool) -> SSLHandle -> IO [Word8] sslReadWhile pred (SSLHandle _ ssl) = rw