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
|
{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
module TeaCleaner.Client
( Activity(..)
, User(..)
, getActivities
, getUsers
, purgeUser
) where
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (StrictText)
import qualified Data.Text.Encoding as Text.Encoding
import Data.Vector (Vector)
import qualified Text.URI as URI
import qualified Text.URI.QQ as URI
import Network.HTTP.Req
( DELETE(..)
, GET(..)
, NoReqBody(..)
, HttpMethod(..)
, HttpBody
, HttpResponse(..)
, HttpBodyAllowed
, ProvidesBody
, defaultHttpConfig
, ignoreResponse
, jsonResponse
, oAuth2Bearer
, responseBody
, req
, runReq
, useHttpsURI
)
import GHC.Records (HasField(..))
import TeaCleaner.Options (jsonOptions)
import Data.Int (Int64)
import qualified Data.Aeson.TH as Aeson
import Data.Time (ZonedTime(..))
import TeaCleaner.Configuration (Settings(..))
import Data.Data (Proxy)
import Text.URI (URI)
data User = User
{ id :: Int64
, login :: StrictText
, loginName :: StrictText
, fullName :: StrictText
, email :: StrictText
, avatarUrl :: StrictText
, language :: StrictText
, isAdmin :: Bool
, lastLogin :: ZonedTime
, created :: ZonedTime
, restricted :: Bool
, active :: Bool
, prohibitLogin :: Bool
, location :: StrictText
, website :: StrictText
, description :: StrictText
, visibility :: StrictText
, followersCount :: Int
, followingCount :: Int
, starredReposCount :: Int
, username :: StrictText
} deriving (Show)
$(Aeson.deriveJSON jsonOptions ''User)
data Activity = Activity
{ actUserId :: Int64
-- , comment Comment
, commentId :: Int64
, content :: StrictText
, created :: ZonedTime
, id :: Int64
, isPrivate :: Bool
, opType :: StrictText
, refName :: StrictText
-- repo Repository{...}
, repoId :: Int64
, userId :: Int64
} deriving (Show)
$(Aeson.deriveJSON jsonOptions ''Activity)
purgeUser :: Settings -> User -> IO ()
purgeUser Settings{..} user =
let pathConstructor lastPiece = [URI.pathPiece|api|] :|
[ [URI.pathPiece|v1|]
, [URI.pathPiece|admin|]
, [URI.pathPiece|users|]
, lastPiece
]
uri = server
{ URI.uriPath = (False,) . pathConstructor
<$> URI.mkPathPiece (getField @"username" user)
, URI.uriQuery = [URI.QueryParam [URI.queryKey|purge|] [URI.queryValue|true|]]
}
in doRequest uri token DELETE NoReqBody ignoreResponse
getActivities :: Settings -> User -> IO (Vector Activity)
getActivities Settings{..} user =
let pathConstructor lastPiece = [URI.pathPiece|api|] :|
[ [URI.pathPiece|v1|]
, [URI.pathPiece|users|]
, lastPiece
, [URI.pathPiece|activities|]
, [URI.pathPiece|feeds|]
]
uri = server
{ URI.uriPath = (False,) . pathConstructor
<$> URI.mkPathPiece (getField @"username" user)
, URI.uriQuery = [URI.QueryParam [URI.queryKey|purge|] [URI.queryValue|true|]]
}
in doRequest uri token GET NoReqBody jsonResponse
getUsers :: Settings -> IO (Vector User)
getUsers Settings{..} =
let pathPieces = [URI.pathPiece|api|] :|
[ [URI.pathPiece|v1|]
, [URI.pathPiece|admin|]
, [URI.pathPiece|users|]
]
uri = server
{ URI.uriPath = Just (False, pathPieces)
}
in doRequest uri token GET NoReqBody jsonResponse
doRequest
:: (HttpMethod method, HttpBody body, HttpResponse response, HttpBodyAllowed (AllowsBody method) (ProvidesBody body))
=> URI -> StrictText -> method -> body -> Proxy response -> IO (HttpResponseBody response)
doRequest uri token method body response =
case useHttpsURI uri of
Just (httpsURI, httpsOptions) -> fmap responseBody
$ runReq defaultHttpConfig
$ req method httpsURI body response
$ httpsOptions <> oAuth2Bearer (Text.Encoding.encodeUtf8 token)
Nothing -> error "Invalid https URI"
|
