From 06fa97bfcf255fd033d3b5bd77d77d68ec8beef6 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Tue, 18 Feb 2025 11:57:18 +0100 Subject: tea-cleaner: Read configuration file --- tea-cleaner/TeaCleaner/Client.hs | 45 +++++++++++---------- tea-cleaner/TeaCleaner/CommandLine.hs | 45 --------------------- tea-cleaner/TeaCleaner/Configuration.hs | 72 +++++++++++++++++++++++++++++++++ tea-cleaner/TeaCleaner/Filter.hs | 41 ++++++++++++------- 4 files changed, 122 insertions(+), 81 deletions(-) delete mode 100644 tea-cleaner/TeaCleaner/CommandLine.hs create mode 100644 tea-cleaner/TeaCleaner/Configuration.hs (limited to 'tea-cleaner/TeaCleaner') diff --git a/tea-cleaner/TeaCleaner/Client.hs b/tea-cleaner/TeaCleaner/Client.hs index af84514..5afd6a5 100644 --- a/tea-cleaner/TeaCleaner/Client.hs +++ b/tea-cleaner/TeaCleaner/Client.hs @@ -10,13 +10,17 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (StrictText) import qualified Data.Text.Encoding as Text.Encoding import Data.Vector (Vector) -import Text.URI (URI(..)) 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 @@ -31,6 +35,9 @@ 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 @@ -75,8 +82,8 @@ data Activity = Activity $(Aeson.deriveJSON jsonOptions ''Activity) -purgeUser :: URI -> StrictText -> User -> IO () -purgeUser server token user = +purgeUser :: Settings -> User -> IO () +purgeUser Settings{..} user = let pathConstructor lastPiece = [URI.pathPiece|api|] :| [ [URI.pathPiece|v1|] , [URI.pathPiece|admin|] @@ -88,15 +95,10 @@ purgeUser server token user = <$> 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 (Text.Encoding.encodeUtf8 token) - Nothing -> error "Invalid https URI" + in doRequest uri token DELETE NoReqBody ignoreResponse -getActivities :: URI -> StrictText -> User -> IO (Vector Activity) -getActivities server token user = +getActivities :: Settings -> User -> IO (Vector Activity) +getActivities Settings{..} user = let pathConstructor lastPiece = [URI.pathPiece|api|] :| [ [URI.pathPiece|v1|] , [URI.pathPiece|users|] @@ -109,15 +111,10 @@ getActivities server token user = <$> 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 (Text.Encoding.encodeUtf8 token) - Nothing -> error "Invalid https URI" + in doRequest uri token GET NoReqBody jsonResponse -getUsers :: URI -> StrictText -> IO (Vector User) -getUsers server token = +getUsers :: Settings -> IO (Vector User) +getUsers Settings{..} = let pathPieces = [URI.pathPiece|api|] :| [ [URI.pathPiece|v1|] , [URI.pathPiece|admin|] @@ -126,9 +123,15 @@ getUsers server token = uri = server { URI.uriPath = Just (False, pathPieces) } - in case useHttpsURI uri of + 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 GET httpsURI NoReqBody jsonResponse + $ req method httpsURI body response $ httpsOptions <> oAuth2Bearer (Text.Encoding.encodeUtf8 token) Nothing -> error "Invalid https URI" diff --git a/tea-cleaner/TeaCleaner/CommandLine.hs b/tea-cleaner/TeaCleaner/CommandLine.hs deleted file mode 100644 index b74263d..0000000 --- a/tea-cleaner/TeaCleaner/CommandLine.hs +++ /dev/null @@ -1,45 +0,0 @@ -module TeaCleaner.CommandLine - ( ProgramOptions(..) - , commandLineInfo - , execParser - ) where - -import Data.Text (Text) -import Options.Applicative - ( Parser - , ParserInfo - , (<**>) - , argument - , execParser - , fullDesc - , help - , helper - , info - , long - , metavar - , progDesc - , str - , switch - ) - -data ProgramOptions = ProgramOptions - { server :: Text - , token :: Text - , liveRun :: Bool - } deriving (Eq, Show) - -commandLineInfo :: ParserInfo ProgramOptions -commandLineInfo = info (commandLine <**> helper) - $ fullDesc <> progDesc "Helps to detect some spam gitea accounts" - -commandLine :: Parser ProgramOptions -commandLine = ProgramOptions - <$> serverOption - <*> tokenOption - <*> liveRunOption - where - serverOption = argument str - $ metavar "SERVER" <> help "Gitea server URL" - tokenOption = argument str - $ metavar "TOKEN" <> help "Access token" - liveRunOption = switch $ long "live-run" <> help "Purge suspicious users" diff --git a/tea-cleaner/TeaCleaner/Configuration.hs b/tea-cleaner/TeaCleaner/Configuration.hs new file mode 100644 index 0000000..a7342d3 --- /dev/null +++ b/tea-cleaner/TeaCleaner/Configuration.hs @@ -0,0 +1,72 @@ +module TeaCleaner.Configuration + ( ProgramOptions(..) + , Settings(..) + , decodeSettingsFile + , commandLineInfo + , execParser + ) where + +import GHC.Records (HasField(..)) +import Data.Text (StrictText) +import qualified Toml +import Toml ((.=)) +import Options.Applicative + ( Parser + , ParserInfo + , (<**>) + , execParser + , fullDesc + , help + , helper + , info + , long + , progDesc + , switch + ) +import Text.URI (URI) +import qualified Text.URI as URI +import Data.Time (UTCTime(..), getCurrentTime) + +data ConfigFile = ConfigFile + { token :: StrictText + , server :: StrictText + } deriving (Eq, Show) + +configFileCodec :: Toml.TomlCodec ConfigFile +configFileCodec = ConfigFile + <$> Toml.text "token" .= getField @"token" + <*> Toml.text "server" .= getField @"server" + +data Settings = Settings + { token :: StrictText + , server :: URI + , now :: UTCTime + } deriving (Eq, Show) + +decodeSettingsFile :: FilePath -> IO Settings +decodeSettingsFile configPath = Toml.decodeFile configFileCodec configPath + >>= withConfiguration + where + withConfiguration configFile@ConfigFile{ server } = URI.mkURI server + >>= withServer configFile + withServer configFile parsedServer = getCurrentTime + >>= withTime configFile parsedServer + withTime ConfigFile{..} parsedServer now = pure $ Settings + { token = token + , server = parsedServer + , now = now + } + +newtype ProgramOptions = ProgramOptions + { liveRun :: Bool + } deriving (Eq, Show) + +commandLineInfo :: ParserInfo ProgramOptions +commandLineInfo = info (commandLine <**> helper) + $ fullDesc <> progDesc "Helps to detect some spam gitea accounts" + +commandLine :: Parser ProgramOptions +commandLine = ProgramOptions + <$> liveRunOption + where + liveRunOption = switch $ long "live-run" <> help "Purge suspicious users" diff --git a/tea-cleaner/TeaCleaner/Filter.hs b/tea-cleaner/TeaCleaner/Filter.hs index c4f243e..8448ff5 100644 --- a/tea-cleaner/TeaCleaner/Filter.hs +++ b/tea-cleaner/TeaCleaner/Filter.hs @@ -1,32 +1,43 @@ module TeaCleaner.Filter - ( filterByActivities + ( FilterResult(..) + , UserFilter(..) + , filterByActivities , filterByUserProperties ) where -import Data.Text (StrictText) import qualified Data.Text as Text import Data.Time (LocalTime(..), ZonedTime(..)) import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) import qualified Data.Vector as Vector -import Text.URI (URI) import TeaCleaner.Client (Activity(..), User(..), getActivities) +import TeaCleaner.Configuration (Settings(..)) -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) +data UserFilter + = PassFilter + | SuspiciousFilter + | FailedFilter + deriving (Eq, Show) + +data FilterResult = FilterResult User UserFilter + deriving (Show) + +filterByUserProperties :: User -> FilterResult +filterByUserProperties user@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) = FilterResult user SuspiciousFilter + | otherwise = FilterResult user PassFilter where zonedDay = localDay . zonedTimeToLocalTime -filterByActivities :: URI -> StrictText -> User -> IO Bool -filterByActivities server token user - = getActivities server token user +filterByActivities :: Settings -> User -> IO FilterResult +filterByActivities settings user = getActivities settings user >>= evalActivities where evalActivities activities | Just (Activity{ opType }, rest) <- Vector.uncons activities - , Vector.null rest = pure $ opType == "create_repo" - evalActivities _ = pure False + , Vector.null rest + , opType == "create_repo" = pure $ FilterResult user SuspiciousFilter + evalActivities _ = pure $ FilterResult user PassFilter -- cgit v1.2.3