diff --git a/examples/Makefile b/examples/Makefile deleted file mode 100644 --- a/examples/Makefile +++ /dev/null @@ -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 diff --git a/examples/easy.hs b/examples/easy.hs deleted file mode 100644 --- a/examples/easy.hs +++ /dev/null @@ -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 ++ "'!" diff --git a/examples/test.hs b/examples/test.hs --- a/examples/test.hs +++ b/examples/test.hs @@ -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 diff --git a/openid.cabal b/openid.cabal --- a/openid.cabal +++ b/openid.cabal @@ -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 diff --git a/src/Data/Digest/OpenSSL/AlternativeHMAC.hsc b/src/Data/Digest/OpenSSL/AlternativeHMAC.hsc new file mode 100644 --- /dev/null +++ b/src/Data/Digest/OpenSSL/AlternativeHMAC.hsc @@ -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 +#include + +-- 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 diff --git a/src/Network/OpenID.hs b/src/Network/OpenID.hs --- a/src/Network/OpenID.hs +++ b/src/Network/OpenID.hs @@ -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 diff --git a/src/Network/OpenID/AttributeExchange.hs b/src/Network/OpenID/AttributeExchange.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/AttributeExchange.hs @@ -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) diff --git a/src/Network/OpenID/Authentication.hs b/src/Network/OpenID/Authentication.hs --- a/src/Network/OpenID/Authentication.hs +++ b/src/Network/OpenID/Authentication.hs @@ -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 -> [] diff --git a/src/Network/OpenID/Easy.hs b/src/Network/OpenID/Easy.hs deleted file mode 100644 --- a/src/Network/OpenID/Easy.hs +++ /dev/null @@ -1,106 +0,0 @@ - --------------------------------------------------------------------------------- --- | --- Module : Network.OpenID.Easy --- Copyright : (c) James Halliday, 2009 --- License : BSD3 --- --- Maintainer : James Halliday --- 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 () diff --git a/src/Network/OpenID/SSL.hs b/src/Network/OpenID/SSL.hs --- a/src/Network/OpenID/SSL.hs +++ b/src/Network/OpenID/SSL.hs @@ -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