OpenID v2 support.

All of the heavy lifting was taken directly from the openid package, and
lives in the OpenId2.* module hierarchy. The difference here is that we
don't use associations at all, removing the need for some hefty
dependencies. I've also gutted MonadLib dependencies.

.gitignore

@@ -1,2 +1,3 @@
 *.swp
 dist
+client_session_key.aes

OpenId2/Discovery.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Network.OpenID.Discovery
+-- Copyright   : (c) Trevor Elliott, 2008
+-- License     : BSD3
+--
+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
+-- Stability   :
+-- Portability :
+--
+
+module OpenId2.Discovery (
+    -- * Discovery
+    discover
+  ) where
+
+-- Friends
+import OpenId2.Types
+import OpenId2.XRDS
+
+-- Libraries
+import Data.Char
+import Data.List
+import Data.Maybe
+import Network.HTTP.Enumerator
+import qualified Data.ByteString.Lazy.UTF8 as BSLU
+import qualified Data.ByteString.Char8 as S8
+import Control.Arrow (first)
+import Control.Applicative ((<$>))
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Failure (Failure (failure))
+
+-- | Attempt to resolve an OpenID endpoint, and user identifier.
+discover :: (MonadIO m, Failure OpenIdException m)
+         => Resolver IO
+         -> Identifier
+         -> m (Provider, Identifier)
+discover resolve ident@(Identifier i) = do
+    res1 <- liftIO $ discoverYADIS resolve ident Nothing
+    case res1 of
+        Just x -> return x
+        Nothing -> do
+            res2 <- liftIO $ discoverHTML resolve ident
+            case res2 of
+                Just x -> return x
+                Nothing -> failure $ DiscoveryException 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 :: Resolver IO
+              -> Identifier
+              -> Maybe String
+              -> IO (Maybe (Provider,Identifier))
+discoverYADIS resolve ident mb_loc = do
+    let uri = fromMaybe (getIdentifier ident) mb_loc
+    req <- parseUrl uri
+    res <- httpLbs req
+    let mloc = lookup "x-xrds-location"
+             $ map (first $ map toLower . S8.unpack)
+             $ responseHeaders res
+    case statusCode res of
+        200 ->
+          case mloc of
+            Just loc -> discoverYADIS resolve ident (Just $ S8.unpack loc)
+            Nothing  -> do
+              let mdoc = parseXRDS $ BSLU.toString $ 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)
+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 <- listToMaybe $ mapMaybe f
+      [ ("http://specs.openid.net/auth/2.0/server", ident)
+      -- claimed identifiers
+      , ("http://specs.openid.net/auth/2.0/signon", localId)
+      , ("http://openid.net/signon/1.0"           , localId)
+      , ("http://openid.net/signon/1.1"           , localId)
+      ]
+    uri <- parseProvider =<< listToMaybe (serviceURIs svc)
+    return (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) =
+    parseHTML ident' . BSLU.toString <$> simpleHttp ident
+
+-- | Parse out an OpenID endpoint and an actual identifier from an HTML
+-- document.
+parseHTML :: Identifier -> String -> Maybe (Provider,Identifier)
+parseHTML ident = resolve
+                . filter isOpenId
+                . linkTags
+                . htmlTags
+  where
+    isOpenId (rel,_) = "openid" `isPrefixOf` rel
+    resolve ls = do
+      prov <- parseProvider =<< lookup "openid2.provider" ls
+      let lid = maybe ident Identifier $ lookup "openid2.local_id" ls
+      return (prov,lid)
+
+
+-- | Filter out link tags from a list of html tags.
+linkTags :: [String] -> [(String,String)]
+linkTags  = mapMaybe f . filter p
+  where
+    p = ("link " `isPrefixOf`)
+    f xs = do
+      let ys = unfoldr splitAttr (drop 5 xs)
+      x <- lookup "rel"  ys
+      y <- lookup "href" ys
+      return (x,y)
+
+
+-- | Split a string into strings of html tags.
+htmlTags :: String -> [String]
+htmlTags [] = []
+htmlTags xs = case break (== '<') xs of
+  (as,_:bs) -> fmt as : htmlTags bs
+  (as,[])   -> [as]
+  where
+    fmt as = case break (== '>') as of
+      (bs,_) -> bs
+
+
+-- | Split out values from a key="value" like string, in a way that
+-- is suitable for use with unfoldr.
+splitAttr :: String -> Maybe ((String,String),String)
+splitAttr xs = case break (== '=') xs of
+  (_,[])         -> Nothing
+  (key,_:'"':ys) -> f key (== '"') ys
+  (key,_:ys)     -> f key isSpace  ys
+  where
+  f key p cs = case break p cs of
+      (_,[])         -> Nothing
+      (value,_:rest) -> Just ((key,value), dropWhile isSpace rest)

OpenId2/HTTP.hs

@@ -0,0 +1,94 @@
+
+--------------------------------------------------------------------------------
+-- |
+-- 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

OpenId2/Normalization.hs

@@ -0,0 +1,62 @@
+{-# 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 Network.URI hiding (scheme,path)
+import Control.Failure (Failure (..))
+
+normalize :: Failure OpenIdException m => String -> m Identifier
+normalize ident =
+    case normalizeIdentifier $ Identifier ident of
+        Just i -> return i
+        Nothing -> failure $ NormalizationException 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 `fmap` xri str
+  | head str `elem` "=@+$!"   = Identifier `fmap` xri str
+  | otherwise = fmt `fmap` (url >>= norm)
+  where
+    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
+          $ normalizePathSegments
+          $ normalizeEscape
+          $ normalizeCase
+          $ uriToString (const "") u []

OpenId2/Types.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Network.OpenID.Types
+-- Copyright   : (c) Trevor Elliott, 2008
+-- License     : BSD3
+--
+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
+-- Stability   : 
+-- Portability : 
+--
+
+module OpenId2.Types (
+    AssocType(..)
+  , SessionType(..)
+  , Association(..)
+  , Params
+  , ReturnTo
+  , Realm
+  , Resolver
+  , Provider (..)
+  , parseProvider
+  , showProvider
+  , modifyProvider
+  , Identifier(..)
+  , Error(..)
+  , assocString
+  , 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)
+
+data OpenIdException =
+      NormalizationException String
+    | DiscoveryException String
+    | AuthenticationException String
+  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)
+
+-- | A valid OpenID identifier.
+newtype Identifier = Identifier { getIdentifier :: String }
+  deriving (Eq,Show,Read)
+
+-- | Errors
+newtype Error = Error String deriving Show

OpenId2/XRDS.hs

@@ -0,0 +1,116 @@
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Text.XRDS
+-- Copyright   : (c) Trevor Elliott, 2008
+-- License     : BSD3
+--
+-- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
+-- Stability   :
+-- Portability :
+--
+
+module OpenId2.XRDS (
+    -- * Types
+    XRDS, XRD
+  , Service(..)
+
+    -- * Utility Functions
+  , isUsable
+  , hasType
+
+    -- * Parsing
+  , parseXRDS
+  ) where
+
+-- Libraries
+import Control.Arrow
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Text.XML.Light
+
+
+-- Types -----------------------------------------------------------------------
+
+type XRDS = [XRD]
+
+type XRD = [Service]
+
+data Service = Service
+  { serviceTypes      :: [String]
+  , serviceMediaTypes :: [String]
+  , serviceURIs       :: [String]
+  , serviceLocalIDs   :: [String]
+  , servicePriority   :: Maybe Int
+  , serviceExtra      :: [Element]
+  } deriving Show
+
+-- 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
+
+
+-- | Filter the attributes of an element by some predicate
+findAttr' :: (QName -> Bool) -> Element -> Maybe String
+findAttr' p el = attrVal `fmap` find (p . attrKey) (elAttribs el)
+
+
+-- | Read, maybe
+readMaybe :: Read a => String -> Maybe a
+readMaybe str = case reads str of
+  [(x,"")] -> Just x
+  _        -> Nothing
+
+
+-- | Get the text of an element
+getText :: Element -> String
+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 ---------------------------------------------------------------------
+
+
+parseXRDS :: String -> Maybe XRDS
+parseXRDS str = do
+  doc <- parseXMLDoc str
+  let xrds = filterChildren (tag "XRD") doc
+  return $ map parseXRD xrds
+
+
+parseXRD :: Element -> XRD
+parseXRD el =
+  let svcs = filterChildren (tag "Service") el
+   in mapMaybe parseService svcs
+
+
+parseService :: Element -> Maybe Service
+parseService el = do
+  let vals t x = first (map getText) $ partition (tag t) x
+      (tys,tr)    = vals "Type"      (elChildren el)
+      (mts,mr)    = vals "MediaType" tr
+      (uris,ur)   = vals "URI"       mr
+      (lids,rest) = vals "LocalID"   ur
+      priority = readMaybe =<< findAttr' (("priority" ==) . qName) el
+  guard $ not $ null tys
+  return $ Service { serviceTypes      = tys
+                   , serviceMediaTypes = mts
+                   , serviceURIs       = uris
+                   , serviceLocalIDs   = lids
+                   , servicePriority   = priority
+                   , serviceExtra      = rest
+                   }

Web/Authenticate/Internal.hs

@@ -1,9 +1,18 @@
 module Web.Authenticate.Internal
     ( qsEncode
+    , qsUrl
     ) where
 
 import Codec.Binary.UTF8.String (encode)
 import Numeric (showHex)
+import Data.List (intercalate)
+
+qsUrl :: String -> [(String, String)] -> String
+qsUrl s [] = s
+qsUrl url pairs =
+    url ++ "?" ++ intercalate "&" (map qsPair pairs)
+  where
+    qsPair (x, y) = qsEncode x ++ '=' : qsEncode y 
 
 qsEncode :: String -> String
 qsEncode =

Web/Authenticate/OpenId.hs

@@ -31,7 +31,7 @@ import Control.Failure hiding (Error)
 import Control.Exception
 import Control.Monad (liftM, unless)
 import qualified Data.ByteString.Lazy.Char8 as L8
-import Web.Authenticate.Internal (qsEncode)
+import Web.Authenticate.Internal (qsUrl)
 import Data.List (intercalate)
 
 -- | An openid identifier (ie, a URL).
@@ -60,7 +60,7 @@ getForwardUrl openid complete = do
     server <- getOpenIdVar "server" bodyIdent
     let delegate = maybe openid id
                  $ getOpenIdVar "delegate" bodyIdent
-    return $ constructUrl server
+    return $ qsUrl server
                         [ ("openid.mode", "checkid_setup")
                         , ("openid.identity", delegate)
                         , ("openid.return_to", complete)
@@ -81,13 +81,6 @@ getOpenIdVar var content = do
         mhead [] = failure $ MissingVar $ "openid." ++ var
         mhead (x:_) = return x
 
-constructUrl :: String -> [(String, String)] -> String
-constructUrl url [] = url
-constructUrl url args =
-    url ++ "?" ++ intercalate "&" (map qsPair args)
-  where
-    qsPair (x, y) = qsEncode x ++ '=' : qsEncode y 
-
 -- | Handle a redirect from an OpenID provider and check that the user
 -- logged in properly. If it was successfully, 'return's the openid.
 -- Otherwise, 'failure's an explanation.
@@ -140,7 +133,7 @@ getAuthUrl req = do
                 "return_to"
                 ]
             let sargs = [("openid.mode", "check_authentication")]
-            return $ constructUrl server $ dargs ++ sargs
+            return $ qsUrl server $ dargs ++ sargs
         makeArg s = do
             let k = "openid." ++ s
             v <- alookup k req

Web/Authenticate/OpenId2.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Web.Authenticate.OpenId2
+    ( getForwardUrl
+    , authenticate
+    , OpenIdException (..)
+    ) where
+
+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))
+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 Control.Arrow ((***))
+
+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)
+        [ ("openid.ns", "http://specs.openid.net/auth/2.0")
+        , ("openid.mode", "checkid_setup")
+        , ("openid.claimed_id", i)
+        , ("openid.identity", i)
+        , ("openid.return_to", complete)
+        ]
+
+authenticate :: (MonadIO m, Failure OpenIdException m)
+             => [(String, String)]
+             -> m String
+authenticate params = do
+    unless (lookup "openid.mode" params == Just "id_res")
+        $ failure $ AuthenticationException "mode is not id_res"
+    ident <- case lookup "openid.identity" params of
+                Just i -> return i
+                Nothing ->
+                    failure $ AuthenticationException "Missing identity"
+    endpoint <-
+        case lookup "openid.op_endpoint" params of
+            Just e -> return e
+            Nothing ->
+                failure $ AuthenticationException "Missing op_endpoint"
+    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
+    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

authenticate.cabal

@@ -1,5 +1,5 @@
 name:            authenticate
-version:         0.6.5
+version:         0.6.6
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -22,9 +22,17 @@ library
                      failure >= 0.0.0 && < 0.2,
                      transformers >= 0.1 && < 0.3,
                      bytestring >= 0.9 && < 0.10,
-                     utf8-string >= 0.3 && < 0.4
+                     utf8-string >= 0.3 && < 0.4,
+                     network >= 2.2.1 && < 2.3,
+                     xml >= 1.3.7 && < 1.4
     exposed-modules: Web.Authenticate.Rpxnow,
                      Web.Authenticate.OpenId,
+                     Web.Authenticate.OpenId2,
                      Web.Authenticate.Facebook
-    other-modules:   Web.Authenticate.Internal
+    other-modules:   Web.Authenticate.Internal,
+                     OpenId2.Discovery,
+                     OpenId2.HTTP,
+                     OpenId2.Normalization,
+                     OpenId2.Types,
+                     OpenId2.XRDS
     ghc-options:     -Wall

openid2.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE TypeFamilies, QuasiQuotes #-}
+import Yesod
+import Web.Authenticate.OpenId2
+import Data.Object
+import Data.Maybe (fromMaybe)
+import Network.HTTP.Enumerator
+
+data OID = OID
+mkYesod "OID" [$parseRoutes|
+/ RootR GET
+/forward ForwardR GET
+/complete CompleteR GET
+|]
+
+instance Yesod OID where approot _ = "http://localhost:3000"
+
+getRootR = defaultLayout [$hamlet|
+%form!action=@ForwardR@
+    OpenId: 
+    %input!type=text!name=openid_identifier!value="http://"
+    %input!type=submit
+|]
+
+getForwardR = do
+    openid <- runFormGet' $ stringInput "openid_identifier"
+    render <- getUrlRender
+    url <- liftIO $ getForwardUrl openid $ render CompleteR
+    redirectString RedirectTemporary url
+    return ()
+
+getCompleteR = do
+    params <- reqGetParams `fmap` getRequest
+    ident <- liftIO $ authenticate params
+    return $ RepPlain $ toContent ident
+
+main = withHttpEnumerator $ basicHandler 3000 OID