tea-cleaner: Add command line parser

kazbek.cabal

@@ -19,16 +19,19 @@ executable tea-cleaner
         TemplateHaskell,
         OverloadedStrings,
         QuasiQuotes,
-        DuplicateRecordFields
+        DuplicateRecordFields,
+        RecordWildCards
     other-modules:
         TeaCleaner.Client
+        TeaCleaner.CommandLine
+        TeaCleaner.Filter
         TeaCleaner.Options
-        TeaCleaner.Types
     build-depends:
         aeson ^>= 2.2.3,
         base ^>=4.20.0.0,
         bytestring ^>= 0.12.2,
         modern-uri ^>= 0.3.6,
+        optparse-applicative ^>= 0.18.1,
         req ^>= 3.13,
         time >= 1.9 && < 2,
         text ^>= 2.1,

tea-cleaner/Main.hs

@@ -2,53 +2,31 @@ module Main
     ( main
     ) where
 
+import Data.Text (StrictText)
 import Data.Vector (Vector)
 import qualified Data.Text as Text
-import System.Environment (getArgs)
+import Text.URI (URI, mkURI)
-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.Filter (filterByActivities, filterByUserProperties)
-import TeaCleaner.Types (Activity(..), User(..))
+import TeaCleaner.Client (User(..), getUsers, purgeUser)
-import TeaCleaner.Client (getActivities, getUsers, purgeUser)
+import TeaCleaner.CommandLine (ProgramOptions(..), commandLineInfo, execParser)
 
-filterByUserProperties :: User -> Bool
+printUsers :: URI -> StrictText -> Bool -> Vector User -> IO ()
-filterByUserProperties User{ created, lastLogin, description, website }
+printUsers server token liveRun users = printCount
-    = zonedDay created == zonedDay lastLogin
+    >> Vector.forM_ users (printUser liveRun)
-    && 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 =
+    buildValue user = getField @"username" user <> "\n"
-        let value
+        <> "  Website: " <> getField @"website" user <> "\n"
-                = "  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"
@@ -56,16 +34,14 @@ printUsers server token users = printCount
         <> "  Description: " <> getField @"description" user <> "\n"
         <> "  Avatar: " <> getField @"avatarUrl" user <> "\n"
         <> "\n"
-         in Text.IO.putStrLn (getField @"username" user <> "\n" <> value)
+    printUser True user = Text.IO.putStrLn (buildValue user)
         >> purgeUser server token user
+    printUser False user = Text.IO.putStrLn (buildValue user)
 
 main :: IO ()
-main = getArgs >>= withArguments
+main = execParser commandLineInfo >>= withArguments
   where
-    withArguments [server, token]
+    withArguments ProgramOptions{..} = mkURI server >>= withServer liveRun token
-        = URI.mkURI (Text.pack server)
+    withServer liveRun token server = getUsers server token
-        >>= withServer token
+        >>= Vector.filterM (filterByActivities server token) . Vector.filter filterByUserProperties
-    withArguments _ = putStrLn "Expected exactly two arguments: server URL and the access token."
+        >>= printUsers server token liveRun
-    withServer token server = getUsers token server
-        >>= Vector.filterM (filterByActivities token server) . Vector.filter filterByUserProperties
-        >>= printUsers token server

tea-cleaner/TeaCleaner/Client.hs

@@ -1,16 +1,18 @@
 module TeaCleaner.Client
-    ( getActivities
+    ( Activity(..)
+    , User(..)
+    , getActivities
     , getUsers
     , purgeUser
     ) where
 
 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 TeaCleaner.Types (Activity(..), User(..))
-import qualified Data.ByteString.Char8 as Char8
 import Network.HTTP.Req
     ( DELETE(..)
     , GET(..)
@@ -25,9 +27,56 @@ import Network.HTTP.Req
     , useHttpsURI
     )
 import GHC.Records (HasField(..))
+import TeaCleaner.Options (jsonOptions)
+import Data.Int (Int64)
+import qualified Data.Aeson.TH as Aeson
+import Data.Time (ZonedTime(..))
 
-purgeUser :: String -> URI -> User -> IO ()
+data User = User
-purgeUser token server user =
+    { id :: Int64
+    , login :: StrictText
+    , loginName :: StrictText
+    , fullName :: StrictText
+    , email :: StrictText
+    , avatarUrl :: StrictText
+    , language :: StrictText
+    , isAdmin :: Bool
+    , lastLogin :: ZonedTime
+    , created :: ZonedTime
+    , restricted :: Bool
+    , active :: Bool
+    , prohibitLogin :: Bool
+    , location :: StrictText
+    , website :: StrictText
+    , description :: StrictText
+    , visibility :: StrictText
+    , followersCount :: Int
+    , followingCount :: Int
+    , starredReposCount :: Int
+    , username :: StrictText
+    } deriving (Show)
+
+$(Aeson.deriveJSON jsonOptions ''User)
+
+data Activity = Activity
+    { actUserId :: Int64
+    -- , comment Comment
+    , commentId :: Int64
+    , content :: StrictText
+    , created :: ZonedTime
+    , id :: Int64
+    , isPrivate :: Bool
+    , opType :: StrictText
+    , refName :: StrictText
+    -- repo	Repository{...}
+    , repoId :: Int64
+    , userId :: Int64
+    } deriving (Show)
+
+$(Aeson.deriveJSON jsonOptions ''Activity)
+
+purgeUser :: URI -> StrictText -> User -> IO ()
+purgeUser server token user =
     let pathConstructor lastPiece = [URI.pathPiece|api|] :|
             [ [URI.pathPiece|v1|]
             , [URI.pathPiece|admin|]
@@ -43,11 +92,11 @@ purgeUser token server user =
         Just (httpsURI, httpsOptions) -> fmap responseBody
             $ runReq defaultHttpConfig
             $ req DELETE httpsURI NoReqBody ignoreResponse
-            $ httpsOptions <> oAuth2Bearer (Char8.pack token)
+            $ httpsOptions <> oAuth2Bearer (Text.Encoding.encodeUtf8 token)
         Nothing -> error "Invalid https URI"
 
-getActivities :: String -> URI -> User -> IO (Vector Activity)
+getActivities :: URI -> StrictText -> User -> IO (Vector Activity)
-getActivities token server user =
+getActivities server token user =
     let pathConstructor lastPiece = [URI.pathPiece|api|] :|
             [ [URI.pathPiece|v1|]
             , [URI.pathPiece|users|]
@@ -64,11 +113,11 @@ getActivities token server user =
         Just (httpsURI, httpsOptions) -> fmap responseBody
             $ runReq defaultHttpConfig
             $ req GET httpsURI NoReqBody jsonResponse
-            $ httpsOptions <> oAuth2Bearer (Char8.pack token)
+            $ httpsOptions <> oAuth2Bearer (Text.Encoding.encodeUtf8 token)
         Nothing -> error "Invalid https URI"
 
-getUsers :: String -> URI -> IO (Vector User)
+getUsers :: URI -> StrictText -> IO (Vector User)
-getUsers token server =
+getUsers server token =
     let pathPieces = [URI.pathPiece|api|] :|
             [ [URI.pathPiece|v1|]
             , [URI.pathPiece|admin|]
@@ -81,5 +130,5 @@ getUsers token server =
         Just (httpsURI, httpsOptions) -> fmap responseBody
             $ runReq defaultHttpConfig
             $ req GET httpsURI NoReqBody jsonResponse
-            $ httpsOptions <> oAuth2Bearer (Char8.pack token)
+            $ httpsOptions <> oAuth2Bearer (Text.Encoding.encodeUtf8 token)
         Nothing -> error "Invalid https URI"

tea-cleaner/TeaCleaner/CommandLine.hs

@@ -0,0 +1,45 @@
+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/Filter.hs

@@ -0,0 +1,32 @@
+module TeaCleaner.Filter
+    ( 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)
+
+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 :: URI -> StrictText -> 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

tea-cleaner/TeaCleaner/Types.hs

@@ -1,53 +0,0 @@
-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)