{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE OverloadedStrings #-}moduleWeb.Authenticate.OpenId(getForwardUrl,authenticate,AuthenticateException(..),Identifier(..))whereimportControl.Monad.IO.ClassimportOpenId2.Normalization(normalize)importOpenId2.Discovery(discover,Discovery(..))importControl.Failure(Failure(failure))importOpenId2.TypesimportWeb.Authenticate.Internal(qsUrl)importControl.Monad(unless)importqualifiedData.ByteString.UTF8asBSUimportqualifiedData.ByteString.Lazy.UTF8asBSLUimportNetwork.HTTP.Enumerator(parseUrl,urlEncodedBody,responseBody,httpLbsRedirect,HttpException,withManager)importControl.Arrow((***))importData.List(unfoldr)importData.Maybe(fromMaybe)importData.Text(Text,pack,unpack)importData.Text.Encoding(encodeUtf8)getForwardUrl::(MonadIOm,FailureAuthenticateExceptionm,FailureHttpExceptionm)=>Text-- ^ The openid the user provided.->Text-- ^ The URL for this application\'s complete page.->MaybeText-- ^ Optional realm->[(Text,Text)]-- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.->mText-- ^ URL to send the user to.getForwardUrlopenid'completemrealmparams=doletrealm=fromMaybecompletemrealmdisc<-normalizeopenid'>>=discovercasediscofDiscovery1servermdelegate->return$pack$qsUrlserver$map(unpack***unpack)-- FIXME$("openid.mode","checkid_setup"):("openid.identity",maybeopenid'packmdelegate):("openid.return_to",complete):("openid.realm",realm):("openid.trust_root",complete):paramsDiscovery2(Providerp)(Identifieri)itype->doleti'=caseitypeofClaimedIdent->iOPIdent->"http://specs.openid.net/auth/2.0/identifier_select"return$pack$qsUrlp$("openid.ns","http://specs.openid.net/auth/2.0"):("openid.mode","checkid_setup"):("openid.claimed_id",unpacki'):("openid.identity",unpacki'):("openid.return_to",unpackcomplete):("openid.realm",unpackrealm):map(unpack***unpack)paramsauthenticate::(MonadIOm,FailureAuthenticateExceptionm,FailureHttpExceptionm)=>[(Text,Text)]->m(Identifier,[(Text,Text)])authenticateparams=dounless(lookup"openid.mode"params==Just"id_res")$failure$caselookup"openid.mode"paramsofNothing->AuthenticationException"openid.mode was not found in the params."(Justm)|m=="error"->caselookup"openid.error"paramsofNothing->AuthenticationException"An error occurred, but no error message was provided."(Juste)->AuthenticationException$unpacke|otherwise->AuthenticationException$"mode is "++unpackm++" but we were expecting id_res."ident<-caselookup"openid.identity"paramsofJusti->returniNothing->failure$AuthenticationException"Missing identity"disc<-normalizeident>>=discoverletendpoint=casediscofDiscovery1p_->pDiscovery2(Providerp)__->pletparams'=map(encodeUtf8***encodeUtf8)$("openid.mode","check_authentication"):filter(\(k,_)->k/="openid.mode")paramsreq'<-parseUrlendpointletreq=urlEncodedBodyparams'req'rsp<-liftIO$withManager$httpLbsRedirectreqletrps=parseDirectResponse$pack$BSLU.toString$responseBodyrsp-- FIXMEcaselookup"is_valid"rpsofJust"true"->return(Identifierident,rps)_->failure$AuthenticationException"OpenID provider did not validate"-- | Turn a response body into a list of parameters.parseDirectResponse::Text->[(Text,Text)]parseDirectResponse=map(pack***pack).unfoldrstep.unpackwherestep[]=Nothingstepstr=casesplit(=='\n')strof(ps,rest)->Just(split(==':')ps,rest)split::(a->Bool)->[a]->([a],[a])splitpas=casebreakpasof(xs,_:ys)->(xs,ys)pair->pair