mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
507 lines
23 KiB
Haskell
507 lines
23 KiB
Haskell
{-# LANGUAGE ApplicativeDo #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Cli.Cli
|
|
( cliMain
|
|
) where
|
|
|
|
import Conduit ( (.|)
|
|
, foldC
|
|
, runConduit
|
|
)
|
|
import Control.Monad.Logger ( LogLevel(..)
|
|
, MonadLogger(monadLoggerLog)
|
|
, MonadLoggerIO(askLoggerIO)
|
|
, ToLogStr
|
|
, fromLogStr
|
|
, toLogStr
|
|
)
|
|
import Crypto.Hash ( SHA256(SHA256)
|
|
, hashWith
|
|
)
|
|
import Data.Aeson ( eitherDecodeStrict )
|
|
import Data.ByteArray.Encoding ( Base(..)
|
|
, convertToBase
|
|
)
|
|
import qualified Data.ByteString.Char8 as B8
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import Data.Default
|
|
import Data.Functor.Contravariant ( contramap )
|
|
import Data.HashMap.Internal.Strict ( HashMap
|
|
, delete
|
|
, empty
|
|
, insert
|
|
, lookup
|
|
, traverseWithKey
|
|
)
|
|
import Data.Text ( toLower )
|
|
import Dhall ( Encoder(embed)
|
|
, FromDhall(..)
|
|
, Generic
|
|
, ToDhall(..)
|
|
, auto
|
|
, inject
|
|
, inputFile
|
|
)
|
|
import Dhall.Core ( pretty )
|
|
import Handler.Admin ( IndexPkgReq(IndexPkgReq)
|
|
, PackageList(..)
|
|
)
|
|
import Lib.External.AppMgr ( sourceManifest )
|
|
import Lib.Types.AppIndex ( PackageManifest
|
|
( PackageManifest
|
|
, packageManifestId
|
|
, packageManifestVersion
|
|
)
|
|
, PkgId(..)
|
|
)
|
|
import Lib.Types.Emver ( Version(..) )
|
|
import Network.HTTP.Client.Conduit ( StreamFileStatus(StreamFileStatus, fileSize, readSoFar)
|
|
, applyBasicAuth
|
|
, httpLbs
|
|
, observedStreamFile
|
|
)
|
|
import Network.HTTP.Client.TLS ( newTlsManager )
|
|
import Network.HTTP.Simple ( getResponseBody
|
|
, getResponseStatus
|
|
, httpJSON
|
|
, httpLBS
|
|
, parseRequest
|
|
, setRequestBody
|
|
, setRequestBodyJSON
|
|
, setRequestHeaders
|
|
)
|
|
import Network.HTTP.Types ( status200 )
|
|
import Network.URI ( URI
|
|
, parseURI
|
|
)
|
|
import Options.Applicative ( (<$>)
|
|
, (<**>)
|
|
, Alternative((<|>))
|
|
, Applicative((<*>), liftA2, pure)
|
|
, Parser
|
|
, ParserInfo
|
|
, command
|
|
, execParser
|
|
, fullDesc
|
|
, help
|
|
, helper
|
|
, info
|
|
, liftA3
|
|
, long
|
|
, mappend
|
|
, metavar
|
|
, optional
|
|
, progDesc
|
|
, short
|
|
, strArgument
|
|
, strOption
|
|
, subparser
|
|
, switch
|
|
)
|
|
import Rainbow ( Chunk
|
|
, Radiant
|
|
, blue
|
|
, chunk
|
|
, fore
|
|
, green
|
|
, magenta
|
|
, putChunk
|
|
, putChunkLn
|
|
, red
|
|
, white
|
|
, yellow
|
|
)
|
|
import Startlude ( ($)
|
|
, ($>)
|
|
, (&)
|
|
, (.)
|
|
, (<&>)
|
|
, Bool(..)
|
|
, ConvertText(toS)
|
|
, Either(..)
|
|
, Eq(..)
|
|
, ExitCode(..)
|
|
, FilePath
|
|
, IO
|
|
, IsString(..)
|
|
, Maybe(..)
|
|
, Monad((>>=))
|
|
, ReaderT(runReaderT)
|
|
, Semigroup((<>))
|
|
, Show
|
|
, String
|
|
, appendFile
|
|
, const
|
|
, decodeUtf8
|
|
, exitWith
|
|
, filter
|
|
, flip
|
|
, fmap
|
|
, for
|
|
, for_
|
|
, fromIntegral
|
|
, fromMaybe
|
|
, fst
|
|
, headMay
|
|
, panic
|
|
, show
|
|
, snd
|
|
, unlessM
|
|
, void
|
|
, when
|
|
, writeFile
|
|
, zip
|
|
)
|
|
import System.Directory ( createDirectoryIfMissing
|
|
, doesPathExist
|
|
, getCurrentDirectory
|
|
, getFileSize
|
|
, getHomeDirectory
|
|
, listDirectory
|
|
)
|
|
import System.FilePath ( (</>)
|
|
, takeDirectory
|
|
, takeExtension
|
|
)
|
|
import System.ProgressBar ( Progress(..)
|
|
, defStyle
|
|
, newProgressBar
|
|
, updateProgress
|
|
)
|
|
import Yesod ( logError
|
|
, logWarn
|
|
)
|
|
|
|
data Upload = Upload
|
|
{ publishRepoName :: !String
|
|
, publishPkg :: !(Maybe FilePath)
|
|
, publishIndex :: !Bool
|
|
}
|
|
deriving Show
|
|
|
|
newtype 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 Shell = Bash | Fish | Zsh deriving Show
|
|
data Command
|
|
= CmdInit !(Maybe Shell)
|
|
| CmdRegAdd !String !PublishCfgRepo
|
|
| CmdRegDel !String
|
|
| CmdRegList
|
|
| CmdUpload !Upload
|
|
| CmdIndex !String !String !Version !Bool
|
|
| CmdListUnindexed !String
|
|
deriving Show
|
|
|
|
cfgLocation :: IO FilePath
|
|
cfgLocation = getHomeDirectory <&> \d -> d </> ".embassy/publish.dhall"
|
|
|
|
parseInit :: Parser (Maybe Shell)
|
|
parseInit = subparser $ command "init" (info go $ progDesc "Initializes embassy-publish config") <> metavar "init"
|
|
where
|
|
shells = [Bash, Fish, Zsh]
|
|
go = headMay . fmap fst . filter snd . zip shells <$> for shells (switch . long . toS . toLower . show)
|
|
|
|
parsePublish :: Parser Upload
|
|
parsePublish = subparser $ command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry") <> metavar
|
|
"upload"
|
|
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"
|
|
|
|
parseIndex :: Parser Command
|
|
parseIndex =
|
|
subparser
|
|
$ command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version")
|
|
<> metavar "index"
|
|
|
|
parseDeindex :: Parser Command
|
|
parseDeindex =
|
|
subparser
|
|
$ command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version")
|
|
<> metavar "deindex"
|
|
|
|
parseIndexHelper :: Bool -> Parser Command
|
|
parseIndexHelper b =
|
|
CmdIndex
|
|
<$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
|
|
<*> strArgument (metavar "PKG")
|
|
<*> strArgument (metavar "VERSION")
|
|
<*> pure b
|
|
|
|
parseListUnindexed :: Parser String
|
|
parseListUnindexed = subparser $ command
|
|
"list-unindexed"
|
|
( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME"))
|
|
$ progDesc "Lists unindexed package versions on target registry"
|
|
)
|
|
|
|
parseCommand :: Parser Command
|
|
parseCommand =
|
|
(CmdInit <$> parseInit)
|
|
<|> (CmdUpload <$> parsePublish)
|
|
<|> subparser (command "reg" (info reg $ progDesc "Manage configured registries") <> metavar "reg")
|
|
<|> parseIndex
|
|
<|> parseDeindex
|
|
<|> (CmdListUnindexed <$> parseListUnindexed)
|
|
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 sh -> init sh
|
|
CmdRegAdd s pcr -> regAdd s pcr
|
|
CmdRegDel s -> regRm s
|
|
CmdRegList -> regLs
|
|
CmdUpload up -> upload up
|
|
CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v
|
|
CmdListUnindexed name -> listUnindexed name
|
|
)
|
|
|
|
init :: Maybe Shell -> IO ()
|
|
init sh = do
|
|
loc <- cfgLocation
|
|
createDirectoryIfMissing True (takeDirectory loc)
|
|
unlessM (doesPathExist loc) $ do
|
|
writeFile loc (pretty $ embed inject (def @PublishCfg))
|
|
home <- getHomeDirectory
|
|
for_ sh $ \case
|
|
Bash -> do
|
|
let bashrc = home </> ".bashrc"
|
|
appendFile bashrc "source <(embassy-publish --bash-completion-script `which embassy-publish`)\n"
|
|
Fish -> do
|
|
let fishrc = home </> ".config" </> "fish" </> "config.fish"
|
|
appendFile fishrc "source <(embassy-publish --fish-compltion-script `which embassy-publish`)\n"
|
|
Zsh -> do
|
|
let zshrc = home </> ".zshrc"
|
|
appendFile zshrc "source <(embassy-publish --zsh-completion-script `which embassy-publish`)\n"
|
|
|
|
|
|
|
|
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')
|
|
putChunkLn $ "Below is the hash to provide to the server operator for your admin credentials" & fore yellow
|
|
putChunkLn
|
|
. fore yellow
|
|
. chunk
|
|
. decodeUtf8
|
|
. convertToBase Base16
|
|
. hashWith SHA256
|
|
. B8.pack
|
|
. mappend "start9_admin:"
|
|
$ publishCfgRepoPass val
|
|
|
|
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
|
|
|
|
upload :: Upload -> IO ()
|
|
upload (Upload name mpkg shouldIndex) = do
|
|
PublishCfgRepo {..} <- findNameInCfg name
|
|
pkg <- case mpkg of
|
|
Nothing -> do
|
|
cwd <- getCurrentDirectory
|
|
files <- listDirectory cwd
|
|
let pkgs = filter (\n -> takeExtension n == ".s9pk") files
|
|
case pkgs of
|
|
[] -> do
|
|
$logError "No package specified, and could not find one in this directory"
|
|
exitWith $ ExitFailure 1
|
|
[p ] -> pure (cwd </> p)
|
|
(_ : _ : _) -> do
|
|
$logWarn "Ambiguous package upload request, found multiple candidates:"
|
|
for_ pkgs $ \f -> $logWarn (fromString f)
|
|
exitWith $ ExitFailure 1
|
|
Just s -> pure s
|
|
noBody <-
|
|
parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload")
|
|
<&> setRequestHeaders [("accept", "text/plain")]
|
|
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
|
|
size <- getFileSize pkg
|
|
bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ())
|
|
body <- observedStreamFile (updateProgress bar . const . sfs2prog) pkg
|
|
let withBody = setRequestBody body noBody
|
|
manager <- newTlsManager
|
|
res <- runReaderT (httpLbs withBody) manager
|
|
if getResponseStatus res == status200
|
|
-- no output is successful
|
|
then pure ()
|
|
else do
|
|
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
|
|
exitWith $ ExitFailure 1
|
|
putChunkLn $ fromString ("Successfully uploaded " <> pkg) & fore green
|
|
when shouldIndex $ do
|
|
home <- getHomeDirectory
|
|
manifestBytes <- sourceManifest (home </> ".cargo/bin") pkg $ \c -> runConduit (c .| foldC)
|
|
PackageManifest { packageManifestId, packageManifestVersion } <- case eitherDecodeStrict manifestBytes of
|
|
Left s -> do
|
|
$logError $ "Could not parse the manifest of the package: " <> toS s
|
|
exitWith $ ExitFailure 1
|
|
Right a -> pure a
|
|
let pkgId = toS $ unPkgId packageManifestId
|
|
index name pkgId packageManifestVersion
|
|
putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green
|
|
|
|
where
|
|
sfs2prog :: StreamFileStatus -> Progress ()
|
|
sfs2prog StreamFileStatus {..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
|
|
|
|
index :: String -> String -> Version -> IO ()
|
|
index name pkg v = do
|
|
PublishCfgRepo {..} <- findNameInCfg name
|
|
noBody <-
|
|
parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/index")
|
|
<&> setRequestHeaders [("accept", "text/plain")]
|
|
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
|
|
let withBody = setRequestBodyJSON (IndexPkgReq (PkgId $ toS pkg) v) noBody
|
|
res <- httpLBS withBody
|
|
-- no output is successful
|
|
if getResponseStatus res == status200
|
|
then pure ()
|
|
else do
|
|
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
|
|
exitWith (ExitFailure 1)
|
|
|
|
|
|
deindex :: String -> String -> Version -> IO ()
|
|
deindex name pkg v = do
|
|
PublishCfgRepo {..} <- findNameInCfg name
|
|
noBody <-
|
|
parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/deindex")
|
|
<&> setRequestHeaders [("accept", "text/plain")]
|
|
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
|
|
let withBody = setRequestBodyJSON (IndexPkgReq (PkgId $ toS pkg) v) noBody
|
|
res <- httpLBS withBody
|
|
-- no output is successful
|
|
if getResponseStatus res == status200
|
|
then pure ()
|
|
else do
|
|
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
|
|
exitWith (ExitFailure 1)
|
|
|
|
|
|
|
|
listUnindexed :: String -> IO ()
|
|
listUnindexed name = do
|
|
PublishCfgRepo {..} <- findNameInCfg name
|
|
noBody <-
|
|
parseRequest (show publishCfgRepoLocation <> "/admin/v0/deindex")
|
|
<&> setRequestHeaders [("accept", "application/json")]
|
|
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
|
|
PackageList {..} <- getResponseBody <$> httpJSON noBody
|
|
void $ flip traverseWithKey unPackageList $ \k v -> do
|
|
putChunk (chunk (unPkgId k <> ": ") & fore blue)
|
|
putChunkLn $ chunk (show v) & fore yellow
|
|
|
|
findNameInCfg :: String -> IO PublishCfgRepo
|
|
findNameInCfg name = do
|
|
loc <- cfgLocation
|
|
PublishCfg cfg <- inputFile auto loc
|
|
case lookup name cfg of
|
|
Nothing -> do
|
|
$logError "Registry name not found!"
|
|
exitWith $ ExitFailure 1
|
|
Just pcr -> pure pcr
|
|
|
|
instance MonadLogger IO where
|
|
monadLoggerLog _ _ LevelDebug = putChunkLn . colorLog white
|
|
monadLoggerLog _ _ LevelInfo = putChunkLn . colorLog blue
|
|
monadLoggerLog _ _ LevelWarn = putChunkLn . colorLog yellow
|
|
monadLoggerLog _ _ LevelError = putChunkLn . colorLog red
|
|
monadLoggerLog _ _ (LevelOther _) = putChunkLn . colorLog magenta
|
|
|
|
colorLog :: ToLogStr msg => Radiant -> msg -> Chunk
|
|
colorLog c m = fore c $ chunk . decodeUtf8 . fromLogStr . toLogStr $ m
|
|
instance MonadLoggerIO IO where
|
|
askLoggerIO = pure monadLoggerLog
|