{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.Authenticate.OpenId
    ( -- * Functions
      getForwardUrl
    , authenticate
    , authenticateClaimed
      -- * Types
    , AuthenticateException (..)
    , Identifier (..)
      -- ** Response
    , OpenIdResponse
    , oirOpLocal
    , oirParams
    , oirClaimed
    ) where

import Control.Monad.IO.Class
import OpenId2.Normalization (normalize)
import OpenId2.Discovery (discover, Discovery (..))
import OpenId2.Types
import Control.Monad (unless)
import qualified Data.Text as T
import Data.Text.Lazy.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Lazy (toStrict)
import Network.HTTP.Conduit
    ( parseUrlThrow, urlEncodedBody, responseBody, httpLbs
    , Manager
    )
import Control.Arrow ((***), second)
import Data.List (unfoldr)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Blaze.ByteString.Builder (toByteString)
import Network.HTTP.Types (renderQueryText)
import Control.Exception (throwIO)

getForwardUrl
    :: MonadIO m
    => Text -- ^ The openid the user provided.
    -> Text -- ^ The URL for this application\'s complete page.
    -> Maybe Text -- ^ Optional realm
    -> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.
    -> Manager
    -> m Text -- ^ URL to send the user to.
getForwardUrl :: Text -> Text -> Maybe Text -> [(Text, Text)] -> Manager -> m Text
getForwardUrl Text
openid' Text
complete Maybe Text
mrealm [(Text, Text)]
params Manager
manager = do
    let realm :: Text
realm = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
complete Maybe Text
mrealm
    Identifier
claimed <- Text -> m Identifier
forall (m :: * -> *). MonadIO m => Text -> m Identifier
normalize (Text -> m Identifier) -> Text -> m Identifier
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
openid'
    Discovery
disc <- Identifier -> Manager -> m Discovery
forall (m :: * -> *).
MonadIO m =>
Identifier -> Manager -> m Discovery
discover Identifier
claimed Manager
manager
    let helper :: Text -> [(Text, Text)] -> m Text
helper Text
s [(Text, Text)]
q = Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
            [ Text
s
            , if Text
"?" Text -> Text -> Bool
`T.isInfixOf` Text
s then Text
"&" else Text
"?"
            , ByteString -> Text
decodeUtf8 (Builder -> ByteString
toByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> QueryText -> Builder
renderQueryText Bool
False (QueryText -> Builder) -> QueryText -> Builder
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> (Text, Maybe Text)) -> [(Text, Text)] -> QueryText
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Maybe Text) -> (Text, Text) -> (Text, Maybe Text)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Text -> Maybe Text
forall a. a -> Maybe a
Just) [(Text, Text)]
q)
            ]
    case Discovery
disc of
        Discovery1 Text
server Maybe Text
mdelegate -> Text -> [(Text, Text)] -> m Text
forall (m :: * -> *). Monad m => Text -> [(Text, Text)] -> m Text
helper Text
server
                ([(Text, Text)] -> m Text) -> [(Text, Text)] -> m Text
forall a b. (a -> b) -> a -> b
$ (Text
"openid.mode", Text
"checkid_setup")
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"openid.identity", Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Identifier -> Text
identifier Identifier
claimed) Text -> Text
forall a. a -> a
id Maybe Text
mdelegate)
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"openid.return_to", Text
complete)
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"openid.realm", Text
realm)
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"openid.trust_root", Text
complete)
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
params
        Discovery2 (Provider Text
p) (Identifier Text
i) IdentType
itype -> do
            let (Text
claimed', Text
identity') =
                    case IdentType
itype of
                        IdentType
ClaimedIdent -> (Identifier -> Text
identifier Identifier
claimed, Text
i)
                        IdentType
OPIdent ->
                            let x :: Text
x = Text
"http://specs.openid.net/auth/2.0/identifier_select"
                             in (Text
x, Text
x)
            Text -> [(Text, Text)] -> m Text
forall (m :: * -> *). Monad m => Text -> [(Text, Text)] -> m Text
helper Text
p
                ([(Text, Text)] -> m Text) -> [(Text, Text)] -> m Text
forall a b. (a -> b) -> a -> b
$ (Text
"openid.ns", Text
"http://specs.openid.net/auth/2.0")
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"openid.mode", Text
"checkid_setup")
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"openid.claimed_id", Text
claimed')
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"openid.identity", Text
identity')
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"openid.return_to", Text
complete)
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"openid.realm", Text
realm)
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
params

authenticate
    :: MonadIO m
    => [(Text, Text)]
    -> Manager
    -> m (Identifier, [(Text, Text)])
authenticate :: [(Text, Text)] -> Manager -> m (Identifier, [(Text, Text)])
authenticate [(Text, Text)]
ps Manager
m = do
    OpenIdResponse
x <- [(Text, Text)] -> Manager -> m OpenIdResponse
forall (m :: * -> *).
MonadIO m =>
[(Text, Text)] -> Manager -> m OpenIdResponse
authenticateClaimed [(Text, Text)]
ps Manager
m
    (Identifier, [(Text, Text)]) -> m (Identifier, [(Text, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (OpenIdResponse -> Identifier
oirOpLocal OpenIdResponse
x, OpenIdResponse -> [(Text, Text)]
oirParams OpenIdResponse
x)
{-# DEPRECATED authenticate "Use authenticateClaimed" #-}

data OpenIdResponse = OpenIdResponse
    { OpenIdResponse -> Identifier
oirOpLocal :: Identifier
    , OpenIdResponse -> [(Text, Text)]
oirParams :: [(Text, Text)]
    , OpenIdResponse -> Maybe Identifier
oirClaimed :: Maybe Identifier
    }

authenticateClaimed
    :: MonadIO m
    => [(Text, Text)]
    -> Manager
    -> m OpenIdResponse
authenticateClaimed :: [(Text, Text)] -> Manager -> m OpenIdResponse
authenticateClaimed [(Text, Text)]
params Manager
manager = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"openid.mode" [(Text, Text)]
params Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"id_res")
        (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ AuthenticateException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (AuthenticateException -> IO ()) -> AuthenticateException -> IO ()
forall a b. (a -> b) -> a -> b
$ case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"openid.mode" [(Text, Text)]
params of
                      Maybe Text
Nothing -> String -> AuthenticateException
AuthenticationException String
"openid.mode was not found in the params."
                      (Just Text
m)
                            | Text
m Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"error" ->
                                case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"openid.error" [(Text, Text)]
params of
                                  Maybe Text
Nothing -> String -> AuthenticateException
AuthenticationException String
"An error occurred, but no error message was provided."
                                  (Just Text
e) -> String -> AuthenticateException
AuthenticationException (String -> AuthenticateException)
-> String -> AuthenticateException
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
e
                            | Bool
otherwise -> String -> AuthenticateException
AuthenticationException (String -> AuthenticateException)
-> String -> AuthenticateException
forall a b. (a -> b) -> a -> b
$ String
"mode is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but we were expecting id_res."
    Text
ident <- case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"openid.identity" [(Text, Text)]
params of
                Just Text
i -> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
                Maybe Text
Nothing ->
                    IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ AuthenticateException -> IO Text
forall e a. Exception e => e -> IO a
throwIO (AuthenticateException -> IO Text)
-> AuthenticateException -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
AuthenticationException String
"Missing identity"
    Discovery
discOP <- Text -> m Identifier
forall (m :: * -> *). MonadIO m => Text -> m Identifier
normalize Text
ident m Identifier -> (Identifier -> m Discovery) -> m Discovery
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Identifier -> Manager -> m Discovery)
-> Manager -> Identifier -> m Discovery
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Manager -> m Discovery
forall (m :: * -> *).
MonadIO m =>
Identifier -> Manager -> m Discovery
discover Manager
manager

    let endpoint :: Discovery -> Text
endpoint Discovery
d =
            case Discovery
d of
                Discovery1 Text
p Maybe Text
_ -> Text
p
                Discovery2 (Provider Text
p) Identifier
_ IdentType
_ -> Text
p
    let params' :: [(ByteString, ByteString)]
params' = ((Text, Text) -> (ByteString, ByteString))
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (Text -> ByteString) -> (Text, Text) -> (ByteString, ByteString)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> ByteString
encodeUtf8)
                ([(Text, Text)] -> [(ByteString, ByteString)])
-> [(Text, Text)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ (Text
"openid.mode", Text
"check_authentication")
                (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
k, Text
_) -> Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"openid.mode") [(Text, Text)]
params
    Request
req' <- IO Request -> m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Request -> m Request) -> IO Request -> m Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Discovery -> Text
endpoint Discovery
discOP
    let req :: Request
req = [(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
params' Request
req'
    Response ByteString
rsp <- Request -> Manager -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req Manager
manager
    let rps :: [(Text, Text)]
rps = Text -> [(Text, Text)]
parseDirectResponse (Text -> [(Text, Text)]) -> Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Text -> Text
toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
rsp

    Maybe Identifier
claimed <-
        case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"openid.claimed_id" [(Text, Text)]
params of
            Maybe Text
Nothing -> Maybe Identifier -> m (Maybe Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Identifier
forall a. Maybe a
Nothing
            Just Text
claimed' -> do
                -- need to validate that this provider can speak for the given
                -- claimed identifier
                Identifier
claimedN <- Text -> m Identifier
forall (m :: * -> *). MonadIO m => Text -> m Identifier
normalize Text
claimed'
                Discovery
discC <- Identifier -> Manager -> m Discovery
forall (m :: * -> *).
MonadIO m =>
Identifier -> Manager -> m Discovery
discover Identifier
claimedN Manager
manager
                Maybe Identifier -> m (Maybe Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Identifier -> m (Maybe Identifier))
-> Maybe Identifier -> m (Maybe Identifier)
forall a b. (a -> b) -> a -> b
$
                    if Discovery -> Text
endpoint Discovery
discOP Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Discovery -> Text
endpoint Discovery
discC
                        then Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
claimedN
                        else Maybe Identifier
forall a. Maybe a
Nothing

    case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"is_valid" [(Text, Text)]
rps of
        Just Text
"true" -> OpenIdResponse -> m OpenIdResponse
forall (m :: * -> *) a. Monad m => a -> m a
return OpenIdResponse :: Identifier -> [(Text, Text)] -> Maybe Identifier -> OpenIdResponse
OpenIdResponse
            { oirOpLocal :: Identifier
oirOpLocal = Text -> Identifier
Identifier Text
ident
            , oirParams :: [(Text, Text)]
oirParams  = [(Text, Text)]
rps
            , oirClaimed :: Maybe Identifier
oirClaimed = Maybe Identifier
claimed
            }
        Maybe Text
_ -> IO OpenIdResponse -> m OpenIdResponse
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OpenIdResponse -> m OpenIdResponse)
-> IO OpenIdResponse -> m OpenIdResponse
forall a b. (a -> b) -> a -> b
$ AuthenticateException -> IO OpenIdResponse
forall e a. Exception e => e -> IO a
throwIO (AuthenticateException -> IO OpenIdResponse)
-> AuthenticateException -> IO OpenIdResponse
forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
AuthenticationException String
"OpenID provider did not validate"

-- | Turn a response body into a list of parameters.
parseDirectResponse :: Text -> [(Text, Text)]
parseDirectResponse :: Text -> [(Text, Text)]
parseDirectResponse  =
    ((String, String) -> (Text, Text))
-> [(String, String)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
pack (String -> Text)
-> (String -> Text) -> (String, String) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> Text
pack) ([(String, String)] -> [(Text, Text)])
-> (Text -> [(String, String)]) -> Text -> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe ((String, String), String))
-> String -> [(String, String)]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr String -> Maybe ((String, String), String)
step (String -> [(String, String)])
-> (Text -> String) -> Text -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack
  where
    step :: String -> Maybe ((String, String), String)
step []  = Maybe ((String, String), String)
forall a. Maybe a
Nothing
    step String
str = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') String
str of
      (String
ps,String
rest) -> ((String, String), String) -> Maybe ((String, String), String)
forall a. a -> Maybe a
Just ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
ps,String
rest)

split :: (a -> Bool) -> [a] -> ([a],[a])
split :: (a -> Bool) -> [a] -> ([a], [a])
split a -> Bool
p [a]
as = case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
p [a]
as of
  ([a]
xs,a
_:[a]
ys) -> ([a]
xs,[a]
ys)
  ([a], [a])
pair      -> ([a], [a])
pair