1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Web.Authenticate.OpenId
( -- * Functions
getForwardUrl
, authenticate
, authenticateClaimed
-- * Types
, AuthenticateException (..)
, Identifier (..)
-- ** Response
, OpenIdResponse
, oirOpLocal
, oirParams
, oirClaimed
) where
import Control.Monad.IO.Class
import OpenId2.Normalization (normalize)
import OpenId2.Discovery (discover, Discovery (..))
import OpenId2.Types
import Control.Monad (unless)
import qualified Data.Text as T
import Data.Text.Lazy.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Lazy (toStrict)
import Network.HTTP.Conduit
( parseUrl, urlEncodedBody, responseBody, httpLbs
, Manager
)
import Control.Arrow ((***), second)
import Data.List (unfoldr)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Blaze.ByteString.Builder (toByteString)
import Network.HTTP.Types (renderQueryText)
import Control.Exception (throwIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (MonadResource)
getForwardUrl
:: (MonadResource m, MonadBaseControl IO m)
=> Text -- ^ The openid the user provided.
-> Text -- ^ The URL for this application\'s complete page.
-> Maybe Text -- ^ Optional realm
-> [(Text, Text)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.
-> Manager
-> m Text -- ^ URL to send the user to.
getForwardUrl openid' complete mrealm params manager = do
let realm = fromMaybe complete mrealm
claimed <- normalize $ T.strip openid'
disc <- discover claimed manager
let helper s q = return $ T.concat
[ s
, if "?" `T.isInfixOf` s then "&" else "?"
, decodeUtf8 (toByteString $ renderQueryText False $ map (second Just) q)
]
case disc of
Discovery1 server mdelegate -> helper server
$ ("openid.mode", "checkid_setup")
: ("openid.identity", maybe (identifier claimed) id mdelegate)
: ("openid.return_to", complete)
: ("openid.realm", realm)
: ("openid.trust_root", complete)
: params
Discovery2 (Provider p) (Identifier i) itype -> do
let (claimed', identity') =
case itype of
ClaimedIdent -> (identifier claimed, i)
OPIdent ->
let x = "http://specs.openid.net/auth/2.0/identifier_select"
in (x, x)
helper p
$ ("openid.ns", "http://specs.openid.net/auth/2.0")
: ("openid.mode", "checkid_setup")
: ("openid.claimed_id", claimed')
: ("openid.identity", identity')
: ("openid.return_to", complete)
: ("openid.realm", realm)
: params
authenticate
:: (MonadBaseControl IO m, MonadResource m, MonadIO m)
=> [(Text, Text)]
-> Manager
-> m (Identifier, [(Text, Text)])
authenticate ps m = do
x <- authenticateClaimed ps m
return (oirOpLocal x, oirParams x)
{-# DEPRECATED authenticate "Use authenticateClaimed" #-}
data OpenIdResponse = OpenIdResponse
{ oirOpLocal :: Identifier
, oirParams :: [(Text, Text)]
, oirClaimed :: Maybe Identifier
}
authenticateClaimed
:: (MonadBaseControl IO m, MonadResource m, MonadIO m)
=> [(Text, Text)]
-> Manager
-> m OpenIdResponse
authenticateClaimed params manager = do
unless (lookup "openid.mode" params == Just "id_res")
$ liftIO $ throwIO $ case lookup "openid.mode" params of
Nothing -> AuthenticationException "openid.mode was not found in the params."
(Just m)
| m == "error" ->
case lookup "openid.error" params of
Nothing -> AuthenticationException "An error occurred, but no error message was provided."
(Just e) -> AuthenticationException $ unpack e
| otherwise -> AuthenticationException $ "mode is " ++ unpack m ++ " but we were expecting id_res."
ident <- case lookup "openid.identity" params of
Just i -> return i
Nothing ->
liftIO $ throwIO $ AuthenticationException "Missing identity"
discOP <- normalize ident >>= flip discover manager
let endpoint d =
case d of
Discovery1 p _ -> p
Discovery2 (Provider p) _ _ -> p
let params' = map (encodeUtf8 *** encodeUtf8)
$ ("openid.mode", "check_authentication")
: filter (\(k, _) -> k /= "openid.mode") params
req' <- liftIO $ parseUrl $ unpack $ endpoint discOP
let req = urlEncodedBody params' req'
rsp <- httpLbs req manager
let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp
claimed <-
case lookup "openid.claimed_id" params of
Nothing -> return Nothing
Just claimed' -> do
-- need to validate that this provider can speak for the given
-- claimed identifier
claimedN <- normalize claimed'
discC <- discover claimedN manager
return $
if endpoint discOP == endpoint discC
then Just claimedN
else Nothing
case lookup "is_valid" rps of
Just "true" -> return OpenIdResponse
{ oirOpLocal = Identifier ident
, oirParams = rps
, oirClaimed = claimed
}
_ -> liftIO $ throwIO $ AuthenticationException "OpenID provider did not validate"
-- | Turn a response body into a list of parameters.
parseDirectResponse :: Text -> [(Text, Text)]
parseDirectResponse =
map (pack *** pack) . unfoldr step . unpack
where
step [] = Nothing
step str = case split (== '\n') str of
(ps,rest) -> Just (split (== ':') ps,rest)
split :: (a -> Bool) -> [a] -> ([a],[a])
split p as = case break p as of
(xs,_:ys) -> (xs,ys)
pair -> pair
|
