mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
implements multi registry management
This commit is contained in:
Keagan McClelland
@@ -1,7 +1,4 @@
|
||||
module Main where
|
||||
import Startlude ( IO
|
||||
, pure
|
||||
)
|
||||
import Cli.Cli (cliMain)
|
||||
|
||||
main :: IO ()
|
||||
main = pure ()
|
||||
main = cliMain
|
||||
|
||||
2
hie.yaml
2
hie.yaml
@@ -6,3 +6,5 @@ cradle:
|
||||
component: "start9-registry:exe:start9-registry"
|
||||
- path: "./test"
|
||||
component: "start9-registry:test:start9-registry-test"
|
||||
- path: "./cli"
|
||||
component: "start9-registry:exe:embassy-publish"
|
||||
|
||||
@@ -27,6 +27,7 @@ dependencies:
|
||||
- cryptonite
|
||||
- cryptonite-conduit
|
||||
- data-default
|
||||
- dhall
|
||||
- directory
|
||||
- errors
|
||||
- esqueleto
|
||||
@@ -44,6 +45,8 @@ dependencies:
|
||||
- monad-logger
|
||||
- monad-logger-extras
|
||||
- monad-loops
|
||||
- network-uri
|
||||
- optparse-applicative
|
||||
- parallel
|
||||
- persistent
|
||||
- persistent-migration
|
||||
@@ -51,6 +54,7 @@ dependencies:
|
||||
- persistent-template
|
||||
- process
|
||||
- protolude
|
||||
- rainbow
|
||||
- shakespeare
|
||||
- template-haskell
|
||||
- text
|
||||
|
||||
216
src/Cli/Cli.hs
Normal file
216
src/Cli/Cli.hs
Normal file
@@ -0,0 +1,216 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Cli.Cli
|
||||
( cliMain
|
||||
) where
|
||||
|
||||
import Data.Default
|
||||
import Data.Functor.Contravariant ( contramap )
|
||||
import Data.HashMap.Internal.Strict ( HashMap
|
||||
, delete
|
||||
, empty
|
||||
, insert
|
||||
, traverseWithKey
|
||||
)
|
||||
import Data.String ( IsString(fromString) )
|
||||
import Dhall hiding ( void )
|
||||
import Dhall.Core ( pretty )
|
||||
import Network.URI ( URI
|
||||
, parseURI
|
||||
)
|
||||
import Options.Applicative hiding ( auto
|
||||
, empty
|
||||
)
|
||||
import Rainbow ( fore
|
||||
, magenta
|
||||
, putChunk
|
||||
, putChunkLn
|
||||
, yellow
|
||||
)
|
||||
import Startlude ( ($)
|
||||
, ($>)
|
||||
, (&)
|
||||
, (.)
|
||||
, (<$>)
|
||||
, (<&>)
|
||||
, (>>=)
|
||||
, Bool(..)
|
||||
, FilePath
|
||||
, IO
|
||||
, IsString
|
||||
, Maybe
|
||||
, Monad(return)
|
||||
, Semigroup((<>))
|
||||
, Show
|
||||
, String
|
||||
, fromMaybe
|
||||
, panic
|
||||
, print
|
||||
, pure
|
||||
, show
|
||||
, unlessM
|
||||
, void
|
||||
, writeFile
|
||||
)
|
||||
import System.Directory ( createDirectory
|
||||
, createDirectoryIfMissing
|
||||
, doesPathExist
|
||||
, getHomeDirectory
|
||||
)
|
||||
import System.FilePath ( (</>)
|
||||
, takeBaseName
|
||||
, takeDirectory
|
||||
)
|
||||
|
||||
data Upload = Upload
|
||||
{ publishRepoName :: String
|
||||
, publishPkg :: Maybe FilePath
|
||||
, publishIndex :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data PublishCfg = PublishCfg
|
||||
{ publishCfgRepos :: HashMap String PublishCfgRepo
|
||||
}
|
||||
deriving Generic
|
||||
instance FromDhall PublishCfg
|
||||
instance ToDhall PublishCfg
|
||||
instance Default PublishCfg where
|
||||
def = PublishCfg empty
|
||||
|
||||
|
||||
data PublishCfgRepo = PublishCfgRepo
|
||||
{ publishCfgRepoLocation :: URI
|
||||
, publishCfgRepoUser :: String
|
||||
, publishCfgRepoPass :: String
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
instance FromDhall PublishCfgRepo
|
||||
instance ToDhall PublishCfgRepo
|
||||
|
||||
instance FromDhall URI where
|
||||
autoWith norm = fromMaybe (panic "Invalid URI for publish target") . parseURI <$> autoWith norm
|
||||
|
||||
instance ToDhall URI where
|
||||
injectWith norm = contramap (show @_ @String) (injectWith norm)
|
||||
|
||||
instance IsString URI where
|
||||
fromString = fromMaybe (panic "Invalid URI for publish target") . parseURI
|
||||
|
||||
data RegAdd = RegAdd
|
||||
deriving Show
|
||||
data RegDel = RegDel
|
||||
deriving Show
|
||||
|
||||
data Command
|
||||
= CmdInit
|
||||
| CmdRegAdd String PublishCfgRepo
|
||||
| CmdRegDel String
|
||||
| CmdRegList
|
||||
| CmdUpload Upload
|
||||
deriving Show
|
||||
|
||||
cfgLocation :: IO FilePath
|
||||
cfgLocation = getHomeDirectory <&> \d -> d </> ".embassy/publish.dhall"
|
||||
|
||||
parseInit :: Parser ()
|
||||
parseInit = subparser $ command "init" (info (pure ()) $ progDesc "Initializes embassy-publish config")
|
||||
|
||||
parsePublish :: Parser Upload
|
||||
parsePublish = subparser $ command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry")
|
||||
where
|
||||
go = liftA3
|
||||
Upload
|
||||
(strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall"))
|
||||
(optional $ strOption
|
||||
(short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the package to publish")
|
||||
)
|
||||
(switch (short 'i' <> long "index" <> help "Index the package after uploading"))
|
||||
|
||||
parseRepoAdd :: Parser Command
|
||||
parseRepoAdd = subparser $ command "add" (info go $ progDesc "Add a registry to your config") <> metavar "add"
|
||||
where
|
||||
go :: Parser Command
|
||||
go =
|
||||
let
|
||||
publishCfgRepoLocation =
|
||||
strOption (short 'l' <> long "location" <> metavar "REGISTRY_URL" <> help "Registry URL")
|
||||
publishCfgRepoUser = strOption
|
||||
(short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry")
|
||||
publishCfgRepoPass = strOption
|
||||
(short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry")
|
||||
name =
|
||||
strOption
|
||||
(short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help
|
||||
"Name to reference this registry in the future"
|
||||
)
|
||||
r = PublishCfgRepo <$> publishCfgRepoLocation <*> publishCfgRepoUser <*> publishCfgRepoPass
|
||||
in
|
||||
liftA2 CmdRegAdd name r
|
||||
|
||||
parseRepoDel :: Parser String
|
||||
parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry from your config") <> metavar "rm"
|
||||
where
|
||||
go = strOption
|
||||
(short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help
|
||||
"Registry name chosen when this was originally configured"
|
||||
)
|
||||
|
||||
parseRepoList :: Parser ()
|
||||
parseRepoList = subparser $ command "ls" (info (pure ()) $ progDesc "List registries in your config") <> metavar "ls"
|
||||
|
||||
parseCommand :: Parser Command
|
||||
parseCommand = (parseInit $> CmdInit) <|> (CmdUpload <$> parsePublish) <|> subparser
|
||||
(command "reg" (info reg $ progDesc "Manage configured registries"))
|
||||
where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList)
|
||||
|
||||
opts :: ParserInfo Command
|
||||
opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages")
|
||||
|
||||
cliMain :: IO ()
|
||||
cliMain =
|
||||
execParser opts
|
||||
>>= (\case
|
||||
CmdInit -> init
|
||||
CmdRegAdd s pcr -> regAdd s pcr
|
||||
CmdRegDel s -> regRm s
|
||||
CmdRegList -> regLs
|
||||
CmdUpload up -> regUpload up
|
||||
)
|
||||
|
||||
init :: IO ()
|
||||
init = do
|
||||
loc <- cfgLocation
|
||||
createDirectoryIfMissing True (takeDirectory loc)
|
||||
unlessM (doesPathExist loc) $ writeFile loc (pretty $ embed inject (def @PublishCfg))
|
||||
|
||||
regAdd :: String -> PublishCfgRepo -> IO ()
|
||||
regAdd name val = do
|
||||
loc <- cfgLocation
|
||||
PublishCfg cfg <- inputFile auto loc
|
||||
let cfg' = insert name val cfg
|
||||
writeFile loc (pretty $ embed inject $ PublishCfg cfg')
|
||||
|
||||
regRm :: String -> IO ()
|
||||
regRm name = do
|
||||
loc <- cfgLocation
|
||||
PublishCfg cfg <- inputFile auto loc
|
||||
let cfg' = delete name cfg
|
||||
writeFile loc (pretty $ embed inject $ PublishCfg cfg')
|
||||
|
||||
regLs :: IO ()
|
||||
regLs = do
|
||||
loc <- cfgLocation
|
||||
PublishCfg cfg <- inputFile auto loc
|
||||
void $ traverseWithKey f cfg
|
||||
where
|
||||
f k v = do
|
||||
putChunk $ fromString (k <> ": ") & fore yellow
|
||||
putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta
|
||||
|
||||
regUpload :: Upload -> IO ()
|
||||
regUpload = panic "unimplemented"
|
||||
@@ -44,6 +44,7 @@ extra-deps:
|
||||
- esqueleto-3.5.1.0
|
||||
- monad-logger-extras-0.1.1.1
|
||||
- persistent-migration-0.3.0
|
||||
- rainbow-0.34.2.2
|
||||
- wai-request-spec-0.10.2.4
|
||||
- warp-3.3.19
|
||||
- yesod-auth-basic-0.1.0.3
|
||||
|
||||
Reference in New Issue
Block a user