module Web.Authenticate.OpenId
(
getForwardUrl
, authenticate
, authenticateClaimed
, AuthenticateException (..)
, Identifier (..)
, OpenIdResponse
, oirOpLocal
, oirParams
, oirClaimed
) where
import Control.Monad.IO.Class
import OpenId2.Normalization (normalize)
import OpenId2.Discovery (discover, Discovery (..))
import OpenId2.Types
import Control.Monad (unless)
import qualified Data.Text as T
import Data.Text.Lazy.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Lazy (toStrict)
import Network.HTTP.Conduit
( parseUrl, urlEncodedBody, responseBody, httpLbs
, Manager
)
import Control.Arrow ((***), second)
import Data.List (unfoldr)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Blaze.ByteString.Builder (toByteString)
import Network.HTTP.Types (renderQueryText)
import Control.Exception (throwIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (MonadResource)
getForwardUrl
:: (MonadResource m, MonadBaseControl IO m)
=> Text
-> Text
-> Maybe Text
-> [(Text, Text)]
-> Manager
-> m Text
getForwardUrl openid' complete mrealm params manager = do
let realm = fromMaybe complete mrealm
claimed <- normalize openid'
disc <- discover claimed manager
let helper s q = return $ T.concat
[ s
, if "?" `T.isInfixOf` s then "&" else "?"
, decodeUtf8 (toByteString $ renderQueryText False $ map (second Just) q)
]
case disc of
Discovery1 server mdelegate -> helper server
$ ("openid.mode", "checkid_setup")
: ("openid.identity", maybe (identifier claimed) id mdelegate)
: ("openid.return_to", complete)
: ("openid.realm", realm)
: ("openid.trust_root", complete)
: params
Discovery2 (Provider p) (Identifier i) itype -> do
let (claimed', identity') =
case itype of
ClaimedIdent -> (identifier claimed, i)
OPIdent ->
let x = "http://specs.openid.net/auth/2.0/identifier_select"
in (x, x)
helper p
$ ("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)
: params
authenticate
:: (MonadBaseControl IO m, MonadResource m, MonadIO m)
=> [(Text, Text)]
-> Manager
-> m (Identifier, [(Text, Text)])
authenticate ps m = do
x <- authenticateClaimed ps m
return (oirOpLocal x, oirParams x)
data OpenIdResponse = OpenIdResponse
{ oirOpLocal :: Identifier
, oirParams :: [(Text, Text)]
, oirClaimed :: Maybe Identifier
}
authenticateClaimed
:: (MonadBaseControl IO m, MonadResource m, MonadIO m)
=> [(Text, Text)]
-> Manager
-> m OpenIdResponse
authenticateClaimed params manager = do
unless (lookup "openid.mode" params == Just "id_res")
$ liftIO $ throwIO $ case lookup "openid.mode" params of
Nothing -> AuthenticationException "openid.mode was not found in the params."
(Just m)
| m == "error" ->
case lookup "openid.error" params of
Nothing -> AuthenticationException "An error occurred, but no error message was provided."
(Just e) -> AuthenticationException $ unpack e
| otherwise -> AuthenticationException $ "mode is " ++ unpack m ++ " but we were expecting id_res."
ident <- case lookup "openid.identity" params of
Just i -> return i
Nothing ->
liftIO $ throwIO $ AuthenticationException "Missing identity"
discOP <- normalize ident >>= flip discover manager
let endpoint d =
case d of
Discovery1 p _ -> p
Discovery2 (Provider p) _ _ -> p
let params' = map (encodeUtf8 *** encodeUtf8)
$ ("openid.mode", "check_authentication")
: filter (\(k, _) -> k /= "openid.mode") params
req' <- liftIO $ parseUrl $ unpack $ endpoint discOP
let req = urlEncodedBody params' req'
rsp <- httpLbs req manager
let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp
claimed <-
case lookup "openid.claimed_id" params of
Nothing -> return Nothing
Just claimed' -> do
claimedN <- normalize claimed'
discC <- discover claimedN manager
return $
if endpoint discOP == endpoint discC
then Just claimedN
else Nothing
case lookup "is_valid" rps of
Just "true" -> return OpenIdResponse
{ oirOpLocal = Identifier ident
, oirParams = rps
, oirClaimed = claimed
}
_ -> liftIO $ throwIO $ AuthenticationException "OpenID provider did not validate"
parseDirectResponse :: Text -> [(Text, Text)]
parseDirectResponse =
map (pack *** pack) . unfoldr step . unpack
where
step [] = Nothing
step str = case split (== '\n') str of
(ps,rest) -> Just (split (== ':') ps,rest)
split :: (a -> Bool) -> [a] -> ([a],[a])
split p as = case break p as of
(xs,_:ys) -> (xs,ys)
pair -> pair