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

implements upload on server

Browse Source 
actually move extracted dir to resource location
This commit is contained in:
Keagan McClelland
2022-05-20 17:44:25 -06:00
parent d2aee89cda
commit 87b5a6e4a1
6 changed files with 90 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
config/routes
View File

@@ -15,4 +15,9 @@
/package/v0/version/#PkgId PkgVersionR GET -- get most recent appId version
-- SUPPORT API V0
/support/v0/error-logs ErrorLogsR POST
/support/v0/error-logs ErrorLogsR POST
-- ADMIN API V0
/admin/v0/upload PkgUploadR POST !admin
/admin/v0/index PkgIndexR POST !admin
/admin/v0/deindex PkgDeindexR POST !admin

1
package.yaml
View File

@@ -23,6 +23,7 @@ dependencies:
- can-i-haz
- conduit
- conduit-extra
- containers
- cryptonite
- cryptonite-conduit
- data-default

1
src/Application.hs
View File

@@ -85,6 +85,7 @@ import Data.String.Interpolate.IsString
( i )
import Database.Persist.Sql ( SqlBackend )
import Foundation
import Handler.Admin
import Handler.Apps
import Handler.ErrorLogs
import Handler.Icons

8
src/Foundation.hs
View File

@@ -36,6 +36,7 @@ import Control.Monad.Reader.Has ( Has(extract, update) )
import Crypto.Hash ( SHA256(SHA256)
, hashWith
)
import Data.Set ( member )
import Data.String.Interpolate.IsString
( i )
import qualified Data.Text as T
@@ -189,6 +190,13 @@ instance Yesod RegistryCtx where
LevelError -> Red
LevelOther _ -> White
isAuthorized :: Route RegistryCtx -> Bool -> Handler AuthResult
isAuthorized route _
| "admin" `member` routeAttrs route = do
hasAuthId <- isJust <$> maybeAuthId
pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only"
| otherwise = pure Authorized
-- How to run database actions.
instance YesodPersist RegistryCtx where

65
src/Handler/Admin.hs Normal file
View File

@@ -0,0 +1,65 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
module Handler.Admin where
import Conduit ( (.|)
, runConduit
, sinkFile
)
import Control.Monad.Reader.Has ( ask )
import Control.Monad.Trans.Maybe ( MaybeT(..) )
import Data.Aeson ( decodeFileStrict )
import Foundation
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot)
, extractPkg
)
import Lib.Types.AppIndex ( PackageManifest(..) )
import Network.HTTP.Types ( status500 )
import Startlude ( ($)
, (.)
, (<$>)
, SomeException(..)
, asum
, hush
, isNothing
, liftIO
, replicate
, show
, when
)
import System.FilePath ( (<.>)
, (</>)
)
import UnliftIO ( try
, withSystemTempDirectory
)
import UnliftIO.Directory ( renameDirectory )
import Util.Shared ( orThrow
, sendResponseText
)
import Yesod ( getsYesod
, logError
, rawRequestBody
)
postPkgUploadR :: Handler ()
postPkgUploadR = do
withSystemTempDirectory "newpkg" $ \path -> do
runConduit $ rawRequestBody .| sinkFile (path </> "temp" <.> "s9pk")
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"))
`orThrow` sendResponseText status500 "Failed to parse manifest.json"
renameDirectory path (pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion)
where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
postPkgIndexR :: Handler ()
postPkgIndexR = _
postPkgDeindexR :: Handler ()
postPkgDeindexR = _

14
src/Util/Shared.hs
View File

@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Util.Shared where
@@ -79,11 +80,11 @@ filterPkgOsCompatible p =
$ \PackageMetadata { packageMetadataPkgRecord = pkg, packageMetadataPkgVersionRecords = versions, packageMetadataPkgCategories = cats, packageMetadataPkgVersion = requestedVersion } ->
do
let compatible = filter (p . versionRecordOsVersion . entityVal) versions
when (not $ null compatible) $ yield PackageMetadata { packageMetadataPkgRecord = pkg
, packageMetadataPkgVersionRecords = compatible
, packageMetadataPkgCategories = cats
, packageMetadataPkgVersion = requestedVersion
}
unless (null compatible) $ yield PackageMetadata { packageMetadataPkgRecord = pkg
, packageMetadataPkgVersionRecords = compatible
, packageMetadataPkgCategories = cats
, packageMetadataPkgVersion = requestedVersion
}
filterDependencyOsCompatible :: (Version -> Bool) -> PackageDependencyMetadata -> PackageDependencyMetadata
filterDependencyOsCompatible p PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDeps, packageDependencyMetadataDepPkgRecord = pkg, packageDependencyMetadataDepVersions = depVersions }
@@ -130,3 +131,6 @@ filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadat
-- TODO it would be better if we could return the requirements for display
$logInfo [i|No satisfactory version of #{depId} for dependent package #{pkgId}|]
pure Nothing
sendResponseText :: MonadHandler m => Status -> Text -> m a
sendResponseText = sendResponseStatus @_ @Text