{-# 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 :: 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] -> 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
        Route master -> Text
render <- WidgetFor master (Route master -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
        let queryString :: Text
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" [])]
        (RY master -> MarkupM ()) -> WidgetFor master ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
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 :: a -> [b] -> AuthHandler master TypedContent
dispatch a
_ [] = do
        [Text]
token1 <- Text -> m [Text]
forall (m :: * -> *). MonadHandler m => Text -> m [Text]
lookupGetParams Text
"token"
        [Text]
token2 <- Text -> m [Text]
forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m [Text]
lookupPostParams Text
"token"
        String
token <- case [Text]
token1 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
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 (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
manager <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
        Rpxnow.Identifier Text
ident [(Text, Text)]
extra <- String -> String -> Manager -> m Identifier
forall (m :: * -> *).
MonadIO m =>
String -> String -> Manager -> m Identifier
Rpxnow.authenticate String
apiKey String
token Manager
manager
        let creds :: Creds master
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 (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 (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> String
unpack) [(Text, Text)]
extra)
                  []
        Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds master
Creds (HandlerSite m)
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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
x -> Maybe String -> Maybe String -> Maybe String
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"]