{-# 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
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 :: forall (m :: * -> *).
MonadIO m =>
Identifier -> Manager -> m Discovery
discover ident :: Identifier
ident@(Identifier Text
i) Manager
manager = do
    Maybe (Provider, Identifier, IdentType)
res1 <- forall (m :: * -> *).
MonadIO m =>
Identifier
-> Maybe String
-> Int
-> Manager
-> m (Maybe (Provider, Identifier, IdentType))
discoverYADIS Identifier
ident forall a. Maybe a
Nothing Int
10 Manager
manager
    case Maybe (Provider, Identifier, IdentType)
res1 of
        Just (Provider
x, Identifier
y, IdentType
z) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *).
MonadIO m =>
Identifier -> Manager -> m (Maybe Discovery)
discoverHTML Identifier
ident Manager
manager
            case Maybe Discovery
res2 of
                Just Discovery
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Discovery
x
                Maybe Discovery
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
DiscoveryException 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)
    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 = forall a. a -> Maybe a -> a
fromMaybe (Text -> String
unpack 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
uri
#else
    req <- liftIO $ parseUrl uri
#endif
    Response ByteString
res <- 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
S8.unpack
             forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"x-xrds-location"
             forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. CI s -> s
CI.original)
             forall a b. (a -> b) -> a -> b
$ forall body. Response body -> ResponseHeaders
responseHeaders Response ByteString
res
    let mloc' :: Maybe String
mloc' = if Maybe String
mloc forall a. Eq a => a -> a -> Bool
== Maybe String
mb_loc then forall a. Maybe a
Nothing else Maybe String
mloc
    if forall body. Response body -> Status
responseStatus Response ByteString
res forall a. Eq a => a -> a -> Bool
== Status
status200
        then
          case Maybe String
mloc' of
            Just String
loc -> forall (m :: * -> *).
MonadIO m =>
Identifier
-> Maybe String
-> Int
-> Manager
-> m (Maybe (Provider, Identifier, IdentType))
discoverYADIS Identifier
ident (forall a. a -> Maybe a
Just String
loc) (Int
redirects forall a. Num a => a -> a -> a
- Int
1) Manager
manager
            Maybe String
Nothing  -> do
              let mdoc :: Maybe XRDS
mdoc = ByteString -> Maybe XRDS
parseXRDS forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
responseBody Response ByteString
res
              case Maybe XRDS
mdoc of
                  Just XRDS
doc -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Identifier -> XRDS -> Maybe (Provider, Identifier, IdentType)
parseYADIS Identifier
ident XRDS
doc
                  Maybe XRDS
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        else forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Service -> Maybe (Provider, Identifier, IdentType)
isOpenId forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Identifier
ident Text -> Identifier
Identifier forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Service -> [Text]
serviceLocalIDs Service
svc
        f :: (Text, a) -> Maybe a
f (Text
x,a
y) | Text
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
tys = forall a. a -> Maybe a
Just a
y
                | Bool
otherwise    = forall a. Maybe a
Nothing
    (Identifier
lid, IdentType
itype) <- forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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 <- forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ Service -> [Text]
serviceURIs Service
svc
    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 :: forall (m :: * -> *).
MonadIO m =>
Identifier -> Manager -> m (Maybe Discovery)
discoverHTML ident' :: Identifier
ident'@(Identifier Text
ident) Manager
manager = do
    Request
req <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
ident
    ByteString
lbs <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall body. Response body -> body
responseBody forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req Manager
manager
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Identifier -> Text -> Maybe Discovery
parseHTML Identifier
ident' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode 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 = forall a b. (a -> b) -> [a] -> [b]
map forall node. Cursor node -> node
node forall a b. (a -> b) -> a -> b
$ Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Axis
element Name
"link"
        ls :: [(Text, Text)]
ls = do
          NodeElement (Element Name
"link" Map Name Text
as [Node]
_) <- [Node]
links
          Just Text
rel <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
"rel" Map Name Text
as
          Just Text
href <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
"href" Map Name Text
as
          forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Text
"openid" Text -> Text -> Bool
`T.isPrefixOf` Text
rel
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
rel, Text
href)
    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 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"openid.server" [(a, Text)]
ls
      let delegate :: Maybe Text
delegate = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"openid.delegate" [(a, Text)]
ls
      forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"openid2.provider" [(a, Text)]
ls
      let lid :: Identifier
lid = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Identifier
ident Text -> Identifier
Identifier forall a b. (a -> b) -> a -> b
$ 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.
      forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall {a}. (Eq a, IsString a) => [(a, Text)] -> Maybe Discovery
resolve2 [(a, Text)]
ls forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall {a}. (Eq a, IsString a) => [(a, Text)] -> Maybe Discovery
resolve1 [(a, Text)]
ls