{-# 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
showList :: [Discovery] -> ShowS
$cshowList :: [Discovery] -> ShowS
show :: Discovery -> String
$cshow :: Discovery -> String
showsPrec :: Int -> Discovery -> ShowS
$cshowsPrec :: Int -> Discovery -> ShowS
Show

-- | Attempt to resolve an OpenID endpoint, and user identifier.
discover :: MonadIO m => Identifier -> Manager -> m Discovery
discover :: Identifier -> Manager -> m Discovery
discover ident :: Identifier
ident@(Identifier Text
i) Manager
manager = do
    Maybe (Provider, Identifier, IdentType)
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 Maybe (Provider, Identifier, IdentType)
res1 of
        Just (Provider
x, Identifier
y, IdentType
z) -> Discovery -> m Discovery
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
            Maybe Discovery
res2 <- Identifier -> Manager -> m (Maybe Discovery)
forall (m :: * -> *).
MonadIO m =>
Identifier -> Manager -> m (Maybe Discovery)
discoverHTML Identifier
ident Manager
manager
            case Maybe Discovery
res2 of
                Just Discovery
x -> Discovery -> m Discovery
forall (m :: * -> *) a. Monad m => a -> m a
return Discovery
x
                Maybe Discovery
Nothing -> IO Discovery -> m Discovery
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. 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 :: 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)
    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
parseRequest String
uri
#else
    req <- liftIO $ parseUrl uri
#endif
    Response ByteString
res <- Request -> Manager -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
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
manager
    let mloc :: Maybe String
mloc = (ByteString -> String) -> Maybe ByteString -> Maybe String
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 ((CI ByteString -> String) -> Header -> (String, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((CI ByteString -> String) -> Header -> (String, ByteString))
-> (CI ByteString -> 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 -> (CI ByteString -> String) -> CI ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack (ByteString -> String)
-> (CI ByteString -> ByteString) -> CI ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> 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' :: Maybe String
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 Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
res Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status200
        then
          case Maybe String
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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe (Provider, Identifier, IdentType)
forall a. Maybe a
Nothing
        else Maybe (Provider, Identifier, IdentType)
-> m (Maybe (Provider, Identifier, IdentType))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Provider, Identifier, IdentType)
forall a. Maybe a
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 (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
    (Identifier
lid, IdentType
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))
      ]
    Text
uri <- [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Service -> [Text]
serviceURIs Service
svc
    (Provider, Identifier, IdentType)
-> Maybe (Provider, Identifier, IdentType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Provider
Provider Text
uri, Identifier
lid, IdentType
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 :: Identifier -> Manager -> m (Maybe Discovery)
discoverHTML ident' :: Identifier
ident'@(Identifier Text
ident) Manager
manager = do
    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
ident
    ByteString
lbs <- (Response ByteString -> ByteString)
-> m (Response ByteString) -> m ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Response ByteString -> ByteString
forall body. Response body -> body
responseBody (m (Response ByteString) -> m ByteString)
-> m (Response ByteString) -> m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req Manager
manager
    Maybe Discovery -> m (Maybe Discovery)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Discovery -> m (Maybe Discovery))
-> Maybe Discovery -> m (Maybe Discovery)
forall a b. (a -> b) -> a -> b
$ Identifier -> Text -> Maybe Discovery
parseHTML Identifier
ident' (Text -> Maybe Discovery)
-> (ByteString -> Text) -> ByteString -> Maybe Discovery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Maybe Discovery) -> ByteString -> Maybe Discovery
forall a b. (a -> b) -> a -> b
$ ByteString
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 Name
"link" Map Name Text
as [Node]
_) <- [Node]
links
          Just Text
rel <- Maybe Text -> [Maybe Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> [Maybe Text]) -> Maybe Text -> [Maybe Text]
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
"rel" Map Name Text
as
          Just Text
href <- Maybe Text -> [Maybe Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> [Maybe Text]) -> Maybe Text -> [Maybe Text]
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
"href" Map Name Text
as
          Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Text
"openid" Text -> Text -> Bool
`T.isPrefixOf` Text
rel
          (Text, Text) -> [(Text, Text)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
rel, Text
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
      Text
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 :: Maybe Text
delegate = a -> [(a, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"openid.delegate" [(a, Text)]
ls
      Discovery -> Maybe Discovery
forall (m :: * -> *) a. Monad m => a -> m a
return (Discovery -> Maybe Discovery) -> Discovery -> Maybe Discovery
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Discovery
Discovery1 Text
server Maybe Text
delegate
    resolve2 :: [(a, Text)] -> Maybe Discovery
resolve2 [(a, Text)]
ls = do
      Text
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
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.
      Discovery -> Maybe Discovery
forall (m :: * -> *) a. Monad m => a -> m a
return (Discovery -> Maybe Discovery) -> Discovery -> Maybe Discovery
forall a b. (a -> b) -> a -> b
$ Provider -> Identifier -> IdentType -> Discovery
Discovery2 (Text -> Provider
Provider Text
prov) Identifier
lid IdentType
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 (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