    {-# LANGUAGE QuasiQuotes #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE GADTs #-}
    module Yesod.Auth.Rpxnow
        ( authRpxnow
        ) where

    import Yesod.Auth
    import qualified Web.Authenticate.Rpxnow as Rpxnow
    import Control.Monad (mplus)

    import Yesod.Core
    import Data.Text (pack, unpack)
    import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
    import Data.Text.Encoding.Error (lenientDecode)
    import Control.Arrow ((***))
    import Network.HTTP.Types (renderQuery)

    authRpxnow :: YesodAuth master
               => String -- ^ app name
               -> String -- ^ key
               -> AuthPlugin master
    authRpxnow :: forall master.
    YesodAuth master =>
    String -> String -> AuthPlugin master
    authRpxnow String
    app String
    apiKey =
        Text
    -> (Text -> [Text] -> AuthHandler master TypedContent)
    -> ((Route Auth -> Route master) -> WidgetFor master ())
    -> AuthPlugin master
    forall master.
    Text
    -> (Text -> [Text] -> AuthHandler master TypedContent)
    -> ((Route Auth -> Route master) -> WidgetFor master ())
    -> AuthPlugin master
    AuthPlugin Text
    "rpxnow" Text -> [Text] -> m TypedContent
    Text -> [Text] -> AuthHandler master TypedContent
    forall a b master. a -> [b] -> AuthHandler master TypedContent
    dispatch (Route Auth -> Route master) -> WidgetFor master ()
    login
      where
        login :: (Route Auth -> Route master) -> WidgetFor master ()
    login Route Auth -> Route master
    tm = do
            render <- WidgetFor master (Route master -> Text)
    WidgetFor master (Route (HandlerSite (WidgetFor master)) -> Text)
    forall (m :: * -> *).
    MonadHandler m =>
    m (Route (HandlerSite m) -> Text)
    getUrlRender
            let queryString = OnDecodeError -> ByteString -> Text
    decodeUtf8With OnDecodeError
    lenientDecode
                            (ByteString -> Text) -> ByteString -> Text
    forall a b. (a -> b) -> a -> b
    $ Bool -> Query -> ByteString
    renderQuery Bool
    True [(ByteString
    "token_url", ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
    forall a b. (a -> b) -> a -> b
    $ Text -> ByteString
    encodeUtf8 (Text -> ByteString) -> Text -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Route master -> Text
    render (Route master -> Text) -> Route master -> Text
    forall a b. (a -> b) -> a -> b
    $ Route Auth -> Route master
    tm (Route Auth -> Route master) -> Route Auth -> Route master
    forall a b. (a -> b) -> a -> b
    $ Text -> [Text] -> Route Auth
    PluginR Text
    "rpxnow" [])]
            toWidget [hamlet|
    $newline never
    <iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
    |]

        dispatch :: a -> [b] -> AuthHandler master TypedContent
        dispatch :: forall a b master. a -> [b] -> AuthHandler master TypedContent
    dispatch a
    _ [] = do
            token1 <- Text -> m [Text]
    forall (m :: * -> *). MonadHandler m => Text -> m [Text]
    lookupGetParams Text
    "token"
            token2 <- lookupPostParams "token"
            token <- case token1 ++ token2 of
                            [] -> [Text] -> m String
    forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
    invalidArgs [Text
    "token: Value not supplied"]
                            Text
    x:[Text]
    _ -> String -> m String
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> m String) -> String -> m String
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    unpack Text
    x
            manager <- authHttpManager
            Rpxnow.Identifier ident extra <- Rpxnow.authenticate apiKey token manager
            let creds =
                    Text -> Text -> [(Text, Text)] -> Creds master
    forall master. Text -> Text -> [(Text, Text)] -> Creds master
    Creds Text
    "rpxnow" Text
    ident
                    ([(Text, Text)] -> Creds master) -> [(Text, Text)] -> Creds master
    forall a b. (a -> b) -> a -> b
    $ ([(Text, Text)] -> [(Text, Text)])
    -> (Text -> [(Text, Text)] -> [(Text, Text)])
    -> Maybe Text
    -> [(Text, Text)]
    -> [(Text, Text)]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [(Text, Text)] -> [(Text, Text)]
    forall a. a -> a
    id (\Text
    x -> (:) (Text
    "verifiedEmail", Text
    x))
                        (Text -> [(Text, Text)] -> Maybe Text
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Text
    "verifiedEmail" [(Text, Text)]
    extra)
                    ([(Text, Text)] -> [(Text, Text)])
    -> [(Text, Text)] -> [(Text, Text)]
    forall a b. (a -> b) -> a -> b
    $ ([(Text, Text)] -> [(Text, Text)])
    -> (Text -> [(Text, Text)] -> [(Text, Text)])
    -> Maybe Text
    -> [(Text, Text)]
    -> [(Text, Text)]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [(Text, Text)] -> [(Text, Text)]
    forall a. a -> a
    id (\Text
    x -> (:) (Text
    "displayName", Text
    x))
                        ((String -> Text) -> Maybe String -> Maybe Text
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap String -> Text
    pack (Maybe String -> Maybe Text) -> Maybe String -> Maybe Text
    forall a b. (a -> b) -> a -> b
    $ [(String, String)] -> Maybe String
    getDisplayName ([(String, String)] -> Maybe String)
    -> [(String, String)] -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ ((Text, Text) -> (String, String))
    -> [(Text, Text)] -> [(String, String)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Text -> String
    unpack (Text -> String)
    -> (Text -> String) -> (Text, Text) -> (String, String)
    forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
    forall (a :: * -> * -> *) b c b' c'.
    Arrow a =>
    a b c -> a b' c' -> a (b, b') (c, c')
    *** Text -> String
    unpack) [(Text, Text)]
    extra)
                      []
            setCredsRedirect creds
        dispatch a
    _ [b]
    _ = m TypedContent
    forall (m :: * -> *) a. MonadHandler m => m a
    notFound

    -- | Get some form of a display name.
    getDisplayName :: [(String, String)] -> Maybe String
    getDisplayName :: [(String, String)] -> Maybe String
    getDisplayName [(String, String)]
    extra =
        (String -> Maybe String -> Maybe String)
    -> Maybe String -> [String] -> Maybe String
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\String
    x -> Maybe String -> Maybe String -> Maybe String
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    mplus (String -> [(String, String)] -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    x [(String, String)]
    extra)) Maybe String
    forall a. Maybe a
    Nothing [String]
    choices
      where
        choices :: [String]
    choices = [String
    "verifiedEmail", String
    "email", String
    "displayName", String
    "preferredUsername"]