diff --git a/examples/easy.hs b/examples/easy.hs new file mode 100644 --- /dev/null +++ b/examples/easy.hs @@ -0,0 +1,41 @@ +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,7 +1,6 @@ import MonadLib -import Network.OpenID -import Network.SSL +import Network.OpenID.HTTP import Network.Socket import System.Environment diff --git a/openid.cabal b/openid.cabal --- a/openid.cabal +++ b/openid.cabal @@ -1,5 +1,5 @@ name: openid -version: 0.1.3.0 +version: 0.1.4.6 cabal-version: >= 1.6 synopsis: An implementation of the OpenID-2.0 spec. description: An implementation of the OpenID-2.0 spec. @@ -11,8 +11,8 @@ license: BSD3 license-file: LICENSE build-type: Simple -tested-with: GHC == 6.8.2 -extra-source-files: examples/Makefile, examples/test.hs +tested-with: GHC == 6.12.1 +extra-source-files: examples/Makefile, examples/test.hs examples/easy.hs flag split-base @@ -23,16 +23,16 @@ if flag(split-base) build-depends: base >= 3 && < 10, bytestring == 0.9.1.*, - containers == 0.2.* + containers >= 0.2 && < 0.4 else build-depends: base < 3 build-depends: HTTP >= 4000.0.5 && < 4000.1, - monadLib == 3.5.*, + monadLib == 3.6.*, nano-hmac == 0.2.*, network == 2.2.*, time == 1.1.*, xml == 1.3.*, - HsOpenSSL == 0.6.* + HsOpenSSL == 0.8.* hs-source-dirs: src exposed-modules: Codec.Binary.Base64, Codec.Encryption.DH, @@ -47,6 +47,7 @@ Network.OpenID.Normalization, Network.OpenID.Types, Network.OpenID.Utils, + Network.OpenID.Easy, Text.XRDS other-modules: Network.OpenID.SSL ghc-options: -W diff --git a/src/Data/Digest/OpenSSL/SHA.hs b/src/Data/Digest/OpenSSL/SHA.hs --- a/src/Data/Digest/OpenSSL/SHA.hs +++ b/src/Data/Digest/OpenSSL/SHA.hs @@ -1,4 +1,3 @@ -{-# INCLUDE #-} {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} -------------------------------------------------------------------------------- diff --git a/src/Network/OpenID/Association.hs b/src/Network/OpenID/Association.hs --- a/src/Network/OpenID/Association.hs +++ b/src/Network/OpenID/Association.hs @@ -37,7 +37,6 @@ -- Libraries import Data.Bits -import Data.List import Data.Maybe import Data.Time import Data.Word @@ -168,7 +167,7 @@ let body = formatParams $ ("openid.ns", openidNS) : ("openid.mode", "associate") - : ("openid.assoc_type", show at) + : ("openid.assoc_type", assocString at) : ("openid.session_type", show st) : maybe [] dhPairs mb_dh ersp <- lift $ resolve $ Network.OpenID.HTTP.postRequest (providerURI prov) body diff --git a/src/Network/OpenID/Association/Map.hs b/src/Network/OpenID/Association/Map.hs --- a/src/Network/OpenID/Association/Map.hs +++ b/src/Network/OpenID/Association/Map.hs @@ -12,7 +12,7 @@ module Network.OpenID.Association.Map ( -- Association Map - AssociationMap + AssociationMap(..) , emptyAssociationMap ) where @@ -27,7 +27,7 @@ -- | A simple association manager based on Data.Map newtype AssociationMap = AM (Map.Map String (UTCTime,Association)) - deriving Show + deriving (Show,Read) instance AssociationManager AssociationMap where findAssociation (AM m) p = snd `fmap` Map.lookup (showProvider p) m diff --git a/src/Network/OpenID/Easy.hs b/src/Network/OpenID/Easy.hs new file mode 100644 --- /dev/null +++ b/src/Network/OpenID/Easy.hs @@ -0,0 +1,106 @@ + +-------------------------------------------------------------------------------- +-- | +-- 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/Types.hs b/src/Network/OpenID/Types.hs --- a/src/Network/OpenID/Types.hs +++ b/src/Network/OpenID/Types.hs @@ -25,10 +25,10 @@ , modifyProvider , Identifier(..) , Error(..) + , assocString ) where -- Libraries -import Control.Monad import Data.List import Data.Word import Network.URI @@ -41,16 +41,22 @@ -- | 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" + 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 @@ -74,7 +80,7 @@ , assocHandle :: String , assocMacKey :: [Word8] , assocType :: AssocType - } deriving Show + } deriving (Show,Read) -- | Parameter lists for communication with the server diff --git a/src/Network/OpenID/Utils.hs b/src/Network/OpenID/Utils.hs --- a/src/Network/OpenID/Utils.hs +++ b/src/Network/OpenID/Utils.hs @@ -36,9 +36,7 @@ -- libraries import Data.Bits -import Data.Char import Data.List -import Data.Maybe import Data.Word import MonadLib import Network.HTTP