tea-cleaner: Read configuration file

kazbek.cabal

@@ -23,7 +23,7 @@ executable tea-cleaner
         RecordWildCards
     other-modules:
         TeaCleaner.Client
-        TeaCleaner.CommandLine
+        TeaCleaner.Configuration
         TeaCleaner.Filter
         TeaCleaner.Options
     build-depends:
@@ -35,6 +35,7 @@ executable tea-cleaner
         req ^>= 3.13,
         time >= 1.9 && < 2,
         text ^>= 2.1,
+        tomland ^>= 1.3.3,
         vector ^>= 0.13.2
     hs-source-dirs: tea-cleaner
     default-language: GHC2024

tea-cleaner/Main.hs

@@ -2,30 +2,45 @@ module Main
     ( main
     ) where
 
-import Data.Text (StrictText)
 import Data.Vector (Vector)
 import qualified Data.Text as Text
-import Text.URI (URI, mkURI)
 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 TeaCleaner.Filter (filterByActivities, filterByUserProperties)
+import TeaCleaner.Filter
+    ( UserFilter(..)
+    , FilterResult(..)
+    , filterByActivities
+    , filterByUserProperties
+    )
 import TeaCleaner.Client (User(..), getUsers, purgeUser)
-import TeaCleaner.CommandLine (ProgramOptions(..), commandLineInfo, execParser)
+import TeaCleaner.Configuration
+    ( ProgramOptions(..)
+    , Settings(..)
+    , decodeSettingsFile
+    , commandLineInfo
+    , execParser
+    )
+import Control.Monad (when)
 
-printUsers :: URI -> StrictText -> Bool -> Vector User -> IO ()
-printUsers server token liveRun users = printCount
-    >> Vector.forM_ users (printUser liveRun)
+handleResults :: Settings -> Bool -> Vector User -> IO ()
+handleResults settings liveRun users = printCount
+    >> Vector.forM_ users (handleResult settings liveRun)
   where
     printCount =
         let count = Text.Builder.decimal $ Vector.length users
          in Text.Lazy.IO.putStrLn
             $ Text.Builder.toLazyText
             $ "Count: " <> count
-    buildValue user = getField @"username" user <> "\n"
+
+handleResult :: Settings -> Bool -> User -> IO ()
+handleResult settings liveRun user = Text.IO.putStrLn buildValue
+    >> when liveRun (purgeUser settings user)
+  where
+    buildValue = getField @"username" user <> "\n"
         <> "  Website: " <> getField @"website" user <> "\n"
         <> "  Created: " <> Text.pack (show $ getField @"created" user) <> "\n"
         <> "  Last login: " <> Text.pack (show $ getField @"lastLogin" user) <> "\n"
@@ -34,14 +49,23 @@ printUsers server token liveRun users = printCount
         <> "  Description: " <> getField @"description" user <> "\n"
         <> "  Avatar: " <> getField @"avatarUrl" user <> "\n"
         <> "\n"
-    printUser True user = Text.IO.putStrLn (buildValue user)
-        >> purgeUser server token user
-    printUser False user = Text.IO.putStrLn (buildValue user)
 
 main :: IO ()
 main = execParser commandLineInfo >>= withArguments
   where
-    withArguments ProgramOptions{..} = mkURI server >>= withServer liveRun token
-    withServer liveRun token server = getUsers server token
-        >>= Vector.filterM (filterByActivities server token) . Vector.filter filterByUserProperties
-        >>= printUsers server token liveRun
+    withArguments ProgramOptions{ liveRun } = decodeSettingsFile "config/tea-cleaner.toml"
+        >>= withSettings liveRun
+
+withSettings :: Bool -> Settings -> IO ()
+withSettings liveRun settings = getUsers settings
+    >>= Vector.foldM' foldFilterResult Vector.empty . fmap filterByUserProperties
+    >>= traverse (filterByActivities settings)
+    >>= Vector.foldM' foldFilterResult Vector.empty
+    >>= handleResults settings liveRun
+  where
+    foldFilterResult accumulator (FilterResult user SuspiciousFilter)
+        = pure $ Vector.snoc accumulator user
+    foldFilterResult accumulator (FilterResult _ PassFilter) = pure accumulator
+    foldFilterResult accumulator (FilterResult user FailedFilter)
+        = handleResult settings liveRun user
+        >> pure accumulator

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"

tea-cleaner/TeaCleaner/CommandLine.hs

@@ -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"

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"

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