add index and deindex endpoints

src/Application.hs

@@ -303,7 +303,7 @@ startApp foundation = do
         -- certbot renew loop
         void . forkIO $ forever $ flip runReaderT foundation $ do
             shouldRenew <- doesSslNeedRenew
-            runLog $ $logInfo $ [i|Checking if SSL Certs should be renewed: #{shouldRenew}|]
+            runLog $ $logInfo [i|Checking if SSL Certs should be renewed: #{shouldRenew}|]
             when shouldRenew $ do
                 runLog $ $logInfo "Renewing SSL Certs."
                 renewSslCerts
@@ -322,9 +322,9 @@ startWeb foundation = do
     where
         startWeb' app = (`onException` (appStopFsNotifyPkg foundation *> appStopFsNotifyEos foundation)) $ do
             let AppSettings {..} = appSettings foundation
-            runLog $ $logInfo $ [i|Launching Tor Web Server on port #{torPort}|]
+            runLog $ $logInfo [i|Launching Tor Web Server on port #{torPort}|]
             torAction <- async $ runSettings (warpSettings torPort foundation) app
-            runLog $ $logInfo $ [i|Launching Web Server on port #{appPort}|]
+            runLog $ $logInfo [i|Launching Web Server on port #{appPort}|]
             action <- async $ if sslAuto
                 then runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app
                 else runSettings (warpSettings appPort foundation) app

src/Database/Marketplace.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Fuse on/on" #-}
 
 module Database.Marketplace where
 
@@ -54,24 +55,24 @@ type CategoryTitle = Text
 searchServices :: (MonadResource m, MonadIO m)
                => Maybe CategoryTitle
                -> Text
-               -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) ()
+               -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
 searchServices Nothing query = selectSource $ do
-    service <- from $ table @PkgRecord
+    service <- from $ table @VersionRecord
     where_
-        (   (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%))
+        (   (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
-        ||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%))
+        ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
-        ||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%))
+        ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
         )
-    orderBy [desc (service ^. PkgRecordUpdatedAt)]
+    orderBy [desc (service ^. VersionRecordUpdatedAt)]
     pure service
 searchServices (Just category) query = selectSource $ do
     services <- from
         (do
             (service :& _ :& cat) <-
                 from
-                $           table @PkgRecord
+                $           table @VersionRecord
                 `innerJoin` table @PkgCategory
-                `on`        (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. PkgRecordId)
+                `on`        (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId)
                 `innerJoin` table @Category
                 `on`        (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
             -- if there is a cateogry, only search in category
@@ -80,13 +81,13 @@ searchServices (Just category) query = selectSource $ do
                 $   cat
                 ^.  CategoryName
                 ==. val category
-                &&. (   (service ^. PkgRecordDescShort `ilike` (%) ++. val query ++. (%))
+                &&. (   (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
-                    ||. (service ^. PkgRecordDescLong `ilike` (%) ++. val query ++. (%))
+                    ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
-                    ||. (service ^. PkgRecordTitle `ilike` (%) ++. val query ++. (%))
+                    ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
                     )
             pure service
         )
-    orderBy [desc (services ^. PkgRecordUpdatedAt)]
+    orderBy [desc (services ^. VersionRecordUpdatedAt)]
     pure services
 
 getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity PkgRecord) (ReaderT SqlBackend m) ()
@@ -98,20 +99,19 @@ getPkgData pkgs = selectSource $ do
 getPkgDependencyData :: MonadIO m
                      => Key PkgRecord
                      -> Version
-                     -> ReaderT SqlBackend m ([(Entity PkgDependency, Entity PkgRecord)])
+                     -> ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)]
 getPkgDependencyData pkgId pkgVersion = select $ do
-    pd <- from
+    from
         (do
             (pkgDepRecord :& depPkgRecord) <-
                 from
                 $           table @PkgDependency
                 `innerJoin` table @PkgRecord
                 `on`        (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId)
-            where_ (pkgDepRecord ^. PkgDependencyPkgId ==. (val pkgId))
+            where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val pkgId)
             where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion)
             pure (pkgDepRecord, depPkgRecord)
         )
-    pure pd
 
 zipCategories :: MonadUnliftIO m
               => ConduitT
@@ -147,7 +147,7 @@ zipDependencyVersions :: (Monad m, MonadIO m)
                       => (Entity PkgDependency, Entity PkgRecord)
                       -> ReaderT SqlBackend m PackageDependencyMetadata
 zipDependencyVersions (pkgDepRecord, depRecord) = do
-    let pkgDbId = entityKey $ depRecord
+    let pkgDbId = entityKey depRecord
     depVers <- select $ do
         v <- from $ table @VersionRecord
         where_ $ v ^. VersionRecordPkgId ==. val pkgDbId

src/Database/Queries.hs

@@ -1,15 +1,38 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Database.Queries where
 
-import           Database.Persist.Sql
+import           Database.Persist.Sql           ( PersistStoreRead(get)
-import           Lib.Types.AppIndex
+                                                , PersistStoreWrite(insertKey, insert_, repsert)
-import           Lib.Types.Emver
+                                                , SqlBackend
-import           Model
+                                                )
+import           Lib.Types.AppIndex             ( PackageManifest(..)
+                                                , PkgId
+                                                )
+import           Lib.Types.Emver                ( Version )
+import           Model                          ( Key(PkgRecordKey, VersionRecordKey)
+                                                , Metric(Metric)
+                                                , PkgRecord(PkgRecord)
+                                                , VersionRecord(VersionRecord)
+                                                )
 import           Orphans.Emver                  ( )
-import           Startlude               hiding ( get )
+import           Startlude                      ( ($)
+                                                , (.)
+                                                , ConvertText(toS)
+                                                , Maybe(..)
+                                                , MonadIO(..)
+                                                , ReaderT
+                                                , SomeException
+                                                , getCurrentTime
+                                                , maybe
+                                                )
+import           System.FilePath                ( takeExtension )
+import           UnliftIO                       ( MonadUnliftIO
+                                                , try
+                                                )
 
 fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe PkgRecord)
 fetchApp = get . PkgRecordKey
@@ -21,3 +44,22 @@ createMetric :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m ()
 createMetric appId version = do
     time <- liftIO getCurrentTime
     insert_ $ Metric time (PkgRecordKey appId) version
+
+upsertPackageVersion :: (MonadUnliftIO m) => PackageManifest -> ReaderT SqlBackend m ()
+upsertPackageVersion PackageManifest {..} = do
+    now <- liftIO getCurrentTime
+    let iconType = maybe "png" (toS . takeExtension . toS) packageManifestIcon
+    let pkgId    = PkgRecordKey packageManifestId
+    let ins = VersionRecord now
+                            (Just now)
+                            pkgId
+                            packageManifestVersion
+                            packageManifestTitle
+                            packageManifestDescriptionShort
+                            packageManifestDescriptionLong
+                            iconType
+                            packageManifestReleaseNotes
+                            packageManifestEosVersion
+                            Nothing
+    _res <- try @_ @SomeException $ insertKey pkgId (PkgRecord now (Just now))
+    repsert (VersionRecordKey pkgId packageManifestVersion) ins

src/Handler/Admin.hs

@@ -9,16 +9,33 @@ import           Conduit                        ( (.|)
                                                 )
 import           Control.Monad.Reader.Has       ( ask )
 import           Control.Monad.Trans.Maybe      ( MaybeT(..) )
-import           Data.Aeson                     ( decodeFileStrict )
+import           Data.Aeson                     ( (.:)
+                                                , FromJSON(parseJSON)
+                                                , decodeFileStrict
+                                                , withObject
+                                                )
+import           Data.String.Interpolate.IsString
+                                                ( i )
+import           Database.Queries               ( upsertPackageVersion )
 import           Foundation
 import           Lib.PkgRepository              ( PkgRepo(PkgRepo, pkgRepoFileRoot)
                                                 , extractPkg
+                                                , getManifestLocation
+                                                )
+import           Lib.Types.AppIndex             ( PackageManifest(..)
+                                                , PkgId
+                                                )
+import           Lib.Types.Emver                ( Version(..) )
+import           Model                          ( Key(PkgRecordKey, VersionRecordKey) )
+import           Network.HTTP.Types             ( status404
+                                                , status500
                                                 )
-import           Lib.Types.AppIndex             ( PackageManifest(..) )
-import           Network.HTTP.Types             ( status500 )
 import           Startlude                      ( ($)
                                                 , (.)
                                                 , (<$>)
+                                                , Applicative(pure)
+                                                , Eq
+                                                , Show
                                                 , SomeException(..)
                                                 , asum
                                                 , hush
@@ -38,9 +55,12 @@ import           UnliftIO.Directory             ( renameDirectory )
 import           Util.Shared                    ( orThrow
                                                 , sendResponseText
                                                 )
-import           Yesod                          ( getsYesod
+import           Yesod                          ( delete
+                                                , getsYesod
                                                 , logError
                                                 , rawRequestBody
+                                                , requireCheckJsonBody
+                                                , runDB
                                                 )
 
 postPkgUploadR :: Handler ()
@@ -58,8 +78,28 @@ postPkgUploadR = do
         renameDirectory path (pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion)
     where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
 
+
+data IndexPkgReq = IndexPkgReq
+    { indexPkgReqId      :: !PkgId
+    , indexPkgReqVersion :: !Version
+    }
+    deriving (Eq, Show)
+instance FromJSON IndexPkgReq where
+    parseJSON = withObject "Index Package Request" $ \o -> do
+        indexPkgReqId      <- o .: "id"
+        indexPkgReqVersion <- o .: "version"
+        pure IndexPkgReq { .. }
+
 postPkgIndexR :: Handler ()
-postPkgIndexR = _
+postPkgIndexR = do
+    IndexPkgReq {..} <- requireCheckJsonBody
+    manifest         <- getManifestLocation indexPkgReqId indexPkgReqVersion
+    man              <- liftIO (decodeFileStrict manifest) `orThrow` sendResponseText
+        status404
+        [i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
+    runDB $ upsertPackageVersion man
 
 postPkgDeindexR :: Handler ()
-postPkgDeindexR = _
+postPkgDeindexR = do
+    IndexPkgReq {..} <- requireCheckJsonBody
+    runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion)

src/Lib/PkgRepository.hs

@@ -286,14 +286,18 @@ watchEosRepoRoot pool = do
                 Right version ->
                     void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText]
 
+getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath
+getManifestLocation pkg version = do
+    root <- asks pkgRepoFileRoot
+    pure $ root </> show pkg </> show version </> "manifest.json"
+
 getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r)
             => PkgId
             -> Version
             -> m (Integer, ConduitT () ByteString m ())
 getManifest pkg version = do
-    root <- asks pkgRepoFileRoot
+    manifestPath <- getManifestLocation pkg version
-    let manifestPath = root </> show pkg </> show version </> "manifest.json"
+    n            <- getFileSize manifestPath
-    n <- getFileSize manifestPath
     pure (n, sourceFile manifestPath)
 
 getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r)

src/Lib/Types/AppIndex.hs

@@ -100,6 +100,7 @@ data PackageManifest = PackageManifest
     , packageManifestIcon             :: !(Maybe Text)
     , packageManifestAlerts           :: !(HM.HashMap ServiceAlert (Maybe Text))
     , packageManifestDependencies     :: !(HM.HashMap PkgId PackageDependency)
+    , packageManifestEosVersion       :: !Version
     }
     deriving Show
 instance FromJSON PackageManifest where
@@ -120,6 +121,7 @@ instance FromJSON PackageManifest where
             pure (alertType, alertDesc)
         let packageManifestAlerts = HM.fromList a
         packageManifestDependencies <- o .: "dependencies"
+        packageManifestEosVersion   <- o .: "eos-version"
         pure PackageManifest { .. }
 
 -- >>> eitherDecode testManifest :: Either String PackageManifest

src/Model.hs

@@ -24,10 +24,10 @@ PkgRecord
     Id PkgId sql=pkg_id
     createdAt UTCTime
     updatedAt UTCTime Maybe
-    title Text
+    -- title Text
-    descShort Text
+    -- descShort Text
-    descLong Text
+    -- descLong Text
-    iconType Text
+    -- iconType Text
     deriving Eq
     deriving Show
 
@@ -36,6 +36,10 @@ VersionRecord sql=version
     updatedAt UTCTime Maybe
     pkgId PkgRecordId
     number Version
+    title Text
+    descShort Text
+    descLong Text
+    iconType Text
     releaseNotes Text
     osVersion Version
     arch Text Maybe

src/Util/Shared.hs

@@ -1,14 +1,13 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
 
 module Util.Shared where
 
-import           Startlude               hiding ( Any
-                                                , Handler
-                                                , yield
-                                                )
 
 import qualified Data.Text                     as T
 import           Network.HTTP.Types
@@ -18,10 +17,10 @@ import           Conduit                        ( ConduitT
                                                 , awaitForever
                                                 , yield
                                                 )
-import           Control.Monad.Reader.Has       ( Has )
+import           Control.Monad.Reader.Has       ( Has
-import           Data.Semigroup                 ( Max(Max)
+                                                , MonadReader
-                                                , getMax
                                                 )
+import           Data.Semigroup                 ( (<>) )
 import           Data.String.Interpolate.IsString
                                                 ( i )
 import           Database.Esqueleto.Experimental
@@ -43,10 +42,33 @@ import           Lib.Types.Emver
 import           Model                          ( Category
                                                 , Key(unPkgRecordKey)
                                                 , PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange)
-                                                , PkgRecord(pkgRecordTitle)
+                                                , PkgRecord
-                                                , VersionRecord(versionRecordNumber, versionRecordOsVersion)
+                                                , VersionRecord(..)
                                                 , pkgDependencyPkgId
                                                 )
+import           Startlude                      ( ($)
+                                                , (.)
+                                                , (<$>)
+                                                , Alternative((<|>))
+                                                , Applicative(pure)
+                                                , Bool(..)
+                                                , Down(Down)
+                                                , Foldable(foldr, null)
+                                                , Functor(fmap)
+                                                , Maybe(..)
+                                                , Monad((>>=))
+                                                , Ord((>))
+                                                , Text
+                                                , decodeUtf8
+                                                , filter
+                                                , fromMaybe
+                                                , headMay
+                                                , isSpace
+                                                , not
+                                                , readMaybe
+                                                , sortOn
+                                                , unless
+                                                )
 
 getVersionSpecFromQuery :: Handler VersionRange
 getVersionSpecFromQuery = do
@@ -116,17 +138,17 @@ filterLatestVersionFromSpec versionMap = awaitForever $ \(a, vs, cats) -> do
 
 -- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package)
 filterDependencyBestVersion :: MonadLogger m => PackageDependencyMetadata -> m (Maybe (Key PkgRecord, Text, Version))
-filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord, packageDependencyMetadataDepPkgRecord = depRecord, packageDependencyMetadataDepVersions = depVersions }
+filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord, packageDependencyMetadataDepVersions = depVersions }
     = do
         -- get best version from VersionRange of dependency
-        let pkgId    = pkgDependencyPkgId $ entityVal pkgDepRecord
+        let pkgId = pkgDependencyPkgId $ entityVal pkgDepRecord
-        let depId    = pkgDependencyDepId $ entityVal pkgDepRecord
+        let depId = pkgDependencyDepId $ entityVal pkgDepRecord
-        let depTitle = pkgRecordTitle $ entityVal depRecord
+        let satisfactory = filter
-        let satisfactory = filter (<|| (pkgDependencyDepVersionRange $ entityVal pkgDepRecord))
+                ((<|| (pkgDependencyDepVersionRange $ entityVal pkgDepRecord)) . versionRecordNumber)
-                                  (versionRecordNumber . entityVal <$> depVersions)
+                (entityVal <$> depVersions)
-        case getMax <$> foldMap (Just . Max) satisfactory of
+        case maximumOn versionRecordNumber satisfactory of
             -- QUESTION is this an acceptable transformation here? These are the only values that we care about after this filter.
-            Just bestVersion -> pure $ Just (depId, depTitle, bestVersion)
+            Just bestVersion -> pure $ Just (depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion)
             Nothing          -> do
                 -- TODO it would be better if we could return the requirements for display
                 $logInfo [i|No satisfactory version of #{depId} for dependent package #{pkgId}|]
@@ -134,3 +156,9 @@ filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadat
 
 sendResponseText :: MonadHandler m => Status -> Text -> m a
 sendResponseText = sendResponseStatus @_ @Text
+
+maximumOn :: forall a b t . (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
+maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
+
+maxOn :: Ord b => (a -> b) -> a -> a -> a
+maxOn f x y = if f x > f y then x else y