Add gitea spam user cleaning script

.gitignore

@@ -1 +1,2 @@
-/build/
+/dist-newstyle/
+/config.toml

.hlint.yaml

@@ -0,0 +1,2 @@
+arguments:
+  - -XQuasiQuotes

kazbek.cabal

@@ -0,0 +1,37 @@
+cabal-version: 3.0
+name: kazbek
+version: 1.0
+synopsis: Various helper programs
+license: MPL-2.0
+license-file: LICENSE
+author: Eugen Wissner
+maintainer: belka@caraus.de
+copyright: (c) 2025 Eugen Wissner
+build-type: Simple
+
+common warnings
+    ghc-options: -Wall
+
+executable tea-cleaner
+    import: warnings
+    main-is: Main.hs
+    default-extensions:
+        TemplateHaskell,
+        OverloadedStrings,
+        QuasiQuotes,
+        DuplicateRecordFields
+    other-modules:
+        TeaCleaner.Client
+        TeaCleaner.Options
+        TeaCleaner.Types
+    build-depends:
+        aeson ^>= 2.2.3,
+        base ^>=4.20.0.0,
+        bytestring ^>= 0.12.2,
+        modern-uri ^>= 0.3.6,
+        req ^>= 3.13,
+        time >= 1.9 && < 2,
+        text ^>= 2.1,
+        vector ^>= 0.13.2
+    hs-source-dirs: tea-cleaner
+    default-language: GHC2024

tea-cleaner/Main.hs

@@ -0,0 +1,71 @@
+module Main
+    ( main
+    ) where
+
+import Data.Vector (Vector)
+import qualified Data.Text as Text
+import System.Environment (getArgs)
+import qualified Text.URI as URI
+import Data.Time (LocalTime(..), ZonedTime(..))
+import qualified Data.Vector as Vector
+import qualified Data.Text.IO as Text.IO
+import qualified Data.Text.Lazy.IO as Text.Lazy.IO
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import qualified Data.Text.Lazy.Builder.Int as Text.Builder
+import GHC.Records (HasField(..))
+import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
+import TeaCleaner.Types (Activity(..), User(..))
+import TeaCleaner.Client (getActivities, getUsers, purgeUser)
+
+filterByUserProperties :: User -> Bool
+filterByUserProperties User{ created, lastLogin, description, website }
+    = zonedDay created == zonedDay lastLogin
+    && zonedDay created > fromOrdinalDate 2024 1
+    && zonedDay created < fromOrdinalDate 2025 17
+    && not (Text.null description)
+    && not (Text.null website)
+  where
+    zonedDay = localDay . zonedTimeToLocalTime
+
+filterByActivities :: String -> URI.URI -> User -> IO Bool
+filterByActivities server token user
+    = getActivities server token user
+    >>= evalActivities
+  where
+    evalActivities activities
+        | Just (Activity{ opType }, rest) <- Vector.uncons activities
+        , Vector.null rest = pure $ opType == "create_repo"
+    evalActivities _ = pure False
+
+printUsers :: String -> URI.URI -> Vector User -> IO ()
+printUsers server token users = printCount
+    >> Vector.forM_ users printUser
+  where
+    printCount =
+        let count = Text.Builder.decimal $ Vector.length users
+         in Text.Lazy.IO.putStrLn
+            $ Text.Builder.toLazyText
+            $ "Count: " <> count
+    printUser user =
+        let value
+                = "  Website: " <> getField @"website" user <> "\n"
+                <> "  Created: " <> Text.pack (show $ getField @"created" user) <> "\n"
+                <> "  Last login: " <> Text.pack (show $ getField @"lastLogin" user) <> "\n"
+                <> "  Email: " <> getField @"email" user <> "\n"
+                <> "  Website: " <> getField @"website" user <> "\n"
+                <> "  Description: " <> getField @"description" user <> "\n"
+                <> "  Avatar: " <> getField @"avatarUrl" user <> "\n"
+                <> "\n"
+         in Text.IO.putStrLn (getField @"username" user <> "\n" <> value)
+            >> purgeUser server token user
+
+main :: IO ()
+main = getArgs >>= withArguments
+  where
+    withArguments [server, token]
+        = URI.mkURI (Text.pack server)
+        >>= withServer token
+    withArguments _ = putStrLn "Expected exactly two arguments: server URL and the access token."
+    withServer token server = getUsers token server
+        >>= Vector.filterM (filterByActivities token server) . Vector.filter filterByUserProperties
+        >>= printUsers token server

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)