diff options
| -rw-r--r-- | .gitignore | 3 | ||||
| -rw-r--r-- | .hlint.yaml | 2 | ||||
| -rw-r--r-- | kazbek.cabal | 37 | ||||
| -rw-r--r-- | tea-cleaner/Main.hs | 71 | ||||
| -rw-r--r-- | tea-cleaner/TeaCleaner/Client.hs | 85 | ||||
| -rw-r--r-- | tea-cleaner/TeaCleaner/Options.hs | 24 | ||||
| -rw-r--r-- | tea-cleaner/TeaCleaner/Types.hs | 53 |
7 files changed, 274 insertions, 1 deletions
@@ -1 +1,2 @@ -/build/ +/dist-newstyle/ +/config.toml diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..3950375 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,2 @@ +arguments: + - -XQuasiQuotes diff --git a/kazbek.cabal b/kazbek.cabal new file mode 100644 index 0000000..071ff75 --- /dev/null +++ b/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 diff --git a/tea-cleaner/Main.hs b/tea-cleaner/Main.hs new file mode 100644 index 0000000..bfad0f7 --- /dev/null +++ b/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 diff --git a/tea-cleaner/TeaCleaner/Client.hs b/tea-cleaner/TeaCleaner/Client.hs new file mode 100644 index 0000000..1556be6 --- /dev/null +++ b/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" diff --git a/tea-cleaner/TeaCleaner/Options.hs b/tea-cleaner/TeaCleaner/Options.hs new file mode 100644 index 0000000..7353f8f --- /dev/null +++ b/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 + } diff --git a/tea-cleaner/TeaCleaner/Types.hs b/tea-cleaner/TeaCleaner/Types.hs new file mode 100644 index 0000000..786dedb --- /dev/null +++ b/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) |