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

10
src/Database/Marketplace.hs
View File

@@ -21,6 +21,7 @@ import Database.Esqueleto.Experimental
, (:&)(..) , (:&)(..)
, (==.) , (==.)
, (^.) , (^.)
, asc
, desc , desc
, from , from
, groupBy , groupBy
@@ -59,6 +60,7 @@ import Model ( Category
, PkgRecordId , PkgRecordId
, VersionRecordDescLong , VersionRecordDescLong
, VersionRecordDescShort , VersionRecordDescShort
, VersionRecordNumber
, VersionRecordPkgId , VersionRecordPkgId
, VersionRecordTitle , VersionRecordTitle
, VersionRecordUpdatedAt , VersionRecordUpdatedAt
@@ -125,8 +127,12 @@ searchServices (Just category) query = selectSource $ do
) )
pure service pure service
) )
groupBy (services ^. VersionRecordPkgId) groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber)
orderBy [desc (services ^. VersionRecordUpdatedAt)] orderBy
[ asc (services ^. VersionRecordPkgId)
, desc (services ^. VersionRecordNumber)
, desc (services ^. VersionRecordUpdatedAt)
]
pure services pure services
getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) () 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.Persist.Postgresql ( runSqlPoolNoTransaction )
import Database.Queries ( upsertPackageVersion ) import Database.Queries ( upsertPackageVersion )
import Foundation ( Handler import Foundation ( Handler
, RegistryCtx(appConnPool) , RegistryCtx(..)
) )
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot) import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot)
, extractPkg , extractPkg
@@ -56,6 +56,7 @@ import Model ( Key(AdminKey, PkgRecordKey, Ve
import Network.HTTP.Types ( status404 import Network.HTTP.Types ( status404
, status500 , status500
) )
import Settings
import Startlude ( ($) import Startlude ( ($)
, (&&&) , (&&&)
, (.) , (.)
@@ -89,7 +90,7 @@ import System.FilePath ( (<.>)
, (</>) , (</>)
) )
import UnliftIO ( try import UnliftIO ( try
, withSystemTempDirectory , withTempDirectory
) )
import UnliftIO.Directory ( createDirectoryIfMissing import UnliftIO.Directory ( createDirectoryIfMissing
, removePathForcibly , removePathForcibly
@@ -112,7 +113,9 @@ import Yesod.Core.Types ( JSONResponse(JSONResponse) )
postPkgUploadR :: Handler () postPkgUploadR :: Handler ()
postPkgUploadR = do postPkgUploadR = do
withSystemTempDirectory "newpkg" $ \dir -> do resourcesTemp <- getsYesod $ (</> "temp") . resourcesDir . appSettings
createDirectoryIfMissing True resourcesTemp
withTempDirectory resourcesTemp "newpkg" $ \dir -> do
let path = dir </> "temp" <.> "s9pk" let path = dir </> "temp" <.> "s9pk"
runConduit $ rawRequestBody .| sinkFile path runConduit $ rawRequestBody .| sinkFile path
pool <- getsYesod appConnPool pool <- getsYesod appConnPool