mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 02:11:53 +00:00
Implements uploads, index, and deindex
This commit is contained in:
Keagan McClelland
@@ -38,6 +38,8 @@ dependencies:
|
||||
- foreign-store
|
||||
- fsnotify
|
||||
- http-api-data
|
||||
- http-client-tls
|
||||
- http-conduit
|
||||
- http-types
|
||||
- interpolate
|
||||
- lens
|
||||
@@ -52,11 +54,13 @@ dependencies:
|
||||
- persistent-migration
|
||||
- persistent-postgresql
|
||||
- persistent-template
|
||||
- postgresql-simple
|
||||
- process
|
||||
- protolude
|
||||
- rainbow
|
||||
- shakespeare
|
||||
- template-haskell
|
||||
- terminal-progress-bar
|
||||
- text
|
||||
- time
|
||||
- transformers
|
||||
|
||||
@@ -93,9 +93,7 @@ import Handler.ErrorLogs
|
||||
import Handler.Icons
|
||||
import Handler.Marketplace
|
||||
import Handler.Version
|
||||
import Lib.PkgRepository ( watchEosRepoRoot
|
||||
, watchPkgRepoRoot
|
||||
)
|
||||
import Lib.PkgRepository ( watchEosRepoRoot )
|
||||
import Lib.Ssl
|
||||
import Migration ( manualMigration )
|
||||
import Model
|
||||
@@ -136,13 +134,12 @@ makeFoundation appSettings = do
|
||||
-- logging function. To get out of this loop, we initially create a
|
||||
-- temporary foundation without a real connection pool, get a log function
|
||||
-- from there, and then create the real foundation.
|
||||
let mkFoundation appConnPool appStopFsNotifyPkg appStopFsNotifyEos = RegistryCtx { .. }
|
||||
let mkFoundation appConnPool appStopFsNotifyEos = RegistryCtx { .. }
|
||||
-- The RegistryCtx {..} syntax is an example of record wild cards. For more
|
||||
-- information, see:
|
||||
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
|
||||
tempFoundation = mkFoundation (panic "connPool forced in tempFoundation")
|
||||
(panic "stopFsNotify forced in tempFoundation")
|
||||
(panic "stopFsNotify forced in tempFoundation")
|
||||
tempFoundation =
|
||||
mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation")
|
||||
logFunc = messageLoggerSource tempFoundation appLogger
|
||||
|
||||
createDirectoryIfMissing True (errorLogRoot appSettings)
|
||||
@@ -151,7 +148,6 @@ makeFoundation appSettings = do
|
||||
pool <- flip runLoggingT logFunc
|
||||
$ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings)
|
||||
|
||||
stopPkgWatch <- runLoggingT (runReaderT (watchPkgRepoRoot pool) appSettings) logFunc
|
||||
stopEosWatch <- runLoggingT (runReaderT (watchEosRepoRoot pool) appSettings) logFunc
|
||||
|
||||
-- Preform database migration using application logging settings
|
||||
@@ -168,7 +164,7 @@ makeFoundation appSettings = do
|
||||
)
|
||||
|
||||
-- Return the foundation
|
||||
return $ mkFoundation pool stopPkgWatch stopEosWatch
|
||||
return $ mkFoundation pool stopEosWatch
|
||||
|
||||
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
|
||||
-- applying some additional middlewares.
|
||||
@@ -334,7 +330,7 @@ startWeb foundation = do
|
||||
app <- makeApplication foundation
|
||||
startWeb' app
|
||||
where
|
||||
startWeb' app = (`onException` (appStopFsNotifyPkg foundation *> appStopFsNotifyEos foundation)) $ do
|
||||
startWeb' app = (`onException` appStopFsNotifyEos foundation) $ do
|
||||
let AppSettings {..} = appSettings foundation
|
||||
runLog $ $logInfo [i|Launching Tor Web Server on port #{torPort}|]
|
||||
torAction <- async $ runSettings (warpSettings torPort foundation) app
|
||||
|
||||
230
src/Cli/Cli.hs
230
src/Cli/Cli.hs
@@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
@@ -8,62 +9,124 @@ module Cli.Cli
|
||||
( cliMain
|
||||
) where
|
||||
|
||||
import Conduit ( (.|)
|
||||
, foldC
|
||||
, runConduit
|
||||
)
|
||||
import Control.Monad.Logger ( LogLevel(..)
|
||||
, MonadLogger(monadLoggerLog)
|
||||
, MonadLoggerIO(askLoggerIO)
|
||||
, ToLogStr
|
||||
, fromLogStr
|
||||
, toLogStr
|
||||
)
|
||||
import Data.Aeson ( eitherDecodeStrict )
|
||||
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.String ( IsString(fromString) )
|
||||
import Dhall hiding ( void )
|
||||
import Dhall.Core ( pretty )
|
||||
import Handler.Admin ( IndexPkgReq(IndexPkgReq) )
|
||||
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
|
||||
, parseRequest
|
||||
)
|
||||
import Network.HTTP.Client.TLS ( newTlsManager )
|
||||
import Network.HTTP.Simple ( getResponseBody
|
||||
, httpLBS
|
||||
, setRequestBody
|
||||
, setRequestBodyJSON
|
||||
, setRequestHeaders
|
||||
)
|
||||
import Network.URI ( URI
|
||||
, parseURI
|
||||
)
|
||||
import Options.Applicative hiding ( auto
|
||||
, empty
|
||||
)
|
||||
import Rainbow ( fore
|
||||
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(return)
|
||||
, IsString(..)
|
||||
, Maybe(..)
|
||||
, Monad((>>=))
|
||||
, ReaderT(runReaderT)
|
||||
, Semigroup((<>))
|
||||
, Show
|
||||
, String
|
||||
, const
|
||||
, decodeUtf8
|
||||
, exitWith
|
||||
, filter
|
||||
, for_
|
||||
, fromIntegral
|
||||
, fromMaybe
|
||||
, panic
|
||||
, print
|
||||
, pure
|
||||
, show
|
||||
, unlessM
|
||||
, void
|
||||
, when
|
||||
, writeFile
|
||||
)
|
||||
import System.Directory ( createDirectory
|
||||
, createDirectoryIfMissing
|
||||
import System.Directory ( createDirectoryIfMissing
|
||||
, doesPathExist
|
||||
, getCurrentDirectory
|
||||
, getFileSize
|
||||
, getHomeDirectory
|
||||
, listDirectory
|
||||
)
|
||||
import System.FilePath ( (</>)
|
||||
, takeBaseName
|
||||
, takeDirectory
|
||||
, takeExtension
|
||||
)
|
||||
import System.ProgressBar ( Progress(..)
|
||||
, defStyle
|
||||
, newProgressBar
|
||||
, updateProgress
|
||||
)
|
||||
import Yesod ( logError
|
||||
, logWarn
|
||||
)
|
||||
|
||||
data Upload = Upload
|
||||
@@ -73,7 +136,7 @@ data Upload = Upload
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data PublishCfg = PublishCfg
|
||||
newtype PublishCfg = PublishCfg
|
||||
{ publishCfgRepos :: HashMap String PublishCfgRepo
|
||||
}
|
||||
deriving Generic
|
||||
@@ -101,17 +164,13 @@ instance ToDhall URI where
|
||||
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
|
||||
| CmdIndex String String Version Bool
|
||||
deriving Show
|
||||
|
||||
cfgLocation :: IO FilePath
|
||||
@@ -163,9 +222,33 @@ parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry f
|
||||
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 "Indexes 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
|
||||
|
||||
parseCommand :: Parser Command
|
||||
parseCommand = (parseInit $> CmdInit) <|> (CmdUpload <$> parsePublish) <|> subparser
|
||||
(command "reg" (info reg $ progDesc "Manage configured registries"))
|
||||
parseCommand =
|
||||
(parseInit $> CmdInit)
|
||||
<|> (CmdUpload <$> parsePublish)
|
||||
<|> subparser (command "reg" (info reg $ progDesc "Manage configured registries"))
|
||||
<|> parseIndex
|
||||
<|> parseDeindex
|
||||
where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList)
|
||||
|
||||
opts :: ParserInfo Command
|
||||
@@ -175,11 +258,12 @@ cliMain :: IO ()
|
||||
cliMain =
|
||||
execParser opts
|
||||
>>= (\case
|
||||
CmdInit -> init
|
||||
CmdRegAdd s pcr -> regAdd s pcr
|
||||
CmdRegDel s -> regRm s
|
||||
CmdRegList -> regLs
|
||||
CmdUpload up -> regUpload up
|
||||
CmdInit -> init
|
||||
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
|
||||
)
|
||||
|
||||
init :: IO ()
|
||||
@@ -212,5 +296,97 @@ regLs = do
|
||||
putChunk $ fromString (k <> ": ") & fore yellow
|
||||
putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta
|
||||
|
||||
regUpload :: Upload -> IO ()
|
||||
regUpload = panic "unimplemented"
|
||||
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 <- getResponseBody <$> runReaderT (httpLbs withBody) manager
|
||||
if LB.null res
|
||||
then pure ()
|
||||
else do
|
||||
$logError (decodeUtf8 $ LB.toStrict 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 <- getResponseBody <$> httpLBS withBody
|
||||
if LB.null res then pure () else $logError (decodeUtf8 $ LB.toStrict 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 <- getResponseBody <$> httpLBS withBody
|
||||
if LB.null res then pure () else $logError (decodeUtf8 $ LB.toStrict res) *> exitWith (ExitFailure 1)
|
||||
|
||||
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
|
||||
|
||||
@@ -85,7 +85,6 @@ data RegistryCtx = RegistryCtx
|
||||
, appWebServerThreadId :: MVar (ThreadId, ThreadId)
|
||||
, appShouldRestartWeb :: MVar Bool
|
||||
, appConnPool :: ConnectionPool
|
||||
, appStopFsNotifyPkg :: IO Bool
|
||||
, appStopFsNotifyEos :: IO Bool
|
||||
}
|
||||
instance Has PkgRepo RegistryCtx where
|
||||
@@ -196,6 +195,9 @@ instance Yesod RegistryCtx where
|
||||
pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only"
|
||||
| otherwise = pure Authorized
|
||||
|
||||
maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64)
|
||||
maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing
|
||||
maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default
|
||||
|
||||
-- How to run database actions.
|
||||
instance YesodPersist RegistryCtx where
|
||||
|
||||
@@ -11,12 +11,16 @@ import Conduit ( (.|)
|
||||
import Control.Monad.Reader.Has ( ask )
|
||||
import Control.Monad.Trans.Maybe ( MaybeT(..) )
|
||||
import Data.Aeson ( (.:)
|
||||
, (.=)
|
||||
, FromJSON(parseJSON)
|
||||
, ToJSON
|
||||
, decodeFileStrict
|
||||
, object
|
||||
, withObject
|
||||
)
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Database.Persist.Postgresql ( runSqlPoolNoTransaction )
|
||||
import Database.Queries ( upsertPackageVersion )
|
||||
import Foundation
|
||||
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot)
|
||||
@@ -24,7 +28,7 @@ import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRo
|
||||
, getManifestLocation
|
||||
)
|
||||
import Lib.Types.AppIndex ( PackageManifest(..)
|
||||
, PkgId
|
||||
, PkgId(unPkgId)
|
||||
)
|
||||
import Lib.Types.Emver ( Version(..) )
|
||||
import Model ( Key(PkgRecordKey, VersionRecordKey) )
|
||||
@@ -35,7 +39,9 @@ import Startlude ( ($)
|
||||
, (.)
|
||||
, (<$>)
|
||||
, Applicative(pure)
|
||||
, Bool(..)
|
||||
, Eq
|
||||
, Maybe(..)
|
||||
, Show
|
||||
, SomeException(..)
|
||||
, asum
|
||||
@@ -44,6 +50,7 @@ import Startlude ( ($)
|
||||
, liftIO
|
||||
, replicate
|
||||
, show
|
||||
, toS
|
||||
, when
|
||||
)
|
||||
import System.FilePath ( (<.>)
|
||||
@@ -52,11 +59,16 @@ import System.FilePath ( (<.>)
|
||||
import UnliftIO ( try
|
||||
, withSystemTempDirectory
|
||||
)
|
||||
import UnliftIO.Directory ( renameDirectory )
|
||||
import UnliftIO.Directory ( createDirectoryIfMissing
|
||||
, removePathForcibly
|
||||
, renameDirectory
|
||||
, renameFile
|
||||
)
|
||||
import Util.Shared ( orThrow
|
||||
, sendResponseText
|
||||
)
|
||||
import Yesod ( delete
|
||||
import Yesod ( ToJSON(..)
|
||||
, delete
|
||||
, getsYesod
|
||||
, logError
|
||||
, rawRequestBody
|
||||
@@ -66,17 +78,22 @@ import Yesod ( delete
|
||||
|
||||
postPkgUploadR :: Handler ()
|
||||
postPkgUploadR = do
|
||||
withSystemTempDirectory "newpkg" $ \path -> do
|
||||
runConduit $ rawRequestBody .| sinkFile (path </> "temp" <.> "s9pk")
|
||||
withSystemTempDirectory "newpkg" $ \dir -> do
|
||||
let path = dir </> "temp" <.> "s9pk"
|
||||
runConduit $ rawRequestBody .| sinkFile path
|
||||
pool <- getsYesod appConnPool
|
||||
PkgRepo {..} <- ask
|
||||
res <- retry $ extractPkg pool path
|
||||
when (isNothing res) $ do
|
||||
$logError "Failed to extract package"
|
||||
sendResponseText status500 "Failed to extract package"
|
||||
PackageManifest {..} <- liftIO (decodeFileStrict (path </> "manifest.json"))
|
||||
PackageManifest {..} <- liftIO (decodeFileStrict (dir </> "manifest.json"))
|
||||
`orThrow` sendResponseText status500 "Failed to parse manifest.json"
|
||||
renameDirectory path (pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion)
|
||||
renameFile path (dir </> (toS . unPkgId) packageManifestId <.> "s9pk")
|
||||
let targetPath = pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion
|
||||
removePathForcibly targetPath
|
||||
createDirectoryIfMissing True targetPath
|
||||
renameDirectory dir targetPath
|
||||
where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
|
||||
|
||||
|
||||
@@ -90,6 +107,8 @@ instance FromJSON IndexPkgReq where
|
||||
indexPkgReqId <- o .: "id"
|
||||
indexPkgReqVersion <- o .: "version"
|
||||
pure IndexPkgReq { .. }
|
||||
instance ToJSON IndexPkgReq where
|
||||
toJSON IndexPkgReq {..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion]
|
||||
|
||||
postPkgIndexR :: Handler ()
|
||||
postPkgIndexR = do
|
||||
@@ -98,7 +117,8 @@ postPkgIndexR = do
|
||||
man <- liftIO (decodeFileStrict manifest) `orThrow` sendResponseText
|
||||
status404
|
||||
[i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
|
||||
runDB $ upsertPackageVersion man
|
||||
pool <- getsYesod appConnPool
|
||||
runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing
|
||||
|
||||
postPkgDeindexR :: Handler ()
|
||||
postPkgDeindexR = do
|
||||
|
||||
2
src/Lib/External/AppMgr.hs
vendored
2
src/Lib/External/AppMgr.hs
vendored
@@ -36,9 +36,9 @@ import GHC.IO.Exception ( IOErrorType(NoSuchThing)
|
||||
import Lib.Error
|
||||
import System.FilePath ( (</>) )
|
||||
import UnliftIO ( MonadUnliftIO
|
||||
, bracket
|
||||
, catch
|
||||
)
|
||||
import UnliftIO ( bracket )
|
||||
|
||||
readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
|
||||
readProcessWithExitCode' a b c = liftIO $ do
|
||||
|
||||
@@ -49,8 +49,15 @@ import Database.Esqueleto.Experimental
|
||||
, insertUnique
|
||||
, runSqlPool
|
||||
)
|
||||
import Database.Persist ( (=.) )
|
||||
import Database.Persist.Class ( upsert )
|
||||
import Database.Persist ( (=.)
|
||||
, insertKey
|
||||
, update
|
||||
, upsert
|
||||
)
|
||||
import Database.Persist.Sql ( SqlPersistT
|
||||
, runSqlPoolNoTransaction
|
||||
)
|
||||
import Database.PostgreSQL.Simple ( SqlError(sqlState) )
|
||||
import Lib.Error ( S9Error(NotFoundE) )
|
||||
import qualified Lib.External.AppMgr as AppMgr
|
||||
import Lib.Types.AppIndex ( PackageManifest(..)
|
||||
@@ -118,6 +125,7 @@ import System.FilePath ( (<.>)
|
||||
import UnliftIO ( MonadUnliftIO
|
||||
, askRunInIO
|
||||
, async
|
||||
, catch
|
||||
, mapConcurrently_
|
||||
, newEmptyMVar
|
||||
, takeMVar
|
||||
@@ -184,15 +192,18 @@ loadPkgDependencies appConnPool manifest = do
|
||||
let pkgVersion = packageManifestVersion manifest
|
||||
let deps = packageManifestDependencies manifest
|
||||
time <- liftIO getCurrentTime
|
||||
_ <- runWith appConnPool $ insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) ->
|
||||
if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e
|
||||
let deps' = first PkgRecordKey <$> HM.toList deps
|
||||
for_
|
||||
deps'
|
||||
(\d -> runSqlPool
|
||||
( insertUnique
|
||||
$ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d)
|
||||
)
|
||||
appConnPool
|
||||
(\d -> flip runSqlPool appConnPool $ do
|
||||
insertUnique
|
||||
$ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d)
|
||||
)
|
||||
where
|
||||
runWith :: MonadUnliftIO m => ConnectionPool -> SqlPersistT m a -> m a
|
||||
runWith pool action = runSqlPoolNoTransaction action pool Nothing
|
||||
|
||||
-- extract all package assets into their own respective files
|
||||
extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m ()
|
||||
@@ -235,27 +246,6 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do
|
||||
mapConcurrently_ (removeFile . (pkgRoot </>)) toRemove
|
||||
throwIO e
|
||||
|
||||
watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool)
|
||||
watchPkgRepoRoot pool = do
|
||||
$logInfo "Starting FSNotify Watch Manager: PKG"
|
||||
root <- asks pkgRepoFileRoot
|
||||
runInIO <- askRunInIO
|
||||
box <- newEmptyMVar @_ @()
|
||||
_ <- forkIO $ liftIO $ withManager $ \watchManager -> do
|
||||
stop <- watchTree watchManager root onlyAdded $ \evt -> do
|
||||
let pkg = eventPath evt
|
||||
-- TODO: validate that package path is an actual s9pk and is in a correctly conforming path.
|
||||
void . forkIO $ runInIO $ do
|
||||
extractPkg pool pkg
|
||||
takeMVar box
|
||||
stop
|
||||
pure $ tryPutMVar box ()
|
||||
where
|
||||
onlyAdded :: ActionPredicate
|
||||
onlyAdded (Added path _ isDir) = not isDir && takeExtension path == ".s9pk"
|
||||
onlyAdded (Modified path _ isDir) = not isDir && takeExtension path == ".s9pk"
|
||||
onlyAdded _ = False
|
||||
|
||||
watchEosRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has EosRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool)
|
||||
watchEosRepoRoot pool = do
|
||||
$logInfo "Starting FSNotify Watch Manager: EOS"
|
||||
|
||||
@@ -148,7 +148,7 @@ filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadat
|
||||
pure Nothing
|
||||
|
||||
sendResponseText :: MonadHandler m => Status -> Text -> m a
|
||||
sendResponseText = sendResponseStatus @_ @Text
|
||||
sendResponseText s = sendResponseStatus s . TypedContent typePlain . toContent
|
||||
|
||||
maximumOn :: forall a b t . (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
|
||||
maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
|
||||
|
||||
@@ -45,6 +45,7 @@ extra-deps:
|
||||
- monad-logger-extras-0.1.1.1
|
||||
- persistent-migration-0.3.0
|
||||
- rainbow-0.34.2.2
|
||||
- terminal-progress-bar-0.4.1
|
||||
- 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