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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | A module for common OAuth flows.
--
-- Consider using authenticate-oauth package
module Biz.Auth
( -- * OAuth
OAuthResponse (..),
OAuthArgs (..),
-- * GitHub Authentication
GitHub (..),
githubOauth,
-- * Servant Helpers
SetCookies,
liveCookieSettings,
testCookieSettings,
)
where
import Alpha
import qualified Data.Aeson as Aeson
import Network.HTTP.Req ((/:), (=:))
import qualified Network.HTTP.Req as Req
import Servant (Header, Headers)
import qualified Servant.Auth.Server as Auth
import qualified System.Envy as Envy
-- | Use this instead of 'mempty' for explicity.
notset :: Text
notset = "notset"
-- | Wrapper around 'Auth.SetCookie' that you can put in a servant path
-- descriptor.
type SetCookies ret =
(Headers '[Header "Set-Cookie" Auth.SetCookie, Header "Set-Cookie" Auth.SetCookie] ret)
liveCookieSettings :: Auth.CookieSettings
liveCookieSettings =
Auth.defaultCookieSettings
{ Auth.cookieIsSecure = Auth.Secure,
-- disable XSRF protection because we don't use any javascript
Auth.cookieXsrfSetting = Nothing
}
testCookieSettings :: Auth.CookieSettings
testCookieSettings =
Auth.defaultCookieSettings
{ Auth.cookieIsSecure = Auth.NotSecure,
Auth.cookieXsrfSetting = Nothing
}
-- | These are arguments that a 3rd-party OAuth provider needs in order for us
-- to authenticate a user.
data OAuthArgs = OAuthArgs
{ clientSecret :: Text,
clientId :: Text,
clientState :: Text
}
deriving (Generic, Show)
instance Envy.DefConfig OAuthArgs where
defConfig =
OAuthArgs
{ clientSecret = notset,
clientId = notset,
clientState = notset
}
instance Envy.FromEnv OAuthArgs
-- | A type for parsing JSON auth responses, used in 'githubOauth' below.
-- Should be moved to Biz.Auth with others.
data OAuthResponse = OAuthResponse
{ access_token :: Text,
scope :: Text,
token_type :: Text
}
deriving (Generic, Aeson.FromJSON)
newtype GitHub = GitHub OAuthArgs
deriving (Show, Generic)
instance Envy.DefConfig GitHub where
defConfig =
GitHub
<| OAuthArgs
{ clientSecret = notset,
clientId = notset,
clientState = notset
}
instance Envy.FromEnv GitHub where
fromEnv Nothing =
GitHub
</ Envy.gFromEnvCustom
Envy.Option
{ Envy.dropPrefixCount = 0,
Envy.customPrefix = "GITHUB"
}
Nothing
fromEnv (Just (GitHub x)) =
GitHub
</ Envy.gFromEnvCustom
Envy.Option
{ Envy.dropPrefixCount = 0,
Envy.customPrefix = "GITHUB"
}
(Just x)
-- | POST to GitHub's OAuth service and get the user's oAuth token.
githubOauth ::
GitHub ->
-- | This should be GitHub.Token but GitHub.Auth doesn't export Token.
Text ->
IO OAuthResponse
githubOauth (GitHub OAuthArgs {..}) code =
accessTokenRequest
/> Req.responseBody
|> Req.runReq Req.defaultHttpConfig
where
accessTokenRequest :: Req.Req (Req.JsonResponse OAuthResponse)
accessTokenRequest =
Req.req
Req.POST
(Req.https "github.com" /: "login" /: "oauth" /: "access_token")
Req.NoReqBody
Req.jsonResponse
<| "client_id" =: clientId
<> "client_secret" =: clientSecret
<> "code" =: code
<> "state" =: clientState
|
