    {-# 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 :: forall (m :: * -> *).
    MonadIO m =>
    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
        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'
        disc <- discover claimed manager
        let helper Text
    s [(Text, Text)]
    q = Text -> m Text
    forall a. a -> m a
    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 b c d. (b -> c) -> (d, b) -> (d, c)
    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 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 :: forall (m :: * -> *).
    MonadIO m =>
    [(Text, Text)] -> Manager -> m (Identifier, [(Text, Text)])
    authenticate [(Text, Text)]
    ps Manager
    m = do
        x <- [(Text, Text)] -> Manager -> m OpenIdResponse
    forall (m :: * -> *).
    MonadIO m =>
    [(Text, Text)] -> Manager -> m OpenIdResponse
    authenticateClaimed [(Text, Text)]
    ps Manager
    m
        return (oirOpLocal x, oirParams 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 :: forall (m :: * -> *).
    MonadIO m =>
    [(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 a. IO a -> m a
    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. (HasCallStack, 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."
        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 a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Text
    i
                    Maybe Text
    Nothing ->
                        IO Text -> m Text
    forall a. IO a -> m a
    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. (HasCallStack, 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"
        discOP <- normalize ident >>= flip discover manager

        let endpoint Discovery
    d =
                case Discovery
    d of
                    Discovery1 Text
    p Maybe Text
    _ -> Text
    p
                    Discovery2 (Provider Text
    p) Identifier
    _ IdentType
    _ -> Text
    p
        let 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 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 -> 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
        req' <- liftIO $ parseUrlThrow $ unpack $ endpoint discOP
        let req = [(ByteString, ByteString)] -> Request -> Request
    urlEncodedBody [(ByteString, ByteString)]
    params' Request
    req'
        rsp <- httpLbs req manager
        let rps = Text -> [(Text, Text)]
    parseDirectResponse (Text -> [(Text, Text)]) -> Text -> [(Text, Text)]
    forall a b. (a -> b) -> a -> b
    $ LazyText -> Text
    toStrict (LazyText -> Text) -> LazyText -> Text
    forall a b. (a -> b) -> a -> b
    $ OnDecodeError -> ByteString -> LazyText
    decodeUtf8With OnDecodeError
    lenientDecode (ByteString -> LazyText) -> ByteString -> LazyText
    forall a b. (a -> b) -> a -> b
    $ Response ByteString -> ByteString
    forall body. Response body -> body
    responseBody Response ByteString
    rsp

        claimed <-
            case lookup "openid.claimed_id" params of
                Maybe Text
    Nothing -> Maybe Identifier -> m (Maybe Identifier)
    forall a. a -> m a
    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
                    claimedN <- Text -> m Identifier
    forall (m :: * -> *). MonadIO m => Text -> m Identifier
    normalize Text
    claimed'
                    discC <- discover claimedN manager
                    return $
                        if endpoint discOP == endpoint discC
                            then Just claimedN
                            else Nothing

        case lookup "is_valid" rps of
            Just Text
    "true" -> OpenIdResponse -> m OpenIdResponse
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return 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 a. IO a -> m a
    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. (HasCallStack, 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 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')
    *** 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 :: forall a. (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