tea-cleaner: Read configuration file

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