    {-# 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)