implements upload on server

actually move extracted dir to resource location

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
+/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

package.yaml

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

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

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

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 = _

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
+                  unless (null compatible) $ yield PackageMetadata { packageMetadataPkgRecord         = pkg
-                                                                       , packageMetadataPkgVersionRecords = compatible
+                                                                   , packageMetadataPkgVersionRecords = compatible
-                                                                       , packageMetadataPkgCategories     = cats
+                                                                   , packageMetadataPkgCategories     = cats
-                                                                       , packageMetadataPkgVersion = requestedVersion
+                                                                   , 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