{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Redundant <$>" #-} module Handler.Marketplace where import Startlude ( ($) , (&&&) , (.) , (<$>) , (<&>) , Applicative((*>), pure) , Bool(True) , ByteString , Down(Down) , Either(Left, Right) , FilePath , Foldable(foldMap) , Functor(fmap) , Int , Maybe(..) , Monad((>>=)) , MonadIO , MonadReader , Monoid(mappend) , Num((*), (-)) , Ord((<)) , ReaderT(runReaderT) , Text , Traversable(traverse) , catMaybes , const , decodeUtf8 , encodeUtf8 , filter , flip , for_ , fromMaybe , fst , head , headMay , id , maybe , partitionEithers , readMaybe , show , snd , void ) import Conduit ( (.|) , dropC , runConduit , sinkList , takeC ) import Control.Monad.Logger ( MonadLogger , logWarn ) import Control.Monad.Reader.Has ( Has , ask ) import Crypto.Hash ( SHA256 ) import Crypto.Hash.Conduit ( hashFile ) import Data.Aeson ( decode , eitherDecode , eitherDecodeStrict ) import qualified Data.Attoparsec.Text as Atto import Data.Attoparsec.Text ( Parser , parseOnly ) import Data.ByteArray.Encoding ( Base(..) , convertToBase ) import Data.ByteString.Base64 ( encodeBase64 ) import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit.List as CL import qualified Data.HashMap.Strict as HM import Data.List ( lookup , sortOn ) import Data.String.Interpolate.IsString ( i ) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB import Database.Esqueleto.Experimental ( Entity(entityKey, entityVal) , SqlBackend , (^.) , asc , desc , from , orderBy , select , table ) import Database.Marketplace ( collateVersions , fetchAllAppVersions , fetchLatestApp , getPkgData , getPkgDependencyData , searchServices , zipCategories , zipDependencyVersions ) import Database.Persist ( PersistUniqueRead(getBy) , insertUnique ) import Foundation ( Handler , RegistryCtx(appConnPool, appSettings) , Route(InstructionsR, LicenseR) ) import Handler.Types.Marketplace ( CategoryTitle , DependencyRes(..) , EosRes(..) , InfoRes(InfoRes) , OrderArrangement(DESC) , PackageListDefaults ( PackageListDefaults , packageListCategory , packageListOrder , packageListPageLimit , packageListPageNumber , packageListQuery ) , PackageListRes(..) , PackageMetadata(..) , PackageReq(packageReqId, packageReqVersion) , PackageRes(..) , ReleaseNotes(ReleaseNotes) , VersionLatestRes(..) ) import Lib.Error ( S9Error(..) ) import Lib.PkgRepository ( PkgRepo , getIcon , getManifest ) import Lib.Types.AppIndex ( PkgId ) import Lib.Types.Emver ( Version , VersionRange , parseRange , parseVersion , satisfies ) import Model ( Category(..) , EntityField(..) , EosHash(EosHash, eosHashHash) , Key(PkgRecordKey, unPkgRecordKey) , OsVersion(..) , PkgRecord(..) , Unique(UniqueVersion) , VersionRecord(..) ) import Network.HTTP.Types ( status400 , status404 ) import Protolude.Unsafe ( unsafeFromJust ) import Settings ( AppSettings(marketplaceName, resourcesDir) ) import System.FilePath ( () ) import UnliftIO.Async ( mapConcurrently ) import UnliftIO.Directory ( listDirectory ) import Util.Shared ( filterDependencyBestVersion , filterDependencyOsCompatible , filterLatestVersionFromSpec , filterPkgOsCompatible , getVersionSpecFromQuery ) import Yesod.Core ( Content(ContentFile) , MonadHandler , MonadResource , RenderRoute(renderRoute) , TypedContent , YesodRequest(..) , addHeader , getRequest , getYesod , getsYesod , lookupGetParam , respond , sendResponseStatus , typeOctet ) import Yesod.Core.Types ( JSONResponse(..) ) import Yesod.Persist ( YesodDB ) import Yesod.Persist.Core ( YesodPersist(runDB) ) queryParamAs :: MonadHandler m => Text -> Parser a -> m (Maybe a) queryParamAs k p = lookupGetParam k >>= \case Nothing -> pure Nothing Just x -> case parseOnly p x of Left e -> sendResponseStatus @_ @Text status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|] Right a -> pure (Just a) getInfoR :: Handler (JSONResponse InfoRes) getInfoR = do name <- getsYesod $ marketplaceName . appSettings allCategories <- runDB $ select $ do cats <- from $ table @Category orderBy [asc (cats ^. CategoryPriority)] pure cats pure $ JSONResponse $ InfoRes name $ categoryName . entityVal <$> allCategories getEosVersionR :: Handler (JSONResponse (Maybe EosRes)) getEosVersionR = do eosVersion <- queryParamAs "eos-version" parseVersion allEosVersions <- runDB $ select $ do vers <- from $ table @OsVersion orderBy [desc (vers ^. OsVersionCreatedAt)] pure vers let osV = entityVal <$> allEosVersions let mLatest = head osV let mappedVersions = ReleaseNotes $ HM.fromList $ sortOn (Down . fst) $ filter (maybe (const True) (<) eosVersion . fst) $ (\v -> (osVersionNumber v, osVersionReleaseNotes v)) <$> osV pure . JSONResponse $ mLatest <&> \latest -> EosRes { eosResVersion = osVersionNumber latest , eosResHeadline = osVersionHeadline latest , eosResReleaseNotes = mappedVersions } getReleaseNotesR :: PkgId -> Handler ReleaseNotes getReleaseNotesR pkg = do appConnPool <- appConnPool <$> getYesod versionRecords <- runDB $ fetchAllAppVersions appConnPool pkg pure $ constructReleaseNotesApiRes versionRecords where constructReleaseNotesApiRes :: [VersionRecord] -> ReleaseNotes constructReleaseNotesApiRes vers = do ReleaseNotes $ HM.fromList $ sortOn (Down . fst) $ (versionRecordNumber &&& versionRecordReleaseNotes) <$> vers getEosR :: Handler TypedContent getEosR = do spec <- getVersionSpecFromQuery root <- getsYesod $ ( "eos") . resourcesDir . appSettings subdirs <- listDirectory root let (failures, successes) = partitionEithers $ Atto.parseOnly parseVersion . T.pack <$> subdirs for_ failures $ \f -> $logWarn [i|Emver Parse Failure for EOS: #{f}|] let mVersion = headMay . sortOn Down . filter (`satisfies` spec) $ successes case mVersion of Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) Just version -> do let imgPath = root show version "eos.img" h <- runDB $ retrieveHash version imgPath addHeader "x-eos-hash" h respond typeOctet $ ContentFile imgPath Nothing where retrieveHash :: Version -> FilePath -> YesodDB RegistryCtx Text retrieveHash v fp = do mHash <- getBy (UniqueVersion v) case mHash of Just h -> pure . eosHashHash . entityVal $ h Nothing -> do h <- hashFile @_ @SHA256 fp let t = decodeUtf8 $ convertToBase Base16 h void $ insertUnique (EosHash v t) -- lazily populate pure t -- TODO refactor with conduit getVersionLatestR :: Handler VersionLatestRes getVersionLatestR = do getParameters <- reqGetParams <$> getRequest case lookup "ids" getParameters of Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "") Just packages -> case eitherDecode $ LBS.fromStrict $ encodeUtf8 packages of Left _ -> sendResponseStatus status400 (InvalidParamsE "get:ids" packages) Right p -> do let packageList = (, Nothing) <$> p found <- runDB $ traverse fetchLatestApp $ fst <$> packageList pure $ VersionLatestRes $ HM.union ( HM.fromList $ (\v -> (unPkgRecordKey . entityKey $ fst v, Just $ versionRecordNumber $ entityVal $ snd v) ) <$> catMaybes found ) $ HM.fromList packageList getPackageListR :: Handler PackageListRes getPackageListR = do osPredicate <- getOsVersionQuery <&> \case Nothing -> const True Just v -> flip satisfies v pkgIds <- getPkgIdsQuery filteredPackages <- case pkgIds of Nothing -> do -- query for all category <- getCategoryQuery page <- getPageQuery limit' <- getLimitQuery query <- T.strip . fromMaybe (packageListQuery defaults) <$> lookupGetParam "query" runDB $ runConduit $ searchServices category query .| collateVersions .| zipCategories -- empty list since there are no requested packages in this case .| filterLatestVersionFromSpec [] .| filterPkgOsCompatible osPredicate -- pages start at 1 for some reason. TODO: make pages start at 0 .| (dropC (limit' * (page - 1)) *> takeC limit') .| sinkList Just packages' -> do -- for each item in list get best available from version range let vMap = (packageReqId &&& packageReqVersion) <$> packages' runDB -- TODO could probably be better with sequenceConduits . runConduit $ getPkgData (packageReqId <$> packages') .| collateVersions .| zipCategories .| filterLatestVersionFromSpec vMap .| filterPkgOsCompatible osPredicate .| sinkList -- NOTE: if a package's dependencies do not meet the system requirements, it is currently omitted from the list pkgsWithDependencies <- runDB $ mapConcurrently (getPackageDependencies osPredicate) filteredPackages PackageListRes <$> mapConcurrently constructPackageListApiRes pkgsWithDependencies where defaults = PackageListDefaults { packageListOrder = DESC , packageListPageLimit = 20 , packageListPageNumber = 1 , packageListCategory = Nothing , packageListQuery = "" } getPkgIdsQuery :: Handler (Maybe [PackageReq]) getPkgIdsQuery = lookupGetParam "ids" >>= \case Nothing -> pure Nothing Just ids -> case eitherDecodeStrict (encodeUtf8 ids) of Left _ -> do let e = InvalidParamsE "get:ids" ids $logWarn (show e) sendResponseStatus status400 e Right a -> pure a getCategoryQuery :: Handler (Maybe CategoryTitle) getCategoryQuery = lookupGetParam "category" >>= \case Nothing -> pure Nothing Just c -> case readMaybe . T.toUpper $ c of Nothing -> do let e = InvalidParamsE "get:category" c $logWarn (show e) sendResponseStatus status400 e Just t -> pure $ Just t getPageQuery :: Handler Int getPageQuery = lookupGetParam "page" >>= \case Nothing -> pure $ packageListPageNumber defaults Just p -> case readMaybe p of Nothing -> do let e = InvalidParamsE "get:page" p $logWarn (show e) sendResponseStatus status400 e Just t -> pure $ case t of 0 -> 1 -- disallow page 0 so offset is not negative _ -> t getLimitQuery :: Handler Int getLimitQuery = lookupGetParam "per-page" >>= \case Nothing -> pure $ packageListPageLimit defaults Just pp -> case readMaybe pp of Nothing -> do let e = InvalidParamsE "get:per-page" pp $logWarn (show e) sendResponseStatus status400 e Just l -> pure l getOsVersionQuery :: Handler (Maybe VersionRange) getOsVersionQuery = lookupGetParam "eos-version-compat" >>= \case Nothing -> pure Nothing Just osv -> case Atto.parseOnly parseRange osv of Left _ -> do let e = InvalidParamsE "get:eos-version-compat" osv $logWarn (show e) sendResponseStatus status400 e Right v -> pure $ Just v getPackageDependencies :: (MonadIO m, MonadLogger m) => (Version -> Bool) -> PackageMetadata -> ReaderT SqlBackend m ( Key PkgRecord , [Category] , [Version] , Version , [(Key PkgRecord, Text, Version)] ) getPackageDependencies osPredicate PackageMetadata { packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion } = do let pkgId = PkgRecordKey pkg let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions let pkgCategories' = entityVal <$> pkgCategories pkgDepInfo <- getPkgDependencyData pkgId pkgVersion pkgDepInfoWithVersions <- traverse zipDependencyVersions pkgDepInfo let compatiblePkgDepInfo = fmap (filterDependencyOsCompatible osPredicate) pkgDepInfoWithVersions res <- catMaybes <$> traverse filterDependencyBestVersion compatiblePkgDepInfo pure (pkgId, pkgCategories', pkgVersions', pkgVersion, res) constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) => ( Key PkgRecord , [Category] , [Version] , Version , [(Key PkgRecord, Text, Version)] ) -> m PackageRes constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do settings <- ask @_ @_ @AppSettings let pkgId = unPkgRecordKey pkgKey manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs -> runConduit $ bs .| CL.foldMap LBS.fromStrict icon <- loadIcon pkgId pkgVersion deps <- constructDependenciesApiRes dependencies pure $ PackageRes { packageResIcon = encodeBase64 icon -- pass through raw JSON Value, we have checked its correct parsing above , packageResManifest = unsafeFromJust . decode $ manifest , packageResCategories = categoryName <$> pkgCategories , packageResInstructions = basicRender $ InstructionsR pkgId , packageResLicense = basicRender $ LicenseR pkgId , packageResVersions = pkgVersions , packageResDependencies = HM.fromList deps } constructDependenciesApiRes :: (MonadResource m, MonadReader r m, Has PkgRepo r) => [(Key PkgRecord, Text, Version)] -> m [(PkgId, DependencyRes)] constructDependenciesApiRes deps = traverse (\(depKey, depTitle, depVersion) -> do let depId = unPkgRecordKey depKey icon <- loadIcon depId depVersion pure (depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = encodeBase64 icon }) ) deps loadIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString loadIcon pkg version = do (_, _, src) <- getIcon pkg version runConduit $ src .| CL.foldMap id basicRender :: RenderRoute a => Route a -> Text basicRender = TL.toStrict . TB.toLazyText . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute