{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE OverloadedStrings #-}moduleWeb.Authenticate.OpenId(-- * FunctionsgetForwardUrl,authenticate,authenticateClaimed-- * Types,AuthenticateException(..),Identifier(..)-- ** Response,OpenIdResponse,oirOpLocal,oirParams,oirClaimed)whereimportControl.Monad.IO.ClassimportOpenId2.Normalization(normalize)importOpenId2.Discovery(discover,Discovery(..))importOpenId2.TypesimportControl.Monad(unless)importqualifiedData.TextasTimportData.Text.Lazy.Encoding(decodeUtf8With)importData.Text.Encoding.Error(lenientDecode)importData.Text.Lazy(toStrict)importNetwork.HTTP.Conduit(parseUrl,urlEncodedBody,responseBody,httpLbs,Manager)importControl.Arrow((***),second)importData.List(unfoldr)importData.Maybe(fromMaybe)importData.Text(Text,pack,unpack)importData.Text.Encoding(encodeUtf8,decodeUtf8)importBlaze.ByteString.Builder(toByteString)importNetwork.HTTP.Types(renderQueryText)importControl.Exception(throwIO)importData.Conduit(MonadBaseControl,MonadResource)getForwardUrl::(MonadResourcem,MonadBaseControlIOm)=>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.->Manager->mText-- ^ URL to send the user to.getForwardUrlopenid'completemrealmparamsmanager=doletrealm=fromMaybecompletemrealmclaimed<-normalizeopenid'disc<-discoverclaimedmanagerlethelpersq=return$T.concat[s,if"?"`T.isInfixOf`sthen"&"else"?",decodeUtf8(toByteString$renderQueryTextFalse$map(secondJust)q)]casediscofDiscovery1servermdelegate->helperserver$("openid.mode","checkid_setup"):("openid.identity",maybe(identifierclaimed)idmdelegate):("openid.return_to",complete):("openid.realm",realm):("openid.trust_root",complete):paramsDiscovery2(Providerp)(Identifieri)itype->dolet(claimed',identity')=caseitypeofClaimedIdent->(identifierclaimed,i)OPIdent->letx="http://specs.openid.net/auth/2.0/identifier_select"in(x,x)helperp$("openid.ns","http://specs.openid.net/auth/2.0"):("openid.mode","checkid_setup"):("openid.claimed_id",claimed'):("openid.identity",identity'):("openid.return_to",complete):("openid.realm",realm):paramsauthenticate::(MonadBaseControlIOm,MonadResourcem,MonadIOm)=>[(Text,Text)]->Manager->m(Identifier,[(Text,Text)])authenticatepsm=dox<-authenticateClaimedpsmreturn(oirOpLocalx,oirParamsx){-# DEPRECATED authenticate "Use authenticateClaimed" #-}dataOpenIdResponse=OpenIdResponse{oirOpLocal::Identifier,oirParams::[(Text,Text)],oirClaimed::MaybeIdentifier}authenticateClaimed::(MonadBaseControlIOm,MonadResourcem,MonadIOm)=>[(Text,Text)]->Manager->mOpenIdResponseauthenticateClaimedparamsmanager=dounless(lookup"openid.mode"params==Just"id_res")$liftIO$throwIO$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->liftIO$throwIO$AuthenticationException"Missing identity"discOP<-normalizeident>>=flipdiscovermanagerletendpointd=casedofDiscovery1p_->pDiscovery2(Providerp)__->pletparams'=map(encodeUtf8***encodeUtf8)$("openid.mode","check_authentication"):filter(\(k,_)->k/="openid.mode")paramsreq'<-liftIO$parseUrl$unpack$endpointdiscOPletreq=urlEncodedBodyparams'req'rsp<-httpLbsreqmanagerletrps=parseDirectResponse$toStrict$decodeUtf8WithlenientDecode$responseBodyrspclaimed<-caselookup"openid.claimed_id"paramsofNothing->returnNothingJustclaimed'->do-- need to validate that this provider can speak for the given-- claimed identifierclaimedN<-normalizeclaimed'discC<-discoverclaimedNmanagerreturn$ifendpointdiscOP==endpointdiscCthenJustclaimedNelseNothingcaselookup"is_valid"rpsofJust"true"->returnOpenIdResponse{oirOpLocal=Identifierident,oirParams=rps,oirClaimed=claimed}_->liftIO$throwIO$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