{-# 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