Add some actions

README.md

@@ -9,6 +9,10 @@ migrate-to-gitea --from github:matthewess --to git.mat.services:mat
 ```
 
 ### features
+- authentication
+	- [ ] github
+	- [ ] gitlab
+	- [ ] gitea
 - supports migrating the following forges to a gitea instance
 	- [ ] github
 	- [ ] gitlab

app/Actions.hs

@@ -0,0 +1,34 @@
+module Actions where
+
+import Data.Aeson
+import Data.Aeson.Types
+import Network.HTTP.Req
+import Request
+import Types
+import Prelude hiding (get)
+
+listReposUrl :: Source -> URL
+listReposUrl (Source Github user) = apiUrl Github /: "users" /~ user /: "repos"
+listReposUrl _ = error "not implemented"
+
+parseListRepos :: Source -> Value -> Either Error [Repo]
+parseListRepos src@(Source forge _) = (bimap ParseError (sourceRepo src <$>)) <$> parseEither parser
+  where
+    parser = case forge of
+      Github ->
+        withArray
+          "Repos"
+          (mapM (withObject "Repo" (.: "name")) . toList)
+      _ -> error "not implemented"
+
+listRepos :: Source -> Action [Repo]
+listRepos src = do
+  let url = listReposUrl src
+  result <- get url
+  pure (parseListRepos src =<< result)
+
+checkRepoExists :: Repo -> Request Bool
+checkRepoExists repo = do
+  let url = repoUrl repo
+  result <- get url
+  pure (isRight result)

app/Main.hs

@@ -1,12 +1,15 @@
 module Main where
 
+import Actions
 import Data.Text (pack)
 import Options.Applicative
+import Request
 import Types
 
-data Options = Options
+data Plan = Plan
   { from :: Source,
-    to :: Destination
+    to :: Destination,
+    repos :: [Text]
   }
   deriving (Eq, Ord, Show)
 
@@ -14,60 +17,87 @@ longShort :: HasName f => String -> Mod f a
 longShort t@(c : _) = long t <> short c
 longShort t = long t
 
-options :: Parser Options
-options =
-  Options
-    <$> (sourceSpec <|> source)
-    <*> (destinationSpec <|> destination)
+parsePlan :: ParserInfo Plan
+parsePlan =
+  info
+    (plan <**> helper)
+    ( fullDesc
+        <> progDesc "migrate-to-gitea solves the problem wherein you have just spun up a new self-hosted https://gitea.io instance, and now you want to move your project history there (or perhaps to one of the more well known public instances)."
+        <> header "migrate-to-gitea - cli tool to migrate from git{hub,lab} to a gitea instance"
+    )
   where
+    plan =
+      Plan
+        <$> (sourceSpec <|> source)
+        <*> (destinationSpec <|> destination)
+        <*> many repo
     sourceSpec =
       option
         (maybeReader (sourceFromText . pack))
         ( longShort "from"
-            <> help "Source to migrate from in the form of 'FORGE:USER'"
+            <> metavar "FORGE:USER"
+            <> help "Source to migrate from"
         )
     source = Source <$> forge <*> fromUser
     forge =
       option
         (str >>= (pure . forgeFromText . pack))
         ( long "forge"
+            <> metavar "FORGE"
             <> help "Forge to migrate from"
         )
     fromUser =
       mkUser
         <$> strOption
           ( long "from-user"
+              <> metavar "USER"
               <> help "User account to migrate from"
           )
     destinationSpec =
       option
         (maybeReader (destinationFromText . pack))
         ( longShort "to"
-            <> help "Destiation to migrate to in the form of 'GITEA_URL:USER'"
+            <> metavar "GITEA_URL:USER"
+            <> help "Destination to migrate to"
         )
     destination = Destination <$> gitea <*> toUser
     gitea =
       option
         (str >>= (pure . mkGitea . pack))
         ( longShort "gitea-url"
+            <> metavar "GITEA_URL"
             <> help "URL of the Gitea instance to migrate to"
         )
     toUser =
       mkUser
         <$> strOption
           ( long "to-user"
-              <> help "User account to migrate to"
+              <> metavar "USER"
+              <> help "Gitea user account to migrate to"
           )
+    repo =
+      strOption
+        ( longShort "repo"
+            <> metavar "REPO"
+            <> help "Repo to migrate. Supply this option multiple times to include multiple repos. Defaults to all repositories"
+        )
 
 main :: IO ()
 main = do
-  args <- execParser parser
-  print args
-  where
-    parser =
-      info
-        (options <**> helper)
-        ( fullDesc
-            <> progDesc "migrate-to-gitea solves the problem wherein you have just spun up a new self-hosted https://gitea.io instance, and now you want to move your project history there (or perhaps to one of the more well known public instances)."
-            <> header "migrate-to-gitea - cli tool to migrate from git{hub,lab} to a gitea instance"
-        )
+  plan <- execParser parsePlan
+  runRequest (runPlan plan)
+
+runPlan :: Plan -> Request ()
+runPlan (Plan {from, to, repos}) = do
+  repos' <-
+    if null repos
+      then listRepos from
+      else (pure . Right) (sourceRepo from <$> repos)
+  either
+    ( \case
+        NotFound -> putTextLn ("Failed to list repos for " <> showSource from)
+        BadAuth msg -> putText "Authentication issue: " >> putBSLn msg
+        ParseError msg -> putStrLn msg
+    )
+    (mapM_ (chainedTo print . checkRepoExists))
+    repos'

app/Request.hs

@@ -0,0 +1,28 @@
+module Request where
+
+import Data.Aeson
+import Network.HTTP.Req
+
+type Request = Req
+
+runRequest :: Request a -> IO a
+runRequest = runReq (defaultHttpConfig {httpConfigCheckResponse = \_ _ _ -> Nothing})
+
+type URL = Url 'Https
+
+data Error
+  = NotFound
+  | BadAuth ByteString
+  | ParseError String
+
+type Action a = Request (Either Error a)
+
+get :: URL -> Action Value
+get url = do
+  response <- req GET url NoReqBody jsonResponse userAgent
+  pure case responseStatusCode response of
+    404 -> Left NotFound
+    403 -> Left (BadAuth (responseStatusMessage response))
+    _ -> Right (responseBody response)
+  where
+    userAgent = header "User-Agent" "migrate-to-gitea"

app/Types.hs

@@ -1,30 +1,22 @@
-module Types
-  ( Gitea,
-    mkGitea,
-    User,
-    mkUser,
-    Source (..),
-    sourceFromText,
-    Destination (..),
-    destinationFromText,
-    Forge (..),
-    forgeFromText,
-    forgeUrl,
-  )
-where
+module Types where
 
-import Data.Text (splitOn)
-import Network.HTTP.Req (Scheme (Https), Url, https)
+import Data.Text
+import Network.HTTP.Req
+import Request
+import Web.Internal.HttpApiData
 
-newtype Gitea = G (Url 'Https)
+newtype Gitea = G Text
   deriving (Eq, Ord, Show)
 
 mkGitea :: Text -> Gitea
-mkGitea = G . https
+mkGitea = G
 
 newtype User = U Text
   deriving (Eq, Ord, Show)
 
+instance ToHttpApiData User where
+  toUrlPiece (U t) = t
+
 mkUser :: Text -> User
 mkUser = U
 
@@ -35,6 +27,9 @@ sourceFromText :: Text -> Maybe Source
 sourceFromText (splitOn ":" -> [forge, user]) = Just (Source (forgeFromText forge) (mkUser user))
 sourceFromText _ = Nothing
 
+showSource :: Source -> Text
+showSource (Source forge (U user)) = forgeName forge <> ":" <> user
+
 data Destination = Destination Gitea User
   deriving (Eq, Ord, Show)
 
@@ -42,6 +37,9 @@ destinationFromText :: Text -> Maybe Destination
 destinationFromText (splitOn ":" -> [host, user]) = Just (Destination (mkGitea host) (mkUser user))
 destinationFromText _ = Nothing
 
+showDestination :: Destination -> Text
+showDestination (Destination (G host) (U user)) = host <> ":" <> user
+
 data Forge
   = Github
   | Gitlab
@@ -56,7 +54,30 @@ forgeFromText "gitlab.com" = Gitlab
 forgeFromText "codeberg" = Gitea (mkGitea "codeberg.org")
 forgeFromText host = Gitea (mkGitea host)
 
-forgeUrl :: Forge -> Url 'Https
-forgeUrl Github = https "github.com"
-forgeUrl Gitlab = https "gitlab.com"
-forgeUrl (Gitea (G url)) = url
+forgeName :: Forge -> Text
+forgeName Github = "github"
+forgeName Gitlab = "gitlab"
+forgeName (Gitea (G host)) = host
+
+forgeHost :: Forge -> Text
+forgeHost (Gitea (G host)) = host
+forgeHost (forgeName -> forge) = forge <> ".com"
+
+forgeUrl :: Forge -> URL
+forgeUrl (forgeHost -> host) = https host
+
+apiUrl :: Forge -> URL
+apiUrl Github = https "api.github.com"
+apiUrl _ = error "Not implemented"
+
+data Repo = Repo Forge User Text
+  deriving (Eq, Ord, Show)
+
+repoUrl :: Repo -> URL
+repoUrl (Repo (apiUrl -> url) user name) = url /~ user /: name
+
+sourceRepo :: Source -> Text -> Repo
+sourceRepo (Source repo user) name = Repo repo user name
+
+destinationRepo :: Destination -> Text -> Repo
+destinationRepo (Destination gitea user) name = Repo (Gitea gitea) user name

flake.nix

@@ -2,12 +2,12 @@
   description = "cli tool to migrate from git{hub,lab} to a gitea instance";
 
   inputs = {
-    nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
-    flake-parts.url = "github:hercules-ci/flake-parts";
+    nixpkgs.url = github:NixOS/nixpkgs/nixos-unstable;
+    flake-parts.url = github:hercules-ci/flake-parts;
     flake-parts.inputs.nixpkgs.follows = "nixpkgs";
-    haskell-flake.url = "github:srid/haskell-flake";
+    haskell-flake.url = github:srid/haskell-flake;
     relude = {
-      url = "github:kowainik/relude";
+      url = github:kowainik/relude;
       flake = false;
     };
   };

migrate-to-gitea.cabal

@@ -27,10 +27,14 @@ executable migrate-to-gitea
     main-is:          Main.hs
 
     -- Modules included in this executable, other than Main.
-    other-modules:    Types
+    other-modules:
+        Actions
+        Request
+        Types
 
     -- LANGUAGE extensions used by modules in this package.
     default-extensions:
+        BlockArguments
         DataKinds
         DerivingVia
         LambdaCase
@@ -42,13 +46,15 @@ executable migrate-to-gitea
     build-depends:    
         , base          >=4.13.0.0 && <=4.18.0.0
         , relude
+        , aeson
+        , http-api-data
         , optparse-applicative
         , req
         , text
         , with-utf8
     mixins:
         base hiding (Prelude),
-        relude (Relude as Prelude, Relude.Container.One),
+        relude (Relude as Prelude, Relude.Container.One, Relude.Extra.Bifunctor),
         relude
     hs-source-dirs:   app
     default-language: GHC2021