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
|
{-# 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,
)
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)
-- | 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
|
