{-# 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 :: forall master.
YesodAuth master =>
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 -> m TypedContent
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
        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
forall a. HasCallStack => a
undefined
        toWidget (\Route site -> [(Text, Text)] -> Text
x -> (Route site -> [(Text, Text)] -> Text) -> Css
[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 :: forall master. Text -> Texts -> AuthHandler master TypedContent
dispatch Text
"GET" [Text
"forward"] = do
        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 roid of
            Just Text
oid -> do
                tm <- m (Route (SubHandlerSite m) -> Route (HandlerSite m))
m (AuthRoute -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                render <- getUrlRender
                let 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 <- authHttpManager
                eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
                case 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
        rr <- m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
        completeHelper idType $ reqGetParams 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
        (posts, _) <- m ([(Text, Text)], [(Text, FileInfo)])
forall (m :: * -> *).
MonadHandler m =>
m ([(Text, Text)], [(Text, FileInfo)])
runRequestBody
        completeHelper idType posts
    dispatch Text
_ Texts
_ = m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound

completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper :: forall master.
IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper IdentifierType
idType [(Text, Text)]
gets' = do
    manager <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
    eres <- tryAny $ OpenId.authenticateClaimed gets' manager
    either onFailure onSuccess eres
  where
    onFailure :: a -> m TypedContent
onFailure a
err = do
        tm <- m (Route (SubHandlerSite m) -> Route (HandlerSite m))
m (AuthRoute -> Route (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
        loginErrorMessage (tm LoginR) $ T.pack $ show 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) -> HasLeadingSpace)
-> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> HasLeadingSpace) -> [a] -> [a]
filter (\(Text
k, Text
_) -> HasLeadingSpace -> HasLeadingSpace
not (HasLeadingSpace -> HasLeadingSpace)
-> HasLeadingSpace -> HasLeadingSpace
forall a b. (a -> b) -> a -> b
$ Text
"__" Text -> Text -> HasLeadingSpace
`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 :: forall m. Creds m -> Text
credsIdentClaimed Creds m
c | Creds m -> Text
forall m. Creds m -> Text
credsPlugin Creds m
c Text -> Text -> HasLeadingSpace
forall a. Eq a => a -> a -> HasLeadingSpace
/= Text
"openid" = Creds m -> Text
forall m. Creds m -> Text
credsIdent Creds m
c

credsIdentClaimed Creds m
c = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Creds m -> Text
forall m. Creds m -> 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)