Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-30 19:54:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #83 from Start9Labs/bugfix/relative-urls

Browse Source 
makes relative urls and uses route types to generate them
This commit is contained in:
Lucy C
2021-12-20 12:46:42 -07:00
committed by GitHub
parent 0ca2372b6d 27b55e64e0
commit 3159f2b3bd
1 changed files with 33 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

56
src/Handler/Marketplace.hs
View File

@@ -24,7 +24,10 @@ import Conduit ( (.|)
, sinkList , sinkList
, sourceFile , sourceFile
, takeC , takeC
)
import Control.Monad.Logger ( MonadLogger, logWarn )
import Control.Monad.Reader.Has ( Has
, ask
) )
import Crypto.Hash ( SHA256 ) import Crypto.Hash ( SHA256 )
import Crypto.Hash.Conduit ( hashFile ) import Crypto.Hash.Conduit ( hashFile )
@@ -46,6 +49,8 @@ import Data.List ( head
import Data.String.Interpolate.IsString import Data.String.Interpolate.IsString
( i ) ( i )
import qualified Data.Text as T 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 import Database.Esqueleto.Experimental
( Entity(entityKey, entityVal) ( Entity(entityKey, entityVal)
, SqlBackend , SqlBackend
@@ -67,15 +72,13 @@ import Database.Persist ( PersistUniqueRead(getBy)
, insertUnique , insertUnique
) )
import Foundation ( Handler import Foundation ( Handler
, RegistryCtx(appSettings, appConnPool) , RegistryCtx(appSettings, appConnPool), Route (IconsR, InstructionsR, LicenseR)
) )
import Handler.Types.Marketplace
import Lib.Error ( S9Error(..) import Lib.Error ( S9Error(..)
) )
import Lib.PkgRepository ( getManifest ) import Lib.PkgRepository ( getManifest )
import Lib.Types.AppIndex ( PkgId(PkgId) import Lib.Types.AppIndex ( PkgId(PkgId)
) )
import Lib.Types.AppIndex ( ) import Lib.Types.AppIndex ( )
import Lib.Types.Category ( CategoryTitle(..) ) import Lib.Types.Category ( CategoryTitle(..) )
@@ -97,14 +100,19 @@ import Network.HTTP.Types ( status400
, status404 , status404
) )
import Protolude.Unsafe ( unsafeFromJust ) import Protolude.Unsafe ( unsafeFromJust )
import Settings ( AppSettings(registryHostname, resourcesDir) ) import Settings
import System.Directory ( getFileSize ) import System.Directory ( getFileSize )
import System.FilePath ( (</>) ) import System.FilePath ( (</>) )
import UnliftIO.Async ( concurrently import UnliftIO.Async ( concurrently
, mapConcurrently , mapConcurrently
) )
import UnliftIO.Directory ( listDirectory ) import UnliftIO.Directory ( listDirectory )
import Util.Shared ( getVersionSpecFromQuery, filterLatestVersionFromSpec, filterPkgOsCompatible, filterDependencyOsCompatible, filterDependencyBestVersion ) import Util.Shared ( getVersionSpecFromQuery
, filterLatestVersionFromSpec
, filterPkgOsCompatible
, filterDependencyOsCompatible
, filterDependencyBestVersion
)
import Yesod.Core ( MonadResource import Yesod.Core ( MonadResource
, TypedContent , TypedContent
, YesodRequest(..) , YesodRequest(..)
@@ -116,15 +124,10 @@ import Yesod.Core ( MonadResource
, sendChunkBS , sendChunkBS
, sendResponseStatus , sendResponseStatus
, typeOctet , typeOctet
, getYesod , getYesod, RenderRoute (renderRoute)
) )
import Yesod.Persist ( YesodDB ) import Yesod.Persist ( YesodDB )
import Yesod.Persist.Core ( YesodPersist(runDB) ) import Yesod.Persist.Core ( YesodPersist(runDB) )
import Control.Monad.Logger
import Control.Monad.Reader.Has ( Has
, ask
)
import Handler.Types.Marketplace
getCategoriesR :: Handler CategoryRes getCategoriesR :: Handler CategoryRes
getCategoriesR = do getCategoriesR = do
@@ -323,23 +326,30 @@ getPackageListR = do
pure $ (pkgId, pkgCategories', pkgVersions', pkgVersion, res) pure $ (pkgId, pkgCategories', pkgVersions', pkgVersion, res)
constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r) => (Key PkgRecord, [Category], [Version], Version, [(Key PkgRecord, Text, Version)]) -> m PackageRes constructPackageListApiRes :: (MonadResource m, MonadReader r m, Has AppSettings r) => (Key PkgRecord, [Category], [Version], Version, [(Key PkgRecord, Text, Version)]) -> m PackageRes
constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do constructPackageListApiRes (pkgKey, pkgCategories, pkgVersions, pkgVersion, dependencies) = do
settings <- ask settings <- ask @_ @_ @AppSettings
let pkgId = unPkgRecordKey pkgKey let pkgId = unPkgRecordKey pkgKey
let domain = registryHostname settings
manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs -> manifest <- flip runReaderT settings $ (snd <$> getManifest pkgId pkgVersion) >>= \bs ->
runConduit $ bs .| CL.foldMap BS.fromStrict runConduit $ bs .| CL.foldMap BS.fromStrict
pure $ PackageRes { packageResIcon = [i|https://#{domain}/package/icon/#{pkgId}|] pure $ PackageRes
{ packageResIcon = basicRender $ IconsR pkgId
-- pass through raw JSON Value, we have checked its correct parsing above -- pass through raw JSON Value, we have checked its correct parsing above
, packageResManifest = unsafeFromJust . decode $ manifest , packageResManifest = unsafeFromJust . decode $ manifest
, packageResCategories = categoryName <$> pkgCategories , packageResCategories = categoryName <$> pkgCategories
, packageResInstructions = [i|https://#{domain}/package/instructions/#{pkgId}|] , packageResInstructions = basicRender $ InstructionsR pkgId
, packageResLicense = [i|https://#{domain}/package/license/#{pkgId}|] , packageResLicense = basicRender $ LicenseR pkgId
, packageResVersions = pkgVersions , packageResVersions = pkgVersions
, packageResDependencies = HM.fromList $ constructDependenciesApiRes domain dependencies , packageResDependencies = HM.fromList $ constructDependenciesApiRes dependencies
} }
constructDependenciesApiRes :: Text constructDependenciesApiRes :: [(Key PkgRecord, Text, Version)]
-> [(Key PkgRecord, Text, Version)]
-> [(PkgId, DependencyRes)] -> [(PkgId, DependencyRes)]
constructDependenciesApiRes domain deps = fmap (\(depKey, depTitle, depVersion) -> do constructDependenciesApiRes deps = fmap (\(depKey, depTitle, depVersion) -> do
let depId = unPkgRecordKey depKey let depId = unPkgRecordKey depKey
(depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = [i|https://#{domain}/package/icon/#{depId}?spec==#{depVersion}|]})) deps (depId, DependencyRes { dependencyResTitle = depTitle, dependencyResIcon = (basicRender $ IconsR depId) <> [i|?spec==#{depVersion}|]})) deps
basicRender :: RenderRoute a => Route a -> Text
basicRender = TL.toStrict
. TB.toLazyText
. fold
. fmap (mappend (TB.singleton '/') . TB.fromText)
. fst
. renderRoute