{-# 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 =
    forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
"openid" forall master. Text -> Texts -> AuthHandler master TypedContent
dispatch 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 <- 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 :: forall a. a -> [(Text, Text)] -> Text
y = forall a. HasCallStack => a
undefined
        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;
|] forall a b. (a -> b) -> a -> b
$ Route site -> [(Text, Text)] -> Text
x forall a. a -> a -> a
`asTypeOf` 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
        Maybe Text
roid <- forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputGet forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
Field m a -> Text -> FormInput m (Maybe a)
iopt 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 <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
                Route master -> Text
render <- forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
                let complete' :: Text
complete' = Route master -> Text
render forall a b. (a -> b) -> a -> b
$ AuthRoute -> Route master
tm AuthRoute
complete
                Manager
manager <- forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
                Either SomeException Text
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Text -> Text -> Maybe Text -> [(Text, Text)] -> Manager -> m Text
OpenId.getForwardUrl Text
oid Text
complete' forall a. Maybe a
Nothing [(Text, Text)]
extensionFields Manager
manager
                case Either SomeException Text
eres of
                    Left SomeException
err -> forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage (AuthRoute -> Route master
tm AuthRoute
LoginR) forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
err
                    Right Text
x -> forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Text
x
            Maybe Text
Nothing -> forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR AuthMessage
Msg.NoOpenID
    dispatch Text
"GET" [Text
"complete", Text
""] = forall master. Text -> Texts -> AuthHandler master TypedContent
dispatch Text
"GET" [Text
"complete"] -- compatibility issues
    dispatch Text
"GET" [Text
"complete"] = do
        YesodRequest
rr <- forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
        forall master.
IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper IdentifierType
idType forall a b. (a -> b) -> a -> b
$ YesodRequest -> [(Text, Text)]
reqGetParams YesodRequest
rr
    dispatch Text
"POST" [Text
"complete", Text
""] = 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)]
_) <- forall (m :: * -> *).
MonadHandler m =>
m ([(Text, Text)], [(Text, FileInfo)])
runRequestBody
        forall master.
IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper IdentifierType
idType [(Text, Text)]
posts
    dispatch Text
_ Texts
_ = 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
manager <- forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
    Either SomeException OpenIdResponse
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
[(Text, Text)] -> Manager -> m OpenIdResponse
OpenId.authenticateClaimed [(Text, Text)]
gets' Manager
manager
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {m :: * -> *} {a}.
(SubHandlerSite m ~ Auth, MonadHandler m,
 YesodAuth (HandlerSite m), Show a) =>
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 <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
        forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage (AuthRoute -> Route (HandlerSite m)
tm AuthRoute
LoginR) forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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 -> forall a. a -> a
id
                        Just (OpenId.Identifier Text
i') -> ((Text
claimedKey, Text
i')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')forall a. a -> [a] -> [a]
:)
                gets'' :: [(Text, Text)]
gets'' = [(Text, Text)] -> [(Text, Text)]
oplocal forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> [(Text, Text)]
claimed forall a b. (a -> b) -> a -> b
$ forall a. (a -> HasLeadingSpace) -> [a] -> [a]
filter (\(Text
k, Text
_) -> HasLeadingSpace -> HasLeadingSpace
not forall a b. (a -> b) -> a -> b
$ Text
"__" Text -> Text -> HasLeadingSpace
`isPrefixOf` Text
k) [(Text, Text)]
gets'
                i :: Text
i = Identifier -> Text
OpenId.identifier forall a b. (a -> b) -> a -> b
$
                        case IdentifierType
idType of
                            IdentifierType
OPLocal -> OpenIdResponse -> Identifier
OpenId.oirOpLocal OpenIdResponse
oir
                            IdentifierType
Claimed -> forall a. a -> Maybe a -> a
fromMaybe (OpenIdResponse -> Identifier
OpenId.oirOpLocal OpenIdResponse
oir) forall a b. (a -> b) -> a -> b
$ OpenIdResponse -> Maybe Identifier
OpenId.oirClaimed OpenIdResponse
oir
            forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect forall a b. (a -> b) -> a -> b
$ 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 | forall m. Creds m -> Text
credsPlugin Creds m
c forall a. Eq a => a -> a -> HasLeadingSpace
/= Text
"openid" = forall m. Creds m -> Text
credsIdent Creds m
c

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