    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE CPP #-}

    --------------------------------------------------------------------------------
    -- |
    -- Module      : Network.OpenID.Discovery
    -- Copyright   : (c) Trevor Elliott, 2008
    -- License     : BSD3
    --
    -- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
    -- Stability   :
    -- Portability :
    --

    module OpenId2.Discovery (
        -- * Discovery
        discover
      , Discovery (..)
      ) where

    -- Friends
    import OpenId2.Types
    import OpenId2.XRDS

    -- Libraries
    import Data.Char
    import Data.Maybe
    import Network.HTTP.Conduit
    import qualified Data.ByteString.Char8 as S8
    import Control.Arrow (first)
    import Control.Monad.IO.Class (MonadIO (liftIO))
    import Control.Monad (mplus, liftM, guard)
    import qualified Data.CaseInsensitive as CI
    import Data.Text (Text, unpack)
    import Data.Text.Lazy (toStrict)
    import qualified Data.Text as T
    import Data.Text.Lazy.Encoding (decodeUtf8With)
    import Data.Text.Encoding.Error (lenientDecode)
    import Control.Applicative ((<$>), (<*>))
    import Network.HTTP.Types (status200)
    import Control.Exception (throwIO)
    import Text.HTML.DOM
    import Text.XML.Cursor
    import Text.XML (Node (..), Element (..))
    import qualified Data.Map as Map

    data Discovery = Discovery1 Text (Maybe Text)
                   | Discovery2 Provider Identifier IdentType
        deriving Int -> Discovery -> ShowS
    [Discovery] -> ShowS
    Discovery -> String
    (Int -> Discovery -> ShowS)
    -> (Discovery -> String)
    -> ([Discovery] -> ShowS)
    -> Show Discovery
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Discovery -> ShowS
    showsPrec :: Int -> Discovery -> ShowS
    $cshow :: Discovery -> String
    show :: Discovery -> String
    $cshowList :: [Discovery] -> ShowS
    showList :: [Discovery] -> ShowS
    Show

    -- | Attempt to resolve an OpenID endpoint, and user identifier.
    discover :: MonadIO m => Identifier -> Manager -> m Discovery
    discover :: forall (m :: * -> *).
    MonadIO m =>
    Identifier -> Manager -> m Discovery
    discover ident :: Identifier
    ident@(Identifier Text
    i) Manager
    manager = do
        res1 <- Identifier
    -> Maybe String
    -> Int
    -> Manager
    -> m (Maybe (Provider, Identifier, IdentType))
    forall (m :: * -> *).
    MonadIO m =>
    Identifier
    -> Maybe String
    -> Int
    -> Manager
    -> m (Maybe (Provider, Identifier, IdentType))
    discoverYADIS Identifier
    ident Maybe String
    forall a. Maybe a
    Nothing Int
    10 Manager
    manager
        case res1 of
            Just (Provider
    x, Identifier
    y, IdentType
    z) -> Discovery -> m Discovery
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Discovery -> m Discovery) -> Discovery -> m Discovery
    forall a b. (a -> b) -> a -> b
    $ Provider -> Identifier -> IdentType -> Discovery
    Discovery2 Provider
    x Identifier
    y IdentType
    z
            Maybe (Provider, Identifier, IdentType)
    Nothing -> do
                res2 <- Identifier -> Manager -> m (Maybe Discovery)
    forall (m :: * -> *).
    MonadIO m =>
    Identifier -> Manager -> m (Maybe Discovery)
    discoverHTML Identifier
    ident Manager
    manager
                case res2 of
                    Just Discovery
    x -> Discovery -> m Discovery
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Discovery
    x
                    Maybe Discovery
    Nothing -> IO Discovery -> m Discovery
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Discovery -> m Discovery) -> IO Discovery -> m Discovery
    forall a b. (a -> b) -> a -> b
    $ AuthenticateException -> IO Discovery
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (AuthenticateException -> IO Discovery)
    -> AuthenticateException -> IO Discovery
    forall a b. (a -> b) -> a -> b
    $ String -> AuthenticateException
    DiscoveryException (String -> AuthenticateException)
    -> String -> AuthenticateException
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    unpack Text
    i

    -- YADIS-Based Discovery -------------------------------------------------------

    -- | Attempt a YADIS based discovery, given a valid identifier.  The result is
    --   an OpenID endpoint, and the actual identifier for the user.
    discoverYADIS :: MonadIO m
                  => Identifier
                  -> Maybe String
                  -> Int -- ^ remaining redirects
                  -> Manager
                  -> m (Maybe (Provider, Identifier, IdentType))
    discoverYADIS :: forall (m :: * -> *).
    MonadIO m =>
    Identifier
    -> Maybe String
    -> Int
    -> Manager
    -> m (Maybe (Provider, Identifier, IdentType))
    discoverYADIS Identifier
    _ Maybe String
    _ Int
    0 Manager
    _ =
    #if MIN_VERSION_http_conduit(2, 2, 0)
        String -> m (Maybe (Provider, Identifier, IdentType))
    forall a. HasCallStack => String -> a
    error String
    "discoverYADIS: Too many redirects"
    #else
        liftIO $ throwIO $ TooManyRedirects
    #if MIN_VERSION_http_conduit(1,6,0)
            []
    #endif
    #endif
    discoverYADIS Identifier
    ident Maybe String
    mb_loc Int
    redirects Manager
    manager = do
        let uri :: String
    uri = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe (Text -> String
    unpack (Text -> String) -> Text -> String
    forall a b. (a -> b) -> a -> b
    $ Identifier -> Text
    identifier Identifier
    ident) Maybe String
    mb_loc
    #if MIN_VERSION_http_conduit(2, 2, 0)
        req <- IO Request -> m Request
    forall a. IO a -> m a
    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
    parseRequest String
    uri
    #else
        req <- liftIO $ parseUrl uri
    #endif
        res <- httpLbs req
    #if !MIN_VERSION_http_conduit(2, 2, 0)
    #if MIN_VERSION_http_conduit(1, 9, 0)
            { checkStatus = \_ _ _ -> Nothing
    #else
            { checkStatus = \_ _ -> Nothing
    #endif
            }
    #endif
            manager
        let mloc = (ByteString -> String) -> Maybe ByteString -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ByteString -> String
    S8.unpack
                 (Maybe ByteString -> Maybe String)
    -> Maybe ByteString -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ String -> [(String, ByteString)] -> Maybe ByteString
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    "x-xrds-location"
                 ([(String, ByteString)] -> Maybe ByteString)
    -> [(String, ByteString)] -> Maybe ByteString
    forall a b. (a -> b) -> a -> b
    $ (Header -> (String, ByteString))
    -> [Header] -> [(String, ByteString)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((HeaderName -> String) -> Header -> (String, ByteString)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first ((HeaderName -> String) -> Header -> (String, ByteString))
    -> (HeaderName -> String) -> Header -> (String, ByteString)
    forall a b. (a -> b) -> a -> b
    $ (Char -> Char) -> ShowS
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower ShowS -> (HeaderName -> String) -> HeaderName -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> String
    S8.unpack (ByteString -> String)
    -> (HeaderName -> ByteString) -> HeaderName -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . HeaderName -> ByteString
    forall s. CI s -> s
    CI.original)
                 ([Header] -> [(String, ByteString)])
    -> [Header] -> [(String, ByteString)]
    forall a b. (a -> b) -> a -> b
    $ Response ByteString -> [Header]
    forall body. Response body -> [Header]
    responseHeaders Response ByteString
    res
        let mloc' = if Maybe String
    mloc Maybe String -> Maybe String -> Bool
    forall a. Eq a => a -> a -> Bool
    == Maybe String
    mb_loc then Maybe String
    forall a. Maybe a
    Nothing else Maybe String
    mloc
        if responseStatus res == status200
            then
              case mloc' of
                Just String
    loc -> Identifier
    -> Maybe String
    -> Int
    -> Manager
    -> m (Maybe (Provider, Identifier, IdentType))
    forall (m :: * -> *).
    MonadIO m =>
    Identifier
    -> Maybe String
    -> Int
    -> Manager
    -> m (Maybe (Provider, Identifier, IdentType))
    discoverYADIS Identifier
    ident (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    loc) (Int
    redirects Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) Manager
    manager
                Maybe String
    Nothing  -> do
                  let mdoc :: Maybe XRDS
    mdoc = ByteString -> Maybe XRDS
    parseXRDS (ByteString -> Maybe XRDS) -> ByteString -> Maybe XRDS
    forall a b. (a -> b) -> a -> b
    $ Response ByteString -> ByteString
    forall body. Response body -> body
    responseBody Response ByteString
    res
                  case Maybe XRDS
    mdoc of
                      Just XRDS
    doc -> Maybe (Provider, Identifier, IdentType)
    -> m (Maybe (Provider, Identifier, IdentType))
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Provider, Identifier, IdentType)
     -> m (Maybe (Provider, Identifier, IdentType)))
    -> Maybe (Provider, Identifier, IdentType)
    -> m (Maybe (Provider, Identifier, IdentType))
    forall a b. (a -> b) -> a -> b
    $ Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType)
    parseYADIS Identifier
    ident XRDS
    doc
                      Maybe XRDS
    Nothing -> Maybe (Provider, Identifier, IdentType)
    -> m (Maybe (Provider, Identifier, IdentType))
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Provider, Identifier, IdentType)
    forall a. Maybe a
    Nothing
            else return Nothing

    -- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml
    -- document.
    parseYADIS :: Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType)
    parseYADIS :: Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType)
    parseYADIS Identifier
    ident = [(Provider, Identifier, IdentType)]
    -> Maybe (Provider, Identifier, IdentType)
    forall a. [a] -> Maybe a
    listToMaybe ([(Provider, Identifier, IdentType)]
     -> Maybe (Provider, Identifier, IdentType))
    -> (XRDS -> [(Provider, Identifier, IdentType)])
    -> XRDS
    -> Maybe (Provider, Identifier, IdentType)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Service -> Maybe (Provider, Identifier, IdentType))
    -> [Service] -> [(Provider, Identifier, IdentType)]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe Service -> Maybe (Provider, Identifier, IdentType)
    isOpenId ([Service] -> [(Provider, Identifier, IdentType)])
    -> (XRDS -> [Service])
    -> XRDS
    -> [(Provider, Identifier, IdentType)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . XRDS -> [Service]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
      where
      isOpenId :: Service -> Maybe (Provider, Identifier, IdentType)
    isOpenId Service
    svc = do
        let tys :: [Text]
    tys = Service -> [Text]
    serviceTypes Service
    svc
            localId :: Identifier
    localId = Identifier -> (Text -> Identifier) -> Maybe Text -> Identifier
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Identifier
    ident Text -> Identifier
    Identifier (Maybe Text -> Identifier) -> Maybe Text -> Identifier
    forall a b. (a -> b) -> a -> b
    $ [Text] -> Maybe Text
    forall a. [a] -> Maybe a
    listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
    forall a b. (a -> b) -> a -> b
    $ Service -> [Text]
    serviceLocalIDs Service
    svc
            f :: (Text, a) -> Maybe a
    f (Text
    x,a
    y) | Text
    x Text -> [Text] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Text]
    tys = a -> Maybe a
    forall a. a -> Maybe a
    Just a
    y
                    | Bool
    otherwise    = Maybe a
    forall a. Maybe a
    Nothing
        (lid, itype) <- [(Identifier, IdentType)] -> Maybe (Identifier, IdentType)
    forall a. [a] -> Maybe a
    listToMaybe ([(Identifier, IdentType)] -> Maybe (Identifier, IdentType))
    -> [(Identifier, IdentType)] -> Maybe (Identifier, IdentType)
    forall a b. (a -> b) -> a -> b
    $ ((Text, (Identifier, IdentType)) -> Maybe (Identifier, IdentType))
    -> [(Text, (Identifier, IdentType))] -> [(Identifier, IdentType)]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (Text, (Identifier, IdentType)) -> Maybe (Identifier, IdentType)
    forall {a}. (Text, a) -> Maybe a
    f
          [ (Text
    "http://specs.openid.net/auth/2.0/server", (Identifier
    ident, IdentType
    OPIdent))
          -- claimed identifiers
          , (Text
    "http://specs.openid.net/auth/2.0/signon", (Identifier
    localId, IdentType
    ClaimedIdent))
          , (Text
    "http://openid.net/signon/1.0"           , (Identifier
    localId, IdentType
    ClaimedIdent))
          , (Text
    "http://openid.net/signon/1.1"           , (Identifier
    localId, IdentType
    ClaimedIdent))
          ]
        uri <- listToMaybe $ serviceURIs svc
        return (Provider uri, lid, itype)

    -- HTML-Based Discovery --------------------------------------------------------

    -- | Attempt to discover an OpenID endpoint, from an HTML document.  The result
    -- will be an endpoint on success, and the actual identifier of the user.
    discoverHTML :: MonadIO m => Identifier -> Manager -> m (Maybe Discovery)
    discoverHTML :: forall (m :: * -> *).
    MonadIO m =>
    Identifier -> Manager -> m (Maybe Discovery)
    discoverHTML ident' :: Identifier
    ident'@(Identifier Text
    ident) Manager
    manager = do
        req <- IO Request -> m Request
    forall a. IO a -> m a
    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
    ident
        lbs <- liftM responseBody $ httpLbs req manager
        return $ parseHTML ident' . toStrict . decodeUtf8With lenientDecode $ lbs

    -- | Parse out an OpenID endpoint and an actual identifier from an HTML
    -- document.
    parseHTML :: Identifier -> Text -> Maybe Discovery
    parseHTML :: Identifier -> Text -> Maybe Discovery
    parseHTML Identifier
    ident Text
    text0 = do
        let doc :: Document
    doc = [Text] -> Document
    parseSTChunks [Text
    text0]
            cursor :: Cursor
    cursor = Document -> Cursor
    fromDocument Document
    doc
            links :: [Node]
    links = (Cursor -> Node) -> [Cursor] -> [Node]
    forall a b. (a -> b) -> [a] -> [b]
    map Cursor -> Node
    forall node. Cursor node -> node
    node ([Cursor] -> [Node]) -> [Cursor] -> [Node]
    forall a b. (a -> b) -> a -> b
    $ Cursor
    cursor Cursor -> (Cursor -> [Cursor]) -> [Cursor]
    forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
    $// Name -> Cursor -> [Cursor]
    element Name
    "link"
            ls :: [(Text, Text)]
    ls = do
              NodeElement (Element "link" as _) <- [Node]
    links
              Just rel <- pure $ Map.lookup "rel" as
              Just href <- pure $ Map.lookup "href" as
              guard $ "openid" `T.isPrefixOf` rel
              pure (rel, href)
        [(Text, Text)] -> Maybe Discovery
    forall {a}. (Eq a, IsString a) => [(a, Text)] -> Maybe Discovery
    resolve [(Text, Text)]
    ls
      where
        resolve1 :: [(a, Text)] -> Maybe Discovery
    resolve1 [(a, Text)]
    ls = do
          server <- a -> [(a, Text)] -> Maybe Text
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup a
    "openid.server" [(a, Text)]
    ls
          let delegate = a -> [(a, Text)] -> Maybe Text
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup a
    "openid.delegate" [(a, Text)]
    ls
          return $ Discovery1 server delegate
        resolve2 :: [(a, Text)] -> Maybe Discovery
    resolve2 [(a, Text)]
    ls = do
          prov <- a -> [(a, Text)] -> Maybe Text
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup a
    "openid2.provider" [(a, Text)]
    ls
          let lid = Identifier -> (Text -> Identifier) -> Maybe Text -> Identifier
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Identifier
    ident Text -> Identifier
    Identifier (Maybe Text -> Identifier) -> Maybe Text -> Identifier
    forall a b. (a -> b) -> a -> b
    $ a -> [(a, Text)] -> Maybe Text
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup a
    "openid2.local_id" [(a, Text)]
    ls
          -- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only
          -- result in a claimed identifier.
          return $ Discovery2 (Provider prov) lid ClaimedIdent

        resolve :: [(a, Text)] -> Maybe Discovery
    resolve [(a, Text)]
    ls = [(a, Text)] -> Maybe Discovery
    forall {a}. (Eq a, IsString a) => [(a, Text)] -> Maybe Discovery
    resolve2 [(a, Text)]
    ls Maybe Discovery -> Maybe Discovery -> Maybe Discovery
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` [(a, Text)] -> Maybe Discovery
    forall {a}. (Eq a, IsString a) => [(a, Text)] -> Maybe Discovery
    resolve1 [(a, Text)]
    ls