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,70 +2,46 @@ module Main
     ( main
     ) where
 
+import Data.Text (StrictText)
 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 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 Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
-import TeaCleaner.Types (Activity(..), User(..))
-import TeaCleaner.Client (getActivities, getUsers, purgeUser)
+import TeaCleaner.Filter (filterByActivities, filterByUserProperties)
+import TeaCleaner.Client (User(..), getUsers, purgeUser)
+import TeaCleaner.CommandLine (ProgramOptions(..), commandLineInfo, execParser)
 
-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
+printUsers :: URI -> StrictText -> Bool -> Vector User -> IO ()
+printUsers server token liveRun users = printCount
+    >> Vector.forM_ users (printUser liveRun)
   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
+    buildValue user = 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"
+        <> "  Email: " <> getField @"email" user <> "\n"
+        <> "  Website: " <> getField @"website" user <> "\n"
+        <> "  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 = getArgs >>= withArguments
+main = execParser commandLineInfo >>= 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
+    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

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 ()
-purgeUser token server user =
+data User = 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 token server user =
+getActivities :: URI -> StrictText -> User -> IO (Vector Activity)
+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 token server =
+getUsers :: URI -> StrictText -> IO (Vector User)
+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)