blob: e83ec2cfdb45e69fa83bec962c07b44979020d38 (
plain) (
blame)
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
|
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
module GoogleSignIn where
--------------------------------------------------------------------------------
import Data.String.Conversions (cs)
import Data.Text (Text)
import Web.JWT
import Utils
import qualified Network.HTTP.Simple as HTTP
import qualified Data.Text as Text
import qualified Web.JWT as JWT
import qualified Data.Time.Clock.POSIX as POSIX
--------------------------------------------------------------------------------
newtype EncodedJWT = EncodedJWT Text
-- | Some of the errors that a JWT
data ValidationResult
= Valid
| DecodeError
| GoogleSaysInvalid Text
| NoMatchingClientIDs [StringOrURI]
| WrongIssuer StringOrURI
| StringOrURIParseFailure Text
| TimeConversionFailure
| MissingRequiredClaim Text
| StaleExpiry NumericDate
deriving (Eq, Show)
-- | Returns True when the supplied `jwt` meets the following criteria:
-- * The token has been signed by Google
-- * The value of `aud` matches my Google client's ID
-- * The value of `iss` matches is "accounts.google.com" or
-- "https://accounts.google.com"
-- * The `exp` time has not passed
--
-- Set `skipHTTP` to `True` to avoid making the network request for testing.
jwtIsValid :: Bool
-> EncodedJWT
-> IO ValidationResult
jwtIsValid skipHTTP (EncodedJWT encodedJWT) = do
case encodedJWT |> decode of
Nothing -> pure DecodeError
Just jwt -> do
if skipHTTP then
continue jwt
else do
let request = "https://oauth2.googleapis.com/tokeninfo"
|> HTTP.setRequestQueryString [ ( "id_token", Just (cs encodedJWT) ) ]
res <- HTTP.httpLBS request
if HTTP.getResponseStatusCode res /= 200 then
pure $ GoogleSaysInvalid (res |> HTTP.getResponseBody |> cs)
else
continue jwt
where
continue :: JWT UnverifiedJWT -> IO ValidationResult
continue jwt = do
let audValues :: [StringOrURI]
audValues = jwt |> claims |> auds
expectedClientID :: Text
expectedClientID = "771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"
expectedIssuers :: [Text]
expectedIssuers = [ "accounts.google.com"
, "https://accounts.google.com"
]
mExpectedClientID :: Maybe StringOrURI
mExpectedClientID = stringOrURI expectedClientID
mExpectedIssuers :: Maybe [StringOrURI]
mExpectedIssuers = expectedIssuers |> traverse stringOrURI
case (mExpectedClientID, mExpectedIssuers) of
(Nothing, _) -> pure $ StringOrURIParseFailure expectedClientID
(_, Nothing) -> pure $ StringOrURIParseFailure (Text.unwords expectedIssuers)
(Just clientID, Just parsedIssuers) ->
-- TODO: Prefer reading clientID from a config. I'm thinking of the
-- AppContext type having my Configuration
if not $ clientID `elem` audValues then
pure $ NoMatchingClientIDs audValues
else
case (jwt |> claims |> iss, jwt |> claims |> JWT.exp) of
(Nothing, _) -> pure $ MissingRequiredClaim "iss"
(_, Nothing) -> pure $ MissingRequiredClaim "exp"
(Just jwtIssuer, Just jwtExpiry) ->
if not $ jwtIssuer `elem` parsedIssuers then
pure $ WrongIssuer jwtIssuer
else do
mCurrentTime <- POSIX.getPOSIXTime |> fmap numericDate
case mCurrentTime of
Nothing -> pure TimeConversionFailure
Just currentTime ->
if not $ currentTime <= jwtExpiry then
pure $ StaleExpiry jwtExpiry
else
pure Valid
|
