{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module OpenId2.Discovery (
discover
, Discovery (..)
) where
import OpenId2.Types
import OpenId2.XRDS
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
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
discoverYADIS :: MonadIO m
=> Identifier
-> Maybe String
-> Int
-> 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
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))
, (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)
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
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
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