From b514763d79196f4d05de74eaed64fe9be28d24d6 Mon Sep 17 00:00:00 2001 From: mat ess Date: Mon, 18 Jul 2022 00:32:53 -0400 Subject: [PATCH] Add some actions --- README.md | 4 +++ app/Actions.hs | 34 ++++++++++++++++++++ app/Main.hs | 70 ++++++++++++++++++++++++++++++------------ app/Request.hs | 28 +++++++++++++++++ app/Types.hs | 65 ++++++++++++++++++++++++++------------- flake.nix | 8 ++--- migrate-to-gitea.cabal | 10 ++++-- 7 files changed, 171 insertions(+), 48 deletions(-) create mode 100644 app/Actions.hs create mode 100644 app/Request.hs diff --git a/README.md b/README.md index 2cb0137..142e368 100644 --- a/README.md +++ b/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 diff --git a/app/Actions.hs b/app/Actions.hs new file mode 100644 index 0000000..7edddc5 --- /dev/null +++ b/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) diff --git a/app/Main.hs b/app/Main.hs index 463f087..15b7145 100644 --- a/app/Main.hs +++ b/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' \ No newline at end of file diff --git a/app/Request.hs b/app/Request.hs new file mode 100644 index 0000000..a2aab6f --- /dev/null +++ b/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" diff --git a/app/Types.hs b/app/Types.hs index 340221b..b4636ab 100644 --- a/app/Types.hs +++ b/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 diff --git a/flake.nix b/flake.nix index e6135b8..3be6cca 100644 --- a/flake.nix +++ b/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; }; }; diff --git a/migrate-to-gitea.cabal b/migrate-to-gitea.cabal index 536622f..dccc72a 100644 --- a/migrate-to-gitea.cabal +++ b/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