{-# 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 =
    forall master.
Text
-> (Text -> [Text] -> AuthHandler master TypedContent)
-> ((Route Auth -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
"rpxnow" 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 <- forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
        let queryString :: Text
queryString = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode
                        forall a b. (a -> b) -> a -> b
$ Bool -> Query -> ByteString
renderQuery Bool
True [(ByteString
"token_url", forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Route master -> Text
render forall a b. (a -> b) -> a -> b
$ Route Auth -> Route master
tm forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Route Auth
PluginR Text
"rpxnow" [])]
        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 :: forall a b master. a -> [b] -> AuthHandler master TypedContent
dispatch a
_ [] = do
        [Text]
token1 <- forall (m :: * -> *). MonadHandler m => Text -> m [Text]
lookupGetParams Text
"token"
        [Text]
token2 <- forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m [Text]
lookupPostParams Text
"token"
        String
token <- case [Text]
token1 forall a. [a] -> [a] -> [a]
++ [Text]
token2 of
                        [] -> forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs [Text
"token: Value not supplied"]
                        Text
x:[Text]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
x
        Manager
manager <- forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
        Rpxnow.Identifier Text
ident [(Text, Text)]
extra <- forall (m :: * -> *).
MonadIO m =>
String -> String -> Manager -> m Identifier
Rpxnow.authenticate String
apiKey String
token Manager
manager
        let creds :: Creds master
creds =
                forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"rpxnow" Text
ident
                forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Text
x -> (:) (Text
"verifiedEmail", Text
x))
                    (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"verifiedEmail" [(Text, Text)]
extra)
                forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Text
x -> (:) (Text
"displayName", Text
x))
                    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
pack forall a b. (a -> b) -> a -> b
$ [(String, String)] -> Maybe String
getDisplayName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
unpack 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)
                  []
        forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds master
creds
    dispatch a
_ [b]
_ = 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 =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
x -> forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, String)]
extra)) forall a. Maybe a
Nothing [String]
choices
  where
    choices :: [String]
choices = [String
"verifiedEmail", String
"email", String
"displayName", String
"preferredUsername"]