{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
module Yesod.Auth.OpenId
    ( authOpenId
    , forwardUrl
    , claimedKey
    , opLocalKey
    , credsIdentClaimed
    , IdentifierType (..)
    ) where

import Yesod.Auth
import qualified Web.Authenticate.OpenId as OpenId

import Yesod.Form
import Yesod.Core
import Data.Text (Text, isPrefixOf)
import qualified Yesod.Auth.Message as Msg
import UnliftIO.Exception (tryAny)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T

forwardUrl :: AuthRoute
forwardUrl :: AuthRoute
forwardUrl = Text -> Texts -> AuthRoute
PluginR Text
"openid" [Text
"forward"]

data IdentifierType = Claimed | OPLocal

authOpenId :: YesodAuth master
           => IdentifierType
           -> [(Text, Text)] -- ^ extension fields
           -> AuthPlugin master
authOpenId :: IdentifierType -> [(Text, Text)] -> AuthPlugin master
authOpenId IdentifierType
idType [(Text, Text)]
extensionFields =
    Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
"openid" Text -> Texts -> AuthHandler master TypedContent
forall master. Text -> Texts -> AuthHandler master TypedContent
dispatch (AuthRoute -> Route master) -> WidgetFor master ()
forall site.
YesodAuth site =>
(AuthRoute -> Route site) -> WidgetFor site ()
login
  where
    complete :: AuthRoute
complete = Text -> Texts -> AuthRoute
PluginR Text
"openid" [Text
"complete"]

    name :: Text
    name :: Text
name = Text
"openid_identifier"

    login :: (AuthRoute -> Route site) -> WidgetFor site ()
login AuthRoute -> Route site
tm = do
        Text
ident <- WidgetFor site Text
forall (m :: * -> *). MonadHandler m => m Text
newIdent
        -- FIXME this is a hack to get GHC 7.6's type checker to allow the
        -- code, but it shouldn't be necessary
        let y :: a -> [(Text, Text)] -> Text
            y :: a -> [(Text, Text)] -> Text
y = a -> [(Text, Text)] -> Text
forall a. HasCallStack => a
undefined
        ((Route site -> [(Text, Text)] -> Text) -> Css)
-> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget (\Route site -> [(Text, Text)] -> Text
x -> [cassius|##{ident}
    background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
    padding-left: 18px;
|] ((Route site -> [(Text, Text)] -> Text) -> Css)
-> (Route site -> [(Text, Text)] -> Text) -> Css
forall a b. (a -> b) -> a -> b
$ Route site -> [(Text, Text)] -> Text
x (Route site -> [(Text, Text)] -> Text)
-> (Route site -> [(Text, Text)] -> Text)
-> Route site
-> [(Text, Text)]
-> Text
forall a. a -> a -> a
`asTypeOf` Route site -> [(Text, Text)] -> Text
forall a. a -> [(Text, Text)] -> Text
y)
        [whamlet|
$newline never
<form method="get" action="@{tm forwardUrl}">
    <input type="hidden" name="openid_identifier" value="http://me.yahoo.com">
    <button .openid-yahoo>_{Msg.LoginYahoo}
<form method="get" action="@{tm forwardUrl}">
    <label for="#{ident}">OpenID: #
    <input id="#{ident}" type="text" name="#{name}" value="http://">
    <input type="submit" value="_{Msg.LoginOpenID}">
|]

    dispatch :: Text -> [Text] -> AuthHandler master TypedContent
    dispatch :: Text -> Texts -> AuthHandler master TypedContent
dispatch Text
"GET" [Text
"forward"] = do
        Maybe Text
roid <- FormInput m (Maybe Text) -> m (Maybe Text)
forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputGet (FormInput m (Maybe Text) -> m (Maybe Text))
-> FormInput m (Maybe Text) -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Field m Text -> Text -> FormInput m (Maybe Text)
forall (m :: * -> *) a.
Monad m =>
Field m a -> Text -> FormInput m (Maybe a)
iopt Field m Text
forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
name
        case Maybe Text
roid of
            Just Text
oid -> do
                AuthRoute -> Route master
tm <- m (AuthRoute -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                Route master -> Text
render <- m (Route master -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
                let complete' :: Text
complete' = Route master -> Text
render (Route master -> Text) -> Route master -> Text
forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route master
tm AuthRoute
complete
                Manager
manager <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
                Either SomeException Text
eres <- m Text -> m (Either SomeException Text)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (m Text -> m (Either SomeException Text))
-> m Text -> m (Either SomeException Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text -> [(Text, Text)] -> Manager -> m Text
forall (m :: * -> *).
MonadIO m =>
Text -> Text -> Maybe Text -> [(Text, Text)] -> Manager -> m Text
OpenId.getForwardUrl Text
oid Text
complete' Maybe Text
forall a. Maybe a
Nothing [(Text, Text)]
extensionFields Manager
manager
                case Either SomeException Text
eres of
                    Left SomeException
err -> Route (HandlerSite m) -> Text -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage (AuthRoute -> Route master
tm AuthRoute
LoginR) (Text -> m TypedContent) -> Text -> m TypedContent
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
err
                    Right Text
x -> Text -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Text
x
            Maybe Text
Nothing -> AuthRoute -> AuthMessage -> AuthHandler master TypedContent
forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.NoOpenID
    dispatch Text
"GET" [Text
"complete", Text
""] = Text -> Texts -> AuthHandler master TypedContent
forall master. Text -> Texts -> AuthHandler master TypedContent
dispatch Text
"GET" [Text
"complete"] -- compatibility issues
    dispatch Text
"GET" [Text
"complete"] = do
        YesodRequest
rr <- m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
        IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
forall master.
IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper IdentifierType
idType ([(Text, Text)] -> AuthHandler master TypedContent)
-> [(Text, Text)] -> AuthHandler master TypedContent
forall a b. (a -> b) -> a -> b
$ YesodRequest -> [(Text, Text)]
reqGetParams YesodRequest
rr
    dispatch Text
"POST" [Text
"complete", Text
""] = Text -> Texts -> AuthHandler master TypedContent
forall master. Text -> Texts -> AuthHandler master TypedContent
dispatch Text
"POST" [Text
"complete"] -- compatibility issues
    dispatch Text
"POST" [Text
"complete"] = do
        ([(Text, Text)]
posts, [(Text, FileInfo)]
_) <- m ([(Text, Text)], [(Text, FileInfo)])
forall (m :: * -> *).
MonadHandler m =>
m ([(Text, Text)], [(Text, FileInfo)])
runRequestBody
        IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
forall master.
IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper IdentifierType
idType [(Text, Text)]
posts
    dispatch Text
_ Texts
_ = m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound

completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper IdentifierType
idType [(Text, Text)]
gets' = do
    Manager
manager <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
    Either SomeException OpenIdResponse
eres <- m OpenIdResponse -> m (Either SomeException OpenIdResponse)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (m OpenIdResponse -> m (Either SomeException OpenIdResponse))
-> m OpenIdResponse -> m (Either SomeException OpenIdResponse)
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> Manager -> m OpenIdResponse
forall (m :: * -> *).
MonadIO m =>
[(Text, Text)] -> Manager -> m OpenIdResponse
OpenId.authenticateClaimed [(Text, Text)]
gets' Manager
manager
    (SomeException -> m TypedContent)
-> (OpenIdResponse -> m TypedContent)
-> Either SomeException OpenIdResponse
-> m TypedContent
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> m TypedContent
forall (m :: * -> *) a.
(MonadHandler m, YesodAuth (HandlerSite m), Show a,
 SubHandlerSite m ~ Auth) =>
a -> m TypedContent
onFailure OpenIdResponse -> m TypedContent
onSuccess Either SomeException OpenIdResponse
eres
  where
    onFailure :: a -> m TypedContent
onFailure a
err = do
        AuthRoute -> Route (HandlerSite m)
tm <- m (AuthRoute -> Route (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
        Route (HandlerSite m) -> Text -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage (AuthRoute -> Route (HandlerSite m)
tm AuthRoute
LoginR) (Text -> m TypedContent) -> Text -> m TypedContent
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
err
    onSuccess :: OpenIdResponse -> m TypedContent
onSuccess OpenIdResponse
oir = do
            let claimed :: [(Text, Text)] -> [(Text, Text)]
claimed =
                    case OpenIdResponse -> Maybe Identifier
OpenId.oirClaimed OpenIdResponse
oir of
                        Maybe Identifier
Nothing -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> a
id
                        Just (OpenId.Identifier Text
i') -> ((Text
claimedKey, Text
i')(Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:)
                oplocal :: [(Text, Text)] -> [(Text, Text)]
oplocal =
                    case OpenIdResponse -> Identifier
OpenId.oirOpLocal OpenIdResponse
oir of
                        OpenId.Identifier Text
i' -> ((Text
opLocalKey, Text
i')(Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:)
                gets'' :: [(Text, Text)]
gets'' = [(Text, Text)] -> [(Text, Text)]
oplocal ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> [(Text, Text)]
claimed ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
k, Text
_) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
"__" Text -> Text -> Bool
`isPrefixOf` Text
k) [(Text, Text)]
gets'
                i :: Text
i = Identifier -> Text
OpenId.identifier (Identifier -> Text) -> Identifier -> Text
forall a b. (a -> b) -> a -> b
$
                        case IdentifierType
idType of
                            IdentifierType
OPLocal -> OpenIdResponse -> Identifier
OpenId.oirOpLocal OpenIdResponse
oir
                            IdentifierType
Claimed -> Identifier -> Maybe Identifier -> Identifier
forall a. a -> Maybe a -> a
fromMaybe (OpenIdResponse -> Identifier
OpenId.oirOpLocal OpenIdResponse
oir) (Maybe Identifier -> Identifier) -> Maybe Identifier -> Identifier
forall a b. (a -> b) -> a -> b
$ OpenIdResponse -> Maybe Identifier
OpenId.oirClaimed OpenIdResponse
oir
            Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect (Creds (HandlerSite m) -> m TypedContent)
-> Creds (HandlerSite m) -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [(Text, Text)] -> Creds master
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"openid" Text
i [(Text, Text)]
gets''

-- | The main identifier provided by the OpenID authentication plugin is the
-- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier
-- available.
--
-- In the 'credsExtra' field of the 'Creds' datatype, you can lookup this key
-- to find the claimed identifier, if available.
--
-- > let finalID = fromMaybe (credsIdent creds)
-- >             $ lookup claimedKey (credsExtra creds)
--
-- Since 1.0.2
claimedKey :: Text
claimedKey :: Text
claimedKey = Text
"__CLAIMED"

opLocalKey :: Text
opLocalKey :: Text
opLocalKey = Text
"__OPLOCAL"

-- | A helper function which will get the claimed identifier, if available, falling back to the OP local identifier.
--
-- See 'claimedKey'.
--
-- Since 1.0.2
credsIdentClaimed :: Creds m -> Text

-- Prevent other backends from overloading the __CLAIMED value, which could
-- possibly open us to security holes.
credsIdentClaimed :: Creds m -> Text
credsIdentClaimed Creds m
c | Creds m -> Text
forall master. Creds master -> Text
credsPlugin Creds m
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"openid" = Creds m -> Text
forall master. Creds master -> Text
credsIdent Creds m
c

credsIdentClaimed Creds m
c = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Creds m -> Text
forall master. Creds master -> Text
credsIdent Creds m
c)
                    (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
claimedKey (Creds m -> [(Text, Text)]
forall master. Creds master -> [(Text, Text)]
credsExtra Creds m
c)