Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

fix cross device link

Browse Source
This commit is contained in:
Keagan McClelland
2022-05-27 14:42:00 -06:00
parent f761677420
commit a1ca3a5eaf
3 changed files with 34 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

29
src/Cli/Cli.hs
View File

@@ -66,23 +66,25 @@ import Network.HTTP.Client.Conduit ( StreamFileStatus(StreamFileSta
, applyBasicAuth
, httpLbs
, observedStreamFile
, parseRequest
)
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)
, Applicative((<*>), liftA2, pure)
, Parser
, ParserInfo
, command
@@ -410,12 +412,12 @@ upload (Upload name mpkg shouldIndex) = do
body <- observedStreamFile (updateProgress bar . const . sfs2prog) pkg
let withBody = setRequestBody body noBody
manager <- newTlsManager
res <- getResponseBody <$> runReaderT (httpLbs withBody) manager
if LB.null res
res <- runReaderT (httpLbs withBody) manager
if getResponseStatus res == status200
-- no output is successful
then pure ()
else do
$logError (decodeUtf8 $ LB.toStrict res)
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
exitWith $ ExitFailure 1
putChunkLn $ fromString ("Successfully uploaded " <> pkg) & fore green
when shouldIndex $ do
@@ -442,9 +444,13 @@ index name pkg v = do
<&> setRequestHeaders [("accept", "text/plain")]
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
let withBody = setRequestBodyJSON (IndexPkgReq (PkgId $ toS pkg) v) noBody
res <- getResponseBody <$> httpLBS withBody
res <- httpLBS withBody
-- no output is successful
if LB.null res then pure () else $logError (decodeUtf8 $ LB.toStrict res) *> exitWith (ExitFailure 1)
if getResponseStatus res == status200
then pure ()
else do
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
exitWith (ExitFailure 1)
deindex :: String -> String -> Version -> IO ()
@@ -455,9 +461,14 @@ deindex name pkg v = do
<&> setRequestHeaders [("accept", "text/plain")]
<&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
let withBody = setRequestBodyJSON (IndexPkgReq (PkgId $ toS pkg) v) noBody
res <- getResponseBody <$> httpLBS withBody
res <- httpLBS withBody
-- no output is successful
if LB.null res then pure () else $logError (decodeUtf8 $ LB.toStrict res) *> exitWith (ExitFailure 1)
if getResponseStatus res == status200
then pure ()
else do
$logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
exitWith (ExitFailure 1)
listUnindexed :: String -> IO ()

10
src/Database/Marketplace.hs
View File

@@ -21,6 +21,7 @@ import Database.Esqueleto.Experimental
, (:&)(..)
, (==.)
, (^.)
, asc
, desc
, from
, groupBy
@@ -59,6 +60,7 @@ import Model ( Category
, PkgRecordId
, VersionRecordDescLong
, VersionRecordDescShort
, VersionRecordNumber
, VersionRecordPkgId
, VersionRecordTitle
, VersionRecordUpdatedAt
@@ -125,8 +127,12 @@ searchServices (Just category) query = selectSource $ do
)
pure service
)
groupBy (services ^. VersionRecordPkgId)
orderBy [desc (services ^. VersionRecordUpdatedAt)]
groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber)
orderBy
[ asc (services ^. VersionRecordPkgId)
, desc (services ^. VersionRecordNumber)
, desc (services ^. VersionRecordUpdatedAt)
]
pure services
getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()

9
src/Handler/Admin.hs
View File

@@ -36,7 +36,7 @@ import Database.Persist ( entityVal
import Database.Persist.Postgresql ( runSqlPoolNoTransaction )
import Database.Queries ( upsertPackageVersion )
import Foundation ( Handler
, RegistryCtx(appConnPool)
, RegistryCtx(..)
)
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot)
, extractPkg
@@ -56,6 +56,7 @@ import Model ( Key(AdminKey, PkgRecordKey, Ve
import Network.HTTP.Types ( status404
, status500
)
import Settings
import Startlude ( ($)
, (&&&)
, (.)
@@ -89,7 +90,7 @@ import System.FilePath ( (<.>)
, (</>)
)
import UnliftIO ( try
, withSystemTempDirectory
, withTempDirectory
)
import UnliftIO.Directory ( createDirectoryIfMissing
, removePathForcibly
@@ -112,7 +113,9 @@ import Yesod.Core.Types ( JSONResponse(JSONResponse) )
postPkgUploadR :: Handler ()
postPkgUploadR = do
withSystemTempDirectory "newpkg" $ \dir -> do
resourcesTemp <- getsYesod $ (</> "temp") . resourcesDir . appSettings
createDirectoryIfMissing True resourcesTemp
withTempDirectory resourcesTemp "newpkg" $ \dir -> do
let path = dir </> "temp" <.> "s9pk"
runConduit $ rawRequestBody .| sinkFile path
pool <- getsYesod appConnPool