Add some actions

main
mat ess 2022-07-18 00:32:53 -04:00
parent 4c6cbf7a86
commit b514763d79
7 changed files with 171 additions and 48 deletions

View File

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

34
app/Actions.hs Normal file
View File

@ -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)

View File

@ -1,12 +1,15 @@
module Main where module Main where
import Actions
import Data.Text (pack) import Data.Text (pack)
import Options.Applicative import Options.Applicative
import Request
import Types import Types
data Options = Options data Plan = Plan
{ from :: Source, { from :: Source,
to :: Destination to :: Destination,
repos :: [Text]
} }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
@ -14,60 +17,87 @@ longShort :: HasName f => String -> Mod f a
longShort t@(c : _) = long t <> short c longShort t@(c : _) = long t <> short c
longShort t = long t longShort t = long t
options :: Parser Options parsePlan :: ParserInfo Plan
options = parsePlan =
Options info
<$> (sourceSpec <|> source) (plan <**> helper)
<*> (destinationSpec <|> destination) ( 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 where
plan =
Plan
<$> (sourceSpec <|> source)
<*> (destinationSpec <|> destination)
<*> many repo
sourceSpec = sourceSpec =
option option
(maybeReader (sourceFromText . pack)) (maybeReader (sourceFromText . pack))
( longShort "from" ( 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 source = Source <$> forge <*> fromUser
forge = forge =
option option
(str >>= (pure . forgeFromText . pack)) (str >>= (pure . forgeFromText . pack))
( long "forge" ( long "forge"
<> metavar "FORGE"
<> help "Forge to migrate from" <> help "Forge to migrate from"
) )
fromUser = fromUser =
mkUser mkUser
<$> strOption <$> strOption
( long "from-user" ( long "from-user"
<> metavar "USER"
<> help "User account to migrate from" <> help "User account to migrate from"
) )
destinationSpec = destinationSpec =
option option
(maybeReader (destinationFromText . pack)) (maybeReader (destinationFromText . pack))
( longShort "to" ( 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 destination = Destination <$> gitea <*> toUser
gitea = gitea =
option option
(str >>= (pure . mkGitea . pack)) (str >>= (pure . mkGitea . pack))
( longShort "gitea-url" ( longShort "gitea-url"
<> metavar "GITEA_URL"
<> help "URL of the Gitea instance to migrate to" <> help "URL of the Gitea instance to migrate to"
) )
toUser = toUser =
mkUser mkUser
<$> strOption <$> strOption
( long "to-user" ( 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 :: IO ()
main = do main = do
args <- execParser parser plan <- execParser parsePlan
print args runRequest (runPlan plan)
where
parser = runPlan :: Plan -> Request ()
info runPlan (Plan {from, to, repos}) = do
(options <**> helper) repos' <-
( fullDesc if null repos
<> 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)." then listRepos from
<> header "migrate-to-gitea - cli tool to migrate from git{hub,lab} to a gitea instance" 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'

28
app/Request.hs Normal file
View File

@ -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"

View File

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

View File

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

View File

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