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
- authentication
- [ ] github
- [ ] gitlab
- [ ] gitea
- supports migrating the following forges to a gitea instance
- [ ] github
- [ ] 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
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
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)
where
<*> 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'

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
( 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

View File

@ -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;
};
};

View File

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