Add gitea spam user cleaning script

tea-cleaner/TeaCleaner/Client.hs

@@ -0,0 +1,85 @@
+module TeaCleaner.Client
+    ( getActivities
+    , getUsers
+    , purgeUser
+    ) where
+
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Vector (Vector)
+import Text.URI (URI(..))
+import qualified Text.URI as URI
+import qualified Text.URI.QQ as URI
+import TeaCleaner.Types (Activity(..), User(..))
+import qualified Data.ByteString.Char8 as Char8
+import Network.HTTP.Req
+    ( DELETE(..)
+    , GET(..)
+    , NoReqBody(..)
+    , defaultHttpConfig
+    , ignoreResponse
+    , jsonResponse
+    , oAuth2Bearer
+    , responseBody
+    , req
+    , runReq
+    , useHttpsURI
+    )
+import GHC.Records (HasField(..))
+
+purgeUser :: String -> URI -> User -> IO ()
+purgeUser token server 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 case useHttpsURI uri of
+        Just (httpsURI, httpsOptions) -> fmap responseBody
+            $ runReq defaultHttpConfig
+            $ req DELETE httpsURI NoReqBody ignoreResponse
+            $ httpsOptions <> oAuth2Bearer (Char8.pack token)
+        Nothing -> error "Invalid https URI"
+
+getActivities :: String -> URI -> User -> IO (Vector Activity)
+getActivities token server 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 case useHttpsURI uri of
+        Just (httpsURI, httpsOptions) -> fmap responseBody
+            $ runReq defaultHttpConfig
+            $ req GET httpsURI NoReqBody jsonResponse
+            $ httpsOptions <> oAuth2Bearer (Char8.pack token)
+        Nothing -> error "Invalid https URI"
+
+getUsers :: String -> URI -> IO (Vector User)
+getUsers token server =
+    let pathPieces = [URI.pathPiece|api|] :|
+            [ [URI.pathPiece|v1|]
+            , [URI.pathPiece|admin|]
+            , [URI.pathPiece|users|]
+            ]
+        uri = server
+            { URI.uriPath = Just (False, pathPieces)
+            }
+     in case useHttpsURI uri of
+        Just (httpsURI, httpsOptions) -> fmap responseBody
+            $ runReq defaultHttpConfig
+            $ req GET httpsURI NoReqBody jsonResponse
+            $ httpsOptions <> oAuth2Bearer (Char8.pack token)
+        Nothing -> error "Invalid https URI"

tea-cleaner/TeaCleaner/Options.hs

@@ -0,0 +1,24 @@
+module TeaCleaner.Options
+    ( jsonOptions
+    ) where
+
+import qualified Data.Aeson.TH as Aeson
+import Prelude hiding (id)
+import Data.Char
+
+applyFirst :: (Char -> Char) -> String -> String
+applyFirst _ []     = []
+applyFirst f [x]    = [f x]
+applyFirst f (x:xs) = f x: xs
+
+-- | Generic casing for symbol separated names
+symbCase :: String -> String
+symbCase = u . applyFirst toLower
+  where u []                       = []
+        u (x:xs) | isUpper x = '_' : toLower x : u xs
+                 | otherwise = x : u xs
+
+jsonOptions :: Aeson.Options
+jsonOptions = Aeson.defaultOptions
+    { Aeson.fieldLabelModifier = symbCase
+    }

tea-cleaner/TeaCleaner/Types.hs

@@ -0,0 +1,53 @@
+module TeaCleaner.Types
+    ( Activity(..)
+    , User(..)
+    ) where
+
+import TeaCleaner.Options (jsonOptions)
+import Data.Int (Int64)
+import Data.Text (Text)
+import qualified Data.Aeson.TH as Aeson
+import Data.Time (ZonedTime(..))
+
+data User = User
+    { id :: Int64
+    , login :: Text
+    , loginName :: Text
+    , fullName :: Text
+    , email :: Text
+    , avatarUrl :: Text
+    , language :: Text
+    , isAdmin :: Bool
+    , lastLogin :: ZonedTime
+    , created :: ZonedTime
+    , restricted :: Bool
+    , active :: Bool
+    , prohibitLogin :: Bool
+    , location :: Text
+    , website :: Text
+    , description :: Text
+    , visibility :: Text
+    , followersCount :: Int
+    , followingCount :: Int
+    , starredReposCount :: Int
+    , username :: Text
+    } deriving (Show)
+
+$(Aeson.deriveJSON jsonOptions ''User)
+
+data Activity = Activity
+    { actUserId :: Int64
+    -- , comment Comment
+    , commentId :: Int64
+    , content :: Text
+    , created :: ZonedTime
+    , id :: Int64
+    , isPrivate :: Bool
+    , opType :: Text
+    , refName :: Text
+    -- repo	Repository{...}
+    , repoId :: Int64
+    , userId :: Int64
+    } deriving (Show)
+
+$(Aeson.deriveJSON jsonOptions ''Activity)