From 87b5a6e4a1cb8bce79ea5183bcf82185ee12d9d1 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Fri, 20 May 2022 17:44:25 -0600 Subject: [PATCH] implements upload on server actually move extracted dir to resource location --- config/routes | 7 ++++- package.yaml | 1 + src/Application.hs | 1 + src/Foundation.hs | 8 ++++++ src/Handler/Admin.hs | 65 ++++++++++++++++++++++++++++++++++++++++++++ src/Util/Shared.hs | 14 ++++++---- 6 files changed, 90 insertions(+), 6 deletions(-) create mode 100644 src/Handler/Admin.hs diff --git a/config/routes b/config/routes index 20ed805..421c6b9 100644 --- a/config/routes +++ b/config/routes @@ -15,4 +15,9 @@ /package/v0/version/#PkgId PkgVersionR GET -- get most recent appId version -- SUPPORT API V0 -/support/v0/error-logs ErrorLogsR POST \ No newline at end of file +/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 \ No newline at end of file diff --git a/package.yaml b/package.yaml index 883da20..3928e26 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,7 @@ dependencies: - can-i-haz - conduit - conduit-extra + - containers - cryptonite - cryptonite-conduit - data-default diff --git a/src/Application.hs b/src/Application.hs index 368a414..d7c570e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 6c09f30..0dcffe3 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs new file mode 100644 index 0000000..d135764 --- /dev/null +++ b/src/Handler/Admin.hs @@ -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 = _ diff --git a/src/Util/Shared.hs b/src/Util/Shared.hs index be3b586..52e1f3b 100644 --- a/src/Util/Shared.hs +++ b/src/Util/Shared.hs @@ -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