mirror of
https://github.com/Start9Labs/registry.git
synced 2026-04-01 04:33:39 +00:00
Feature/api versioning (#106)
* wip * finishes initial refactor * prune unused code * finished massive refactor * remove commented deps * fix import * fix bug
This commit is contained in:
Keagan McClelland
committed by
GitHub
GitHub
parent
bb0488f1dd
commit
dbd73fae7f
@@ -1,128 +1,148 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Handler.Admin where
|
||||
|
||||
import Conduit ( (.|)
|
||||
, runConduit
|
||||
, sinkFile
|
||||
)
|
||||
import Control.Exception ( ErrorCall(ErrorCall) )
|
||||
import Control.Monad.Reader.Has ( ask )
|
||||
import Control.Monad.Trans.Maybe ( MaybeT(..) )
|
||||
import Data.Aeson ( (.:)
|
||||
, (.:?)
|
||||
, (.=)
|
||||
, FromJSON(parseJSON)
|
||||
, ToJSON
|
||||
, decodeFileStrict
|
||||
, object
|
||||
, withObject
|
||||
)
|
||||
import Data.HashMap.Internal.Strict ( HashMap
|
||||
, differenceWith
|
||||
, filter
|
||||
, fromListWith
|
||||
)
|
||||
import Data.List ( (\\)
|
||||
, null
|
||||
)
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Database.Persist ( Entity(entityKey)
|
||||
, PersistStoreRead(get)
|
||||
, PersistUniqueRead(getBy)
|
||||
, PersistUniqueWrite(deleteBy, insertUnique, upsert)
|
||||
, entityVal
|
||||
, insert_
|
||||
, selectList
|
||||
)
|
||||
import Database.Persist.Postgresql ( runSqlPoolNoTransaction )
|
||||
import Database.Queries ( upsertPackageVersion )
|
||||
import Foundation ( Handler
|
||||
, RegistryCtx(..)
|
||||
)
|
||||
import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoFileRoot)
|
||||
, extractPkg
|
||||
, getManifestLocation
|
||||
, getPackages
|
||||
, getVersionsFor
|
||||
)
|
||||
import Lib.Types.AppIndex ( PackageManifest(..)
|
||||
, PkgId(unPkgId)
|
||||
)
|
||||
import Lib.Types.Emver ( Version(..) )
|
||||
import Model ( Category(..)
|
||||
, Key(AdminKey, PkgRecordKey, VersionRecordKey)
|
||||
, PkgCategory(PkgCategory)
|
||||
, Unique(UniqueName, UniquePkgCategory)
|
||||
, Upload(..)
|
||||
, VersionRecord(versionRecordNumber, versionRecordPkgId)
|
||||
, unPkgRecordKey
|
||||
)
|
||||
import Network.HTTP.Types ( status403
|
||||
, status404
|
||||
, status500
|
||||
)
|
||||
import Settings
|
||||
import Startlude ( ($)
|
||||
, (&&&)
|
||||
, (.)
|
||||
, (<$>)
|
||||
, (<<$>>)
|
||||
, (<>)
|
||||
, Applicative(pure)
|
||||
, Bool(..)
|
||||
, Eq
|
||||
, Int
|
||||
, Maybe(..)
|
||||
, Monad((>>=))
|
||||
, Show
|
||||
, SomeException(..)
|
||||
, Text
|
||||
, asum
|
||||
, fmap
|
||||
, fromMaybe
|
||||
, getCurrentTime
|
||||
, guarded
|
||||
, hush
|
||||
, isNothing
|
||||
, liftIO
|
||||
, not
|
||||
, replicate
|
||||
, show
|
||||
, throwIO
|
||||
, toS
|
||||
, traverse
|
||||
, void
|
||||
, when
|
||||
, zip
|
||||
)
|
||||
import System.FilePath ( (<.>)
|
||||
, (</>)
|
||||
)
|
||||
import UnliftIO ( try
|
||||
, withTempDirectory
|
||||
)
|
||||
import UnliftIO.Directory ( createDirectoryIfMissing
|
||||
, removePathForcibly
|
||||
, renameDirectory
|
||||
, renameFile
|
||||
)
|
||||
import Util.Shared ( orThrow
|
||||
, sendResponseText
|
||||
)
|
||||
import Yesod ( ToJSON(..)
|
||||
, delete
|
||||
, getsYesod
|
||||
, logError
|
||||
, rawRequestBody
|
||||
, requireCheckJsonBody
|
||||
, runDB
|
||||
)
|
||||
import Yesod.Auth ( YesodAuth(maybeAuthId) )
|
||||
import Yesod.Core.Types ( JSONResponse(JSONResponse) )
|
||||
import Conduit (
|
||||
runConduit,
|
||||
sinkFile,
|
||||
(.|),
|
||||
)
|
||||
import Control.Exception (ErrorCall (ErrorCall))
|
||||
import Control.Monad.Reader.Has (ask)
|
||||
import Control.Monad.Trans.Maybe (MaybeT (..))
|
||||
import Data.Aeson (
|
||||
FromJSON (parseJSON),
|
||||
ToJSON,
|
||||
decodeFileStrict,
|
||||
object,
|
||||
withObject,
|
||||
(.:),
|
||||
(.:?),
|
||||
(.=),
|
||||
)
|
||||
import Data.HashMap.Internal.Strict (
|
||||
HashMap,
|
||||
differenceWith,
|
||||
filter,
|
||||
fromListWith,
|
||||
)
|
||||
import Data.List (
|
||||
null,
|
||||
(\\),
|
||||
)
|
||||
import Data.String.Interpolate.IsString (
|
||||
i,
|
||||
)
|
||||
import Database.Persist (
|
||||
Entity (entityKey),
|
||||
PersistStoreRead (get),
|
||||
PersistUniqueRead (getBy),
|
||||
PersistUniqueWrite (deleteBy, insertUnique, upsert),
|
||||
entityVal,
|
||||
insert_,
|
||||
selectList,
|
||||
)
|
||||
import Database.Persist.Postgresql (runSqlPoolNoTransaction)
|
||||
import Database.Queries (upsertPackageVersion)
|
||||
import Foundation (
|
||||
Handler,
|
||||
RegistryCtx (..),
|
||||
)
|
||||
import Handler.Util (
|
||||
orThrow,
|
||||
sendResponseText,
|
||||
)
|
||||
import Lib.PkgRepository (
|
||||
PkgRepo (PkgRepo, pkgRepoFileRoot),
|
||||
extractPkg,
|
||||
getManifestLocation,
|
||||
getPackages,
|
||||
getVersionsFor,
|
||||
)
|
||||
import Lib.Types.Core (
|
||||
PkgId (unPkgId),
|
||||
)
|
||||
import Lib.Types.Emver (Version (..))
|
||||
import Lib.Types.Manifest (PackageManifest (..))
|
||||
import Model (
|
||||
Category (..),
|
||||
Key (AdminKey, PkgRecordKey, VersionRecordKey),
|
||||
PkgCategory (PkgCategory),
|
||||
Unique (UniqueName, UniquePkgCategory),
|
||||
Upload (..),
|
||||
VersionRecord (versionRecordNumber, versionRecordPkgId),
|
||||
unPkgRecordKey,
|
||||
)
|
||||
import Network.HTTP.Types (
|
||||
status403,
|
||||
status404,
|
||||
status500,
|
||||
)
|
||||
import Settings
|
||||
import Startlude (
|
||||
Applicative (pure),
|
||||
Bool (..),
|
||||
Eq,
|
||||
Int,
|
||||
Maybe (..),
|
||||
Monad ((>>=)),
|
||||
Show,
|
||||
SomeException (..),
|
||||
Text,
|
||||
asum,
|
||||
fmap,
|
||||
fromMaybe,
|
||||
getCurrentTime,
|
||||
guarded,
|
||||
hush,
|
||||
isNothing,
|
||||
liftIO,
|
||||
not,
|
||||
replicate,
|
||||
show,
|
||||
throwIO,
|
||||
toS,
|
||||
traverse,
|
||||
void,
|
||||
when,
|
||||
zip,
|
||||
($),
|
||||
(&&&),
|
||||
(.),
|
||||
(.*),
|
||||
(<$>),
|
||||
(<<$>>),
|
||||
(<>),
|
||||
)
|
||||
import System.FilePath (
|
||||
(<.>),
|
||||
(</>),
|
||||
)
|
||||
import UnliftIO (
|
||||
try,
|
||||
withTempDirectory,
|
||||
)
|
||||
import UnliftIO.Directory (
|
||||
createDirectoryIfMissing,
|
||||
removePathForcibly,
|
||||
renameDirectory,
|
||||
renameFile,
|
||||
)
|
||||
import Yesod (
|
||||
ToJSON (..),
|
||||
delete,
|
||||
getsYesod,
|
||||
logError,
|
||||
rawRequestBody,
|
||||
requireCheckJsonBody,
|
||||
runDB,
|
||||
)
|
||||
import Yesod.Auth (YesodAuth (maybeAuthId))
|
||||
import Yesod.Core.Types (JSONResponse (JSONResponse))
|
||||
|
||||
|
||||
postPkgUploadR :: Handler ()
|
||||
postPkgUploadR = do
|
||||
@@ -131,14 +151,15 @@ postPkgUploadR = do
|
||||
withTempDirectory resourcesTemp "newpkg" $ \dir -> do
|
||||
let path = dir </> "temp" <.> "s9pk"
|
||||
runConduit $ rawRequestBody .| sinkFile path
|
||||
pool <- getsYesod appConnPool
|
||||
PkgRepo {..} <- ask
|
||||
res <- retry $ extractPkg pool path
|
||||
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 (dir </> "manifest.json"))
|
||||
`orThrow` sendResponseText status500 "Failed to parse manifest.json"
|
||||
PackageManifest{..} <-
|
||||
liftIO (decodeFileStrict (dir </> "manifest.json"))
|
||||
`orThrow` sendResponseText status500 "Failed to parse manifest.json"
|
||||
renameFile path (dir </> (toS . unPkgId) packageManifestId <.> "s9pk")
|
||||
let targetPath = pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion
|
||||
removePathForcibly targetPath
|
||||
@@ -153,92 +174,100 @@ postPkgUploadR = do
|
||||
Just name -> do
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
|
||||
where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
|
||||
where
|
||||
retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
|
||||
|
||||
|
||||
data IndexPkgReq = IndexPkgReq
|
||||
{ indexPkgReqId :: !PkgId
|
||||
{ indexPkgReqId :: !PkgId
|
||||
, indexPkgReqVersion :: !Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance FromJSON IndexPkgReq where
|
||||
parseJSON = withObject "Index Package Request" $ \o -> do
|
||||
indexPkgReqId <- o .: "id"
|
||||
indexPkgReqId <- o .: "id"
|
||||
indexPkgReqVersion <- o .: "version"
|
||||
pure IndexPkgReq { .. }
|
||||
pure IndexPkgReq{..}
|
||||
instance ToJSON IndexPkgReq where
|
||||
toJSON IndexPkgReq {..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion]
|
||||
toJSON IndexPkgReq{..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion]
|
||||
|
||||
|
||||
postPkgIndexR :: Handler ()
|
||||
postPkgIndexR = do
|
||||
IndexPkgReq {..} <- requireCheckJsonBody
|
||||
manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion
|
||||
man <- liftIO (decodeFileStrict manifest) `orThrow` sendResponseText
|
||||
status404
|
||||
[i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
|
||||
IndexPkgReq{..} <- requireCheckJsonBody
|
||||
manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion
|
||||
man <-
|
||||
liftIO (decodeFileStrict manifest)
|
||||
`orThrow` sendResponseText
|
||||
status404
|
||||
[i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
|
||||
pool <- getsYesod appConnPool
|
||||
runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing
|
||||
|
||||
|
||||
postPkgDeindexR :: Handler ()
|
||||
postPkgDeindexR = do
|
||||
IndexPkgReq {..} <- requireCheckJsonBody
|
||||
IndexPkgReq{..} <- requireCheckJsonBody
|
||||
runDB $ delete (VersionRecordKey (PkgRecordKey indexPkgReqId) indexPkgReqVersion)
|
||||
|
||||
newtype PackageList = PackageList { unPackageList :: HashMap PkgId [Version] }
|
||||
|
||||
newtype PackageList = PackageList {unPackageList :: HashMap PkgId [Version]}
|
||||
instance FromJSON PackageList where
|
||||
parseJSON = fmap PackageList . parseJSON
|
||||
instance ToJSON PackageList where
|
||||
toJSON = toJSON . unPackageList
|
||||
|
||||
|
||||
getPkgDeindexR :: Handler (JSONResponse PackageList)
|
||||
getPkgDeindexR = do
|
||||
dbList <-
|
||||
runDB
|
||||
$ (unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber)
|
||||
. entityVal
|
||||
<<$>> selectList [] []
|
||||
runDB $
|
||||
(unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber)
|
||||
. entityVal
|
||||
<<$>> selectList [] []
|
||||
let inDb = fromListWith (<>) dbList
|
||||
pkgsOnDisk <- getPackages
|
||||
onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk
|
||||
onDisk <- fromListWith (<>) . zip pkgsOnDisk <$> traverse getVersionsFor pkgsOnDisk
|
||||
pure . JSONResponse . PackageList $ filter (not . null) $ differenceWith (guarded null .* (\\)) onDisk inDb
|
||||
|
||||
{-# INLINE (.*) #-}
|
||||
infixr 8 .*
|
||||
(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
|
||||
(.*) = (.) . (.)
|
||||
|
||||
data AddCategoryReq = AddCategoryReq
|
||||
{ addCategoryDescription :: !(Maybe Text)
|
||||
, addCategoryPriority :: !(Maybe Int)
|
||||
, addCategoryPriority :: !(Maybe Int)
|
||||
}
|
||||
instance FromJSON AddCategoryReq where
|
||||
parseJSON = withObject "AddCategoryReq" $ \o -> do
|
||||
addCategoryDescription <- o .:? "description"
|
||||
addCategoryPriority <- o .:? "priority"
|
||||
pure AddCategoryReq { .. }
|
||||
addCategoryPriority <- o .:? "priority"
|
||||
pure AddCategoryReq{..}
|
||||
instance ToJSON AddCategoryReq where
|
||||
toJSON AddCategoryReq {..} = object ["description" .= addCategoryDescription, "priority" .= addCategoryPriority]
|
||||
toJSON AddCategoryReq{..} = object ["description" .= addCategoryDescription, "priority" .= addCategoryPriority]
|
||||
|
||||
|
||||
postCategoryR :: Text -> Handler ()
|
||||
postCategoryR cat = do
|
||||
AddCategoryReq {..} <- requireCheckJsonBody
|
||||
now <- liftIO getCurrentTime
|
||||
AddCategoryReq{..} <- requireCheckJsonBody
|
||||
now <- liftIO getCurrentTime
|
||||
void . runDB $ upsert (Category now cat (fromMaybe "" addCategoryDescription) (fromMaybe 0 addCategoryPriority)) []
|
||||
|
||||
|
||||
deleteCategoryR :: Text -> Handler ()
|
||||
deleteCategoryR cat = runDB $ deleteBy (UniqueName cat)
|
||||
|
||||
|
||||
postPkgCategorizeR :: Text -> PkgId -> Handler ()
|
||||
postPkgCategorizeR cat pkg = runDB $ do
|
||||
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
|
||||
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
|
||||
_pkgEnt <- get (PkgRecordKey pkg) `orThrow` sendResponseText status404 [i|Package "#{pkg}" does not exist|]
|
||||
now <- liftIO getCurrentTime
|
||||
void $ insertUnique (PkgCategory now (PkgRecordKey pkg) (entityKey catEnt)) `orThrow` sendResponseText
|
||||
status403
|
||||
[i|Package "#{pkg}" is already assigned to category "#{cat}"|]
|
||||
now <- liftIO getCurrentTime
|
||||
void $
|
||||
insertUnique (PkgCategory now (PkgRecordKey pkg) (entityKey catEnt))
|
||||
`orThrow` sendResponseText
|
||||
status403
|
||||
[i|Package "#{pkg}" is already assigned to category "#{cat}"|]
|
||||
|
||||
|
||||
deletePkgCategorizeR :: Text -> PkgId -> Handler ()
|
||||
deletePkgCategorizeR cat pkg = runDB $ do
|
||||
catEnt <- getBy (UniqueName cat) `orThrow` sendResponseText status404 [i|Category "#{cat}" does not exist|]
|
||||
deleteBy (UniquePkgCategory (PkgRecordKey pkg) (entityKey catEnt))
|
||||
|
||||
|
||||
@@ -1,113 +0,0 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module Handler.Apps where
|
||||
|
||||
import Startlude ( ($)
|
||||
, (.)
|
||||
, Applicative(pure)
|
||||
, FilePath
|
||||
, Maybe(..)
|
||||
, Monad((>>=))
|
||||
, Show
|
||||
, String
|
||||
, show
|
||||
, void
|
||||
)
|
||||
|
||||
import Control.Monad.Logger ( logError )
|
||||
import qualified Data.Text as T
|
||||
import qualified GHC.Show ( Show(..) )
|
||||
import Network.HTTP.Types ( status404 )
|
||||
import System.FilePath ( (<.>)
|
||||
, takeBaseName
|
||||
)
|
||||
import Yesod.Core ( Content(ContentFile)
|
||||
, TypedContent
|
||||
, addHeader
|
||||
, notFound
|
||||
, respond
|
||||
, respondSource
|
||||
, sendChunkBS
|
||||
, sendResponseStatus
|
||||
, typeJson
|
||||
, typeOctet
|
||||
)
|
||||
import Yesod.Persist.Core ( YesodPersist(runDB) )
|
||||
|
||||
import Conduit ( (.|)
|
||||
, awaitForever
|
||||
)
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Database.Queries ( createMetric
|
||||
, fetchApp
|
||||
, fetchAppVersion
|
||||
)
|
||||
import Foundation ( Handler )
|
||||
import Lib.Error ( S9Error(NotFoundE) )
|
||||
import Lib.PkgRepository ( getBestVersion
|
||||
, getManifest
|
||||
, getPackage
|
||||
)
|
||||
import Lib.Registry ( S9PK )
|
||||
import Lib.Types.AppIndex ( PkgId(PkgId) )
|
||||
import Lib.Types.Emver ( Version )
|
||||
import Util.Shared ( addPackageHeader
|
||||
, getVersionSpecFromQuery
|
||||
, orThrow
|
||||
, versionPriorityFromQueryIsMin
|
||||
)
|
||||
|
||||
data FileExtension = FileExtension !FilePath !(Maybe String)
|
||||
instance Show FileExtension where
|
||||
show (FileExtension f Nothing ) = f
|
||||
show (FileExtension f (Just e)) = f <.> e
|
||||
|
||||
getAppManifestR :: PkgId -> Handler TypedContent
|
||||
getAppManifestR pkg = do
|
||||
versionSpec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <- getBestVersion pkg versionSpec preferMin
|
||||
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
|
||||
addPackageHeader pkg version
|
||||
(len, src) <- getManifest pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typeJson $ src .| awaitForever sendChunkBS
|
||||
|
||||
getAppR :: S9PK -> Handler TypedContent
|
||||
getAppR file = do
|
||||
let pkg = PkgId . T.pack $ takeBaseName (show file)
|
||||
versionSpec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <- getBestVersion pkg versionSpec preferMin
|
||||
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
|
||||
addPackageHeader pkg version
|
||||
void $ recordMetrics pkg version
|
||||
pkgPath <- getPackage pkg version >>= \case
|
||||
Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|])
|
||||
Just a -> pure a
|
||||
respond typeOctet $ ContentFile pkgPath Nothing
|
||||
|
||||
|
||||
recordMetrics :: PkgId -> Version -> Handler ()
|
||||
recordMetrics pkg appVersion = do
|
||||
sa <- runDB $ fetchApp pkg
|
||||
case sa of
|
||||
Nothing -> do
|
||||
$logError [i|#{pkg} not found in database|]
|
||||
notFound
|
||||
Just _ -> do
|
||||
existingVersion <- runDB $ fetchAppVersion pkg appVersion
|
||||
case existingVersion of
|
||||
Nothing -> do
|
||||
$logError [i|#{pkg}@#{appVersion} not found in database|]
|
||||
notFound
|
||||
Just _ -> runDB $ createMetric pkg appVersion
|
||||
|
||||
5
src/Handler/Eos.hs
Normal file
5
src/Handler/Eos.hs
Normal file
@@ -0,0 +1,5 @@
|
||||
module Handler.Eos (module X) where
|
||||
|
||||
import Handler.Eos.V0.EosImg as X
|
||||
import Handler.Eos.V0.Latest as X
|
||||
|
||||
53
src/Handler/Eos/V0/EosImg.hs
Normal file
53
src/Handler/Eos/V0/EosImg.hs
Normal file
@@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Handler.Eos.V0.EosImg where
|
||||
|
||||
import Crypto.Hash (SHA256)
|
||||
import Crypto.Hash.Conduit (hashFile)
|
||||
import Data.Attoparsec.Text qualified as Atto
|
||||
import Data.ByteArray.Encoding (Base (..), convertToBase)
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Data.Text qualified as T
|
||||
import Database.Persist (Entity (..), insertUnique)
|
||||
import Database.Persist.Class (getBy)
|
||||
import Foundation (Handler, RegistryCtx (..))
|
||||
import Handler.Util (getVersionSpecFromQuery)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.Types.Emver (Version (..), parseVersion, satisfies)
|
||||
import Model (EosHash (..), Unique (..))
|
||||
import Network.HTTP.Types (status404)
|
||||
import Settings (AppSettings (..))
|
||||
import Startlude (Down (..), FilePath, Maybe (..), Text, decodeUtf8, filter, for_, headMay, partitionEithers, pure, show, sortOn, void, ($), (.), (<$>))
|
||||
import System.FilePath ((</>))
|
||||
import UnliftIO.Directory (listDirectory)
|
||||
import Yesod (Content (..), TypedContent, YesodDB, YesodPersist (runDB), addHeader, getsYesod, respond, sendResponseStatus, typeOctet)
|
||||
import Yesod.Core (logWarn)
|
||||
|
||||
|
||||
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
|
||||
65
src/Handler/Eos/V0/Latest.hs
Normal file
65
src/Handler/Eos/V0/Latest.hs
Normal file
@@ -0,0 +1,65 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Handler.Eos.V0.Latest where
|
||||
|
||||
import Data.Aeson (ToJSON (toJSON), object, (.=))
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Database.Esqueleto.Experimental (
|
||||
Entity (entityVal),
|
||||
desc,
|
||||
from,
|
||||
orderBy,
|
||||
select,
|
||||
table,
|
||||
(^.),
|
||||
)
|
||||
import Foundation (Handler)
|
||||
import Handler.Package.V0.ReleaseNotes (ReleaseNotes (..))
|
||||
import Handler.Util (queryParamAs)
|
||||
import Lib.Types.Emver (Version, parseVersion)
|
||||
import Model (EntityField (..), OsVersion (..))
|
||||
import Orphans.Emver ()
|
||||
import Startlude (Bool (..), Down (..), Eq, Generic, Maybe, Ord ((<)), Show, Text, const, filter, fst, head, maybe, pure, sortOn, ($), (&&&), (.), (<$>), (<&>))
|
||||
import Yesod (ToContent (toContent), ToTypedContent (..), YesodPersist (runDB))
|
||||
import Yesod.Core.Types (JSONResponse (..))
|
||||
|
||||
|
||||
data EosRes = EosRes
|
||||
{ eosResVersion :: !Version
|
||||
, eosResHeadline :: !Text
|
||||
, eosResReleaseNotes :: !ReleaseNotes
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
instance ToJSON EosRes where
|
||||
toJSON EosRes{..} =
|
||||
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
|
||||
instance ToContent EosRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent EosRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
|
||||
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) $
|
||||
((osVersionNumber &&& osVersionReleaseNotes))
|
||||
<$> osV
|
||||
pure . JSONResponse $
|
||||
mLatest <&> \latest ->
|
||||
EosRes
|
||||
{ eosResVersion = osVersionNumber latest
|
||||
, eosResHeadline = osVersionHeadline latest
|
||||
, eosResReleaseNotes = mappedVersions
|
||||
}
|
||||
@@ -1,66 +0,0 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Handler.ErrorLogs where
|
||||
|
||||
import Data.Aeson ( (.:)
|
||||
, FromJSON(parseJSON)
|
||||
, withObject
|
||||
)
|
||||
import Foundation ( Handler )
|
||||
import Model ( EntityField(ErrorLogRecordIncidents)
|
||||
, ErrorLogRecord(ErrorLogRecord)
|
||||
)
|
||||
import Startlude ( ($)
|
||||
, Applicative(pure)
|
||||
, Eq
|
||||
, MonadIO(liftIO)
|
||||
, Show
|
||||
, Text
|
||||
, Word32
|
||||
, getCurrentTime
|
||||
, void
|
||||
)
|
||||
import Yesod.Core ( requireCheckJsonBody )
|
||||
import Yesod.Persist ( (+=.)
|
||||
, runDB
|
||||
, upsert
|
||||
)
|
||||
|
||||
data ErrorLog = ErrorLog
|
||||
{ errorLogEpoch :: !Text
|
||||
, errorLogCommitHash :: !Text
|
||||
, errorLogSourceFile :: !Text
|
||||
, errorLogLine :: !Word32
|
||||
, errorLogTarget :: !Text
|
||||
, errorLogLevel :: !Text
|
||||
, errorLogMessage :: !Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSON ErrorLog where
|
||||
parseJSON = withObject "Error Log" $ \o -> do
|
||||
errorLogEpoch <- o .: "log-epoch"
|
||||
errorLogCommitHash <- o .: "commit-hash"
|
||||
errorLogSourceFile <- o .: "file"
|
||||
errorLogLine <- o .: "line"
|
||||
errorLogLevel <- o .: "level"
|
||||
errorLogTarget <- o .: "target"
|
||||
errorLogMessage <- o .: "log-message"
|
||||
pure ErrorLog { .. }
|
||||
|
||||
|
||||
postErrorLogsR :: Handler ()
|
||||
postErrorLogsR = do
|
||||
ErrorLog {..} <- requireCheckJsonBody @_ @ErrorLog
|
||||
void $ runDB $ do
|
||||
now <- liftIO getCurrentTime
|
||||
let logRecord = ErrorLogRecord now
|
||||
errorLogEpoch
|
||||
errorLogCommitHash
|
||||
errorLogSourceFile
|
||||
errorLogLine
|
||||
errorLogTarget
|
||||
errorLogLevel
|
||||
errorLogMessage
|
||||
1
|
||||
upsert logRecord [ErrorLogRecordIncidents +=. 1]
|
||||
@@ -1,80 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Handler.Icons where
|
||||
|
||||
import Startlude ( ($)
|
||||
, Eq
|
||||
, Generic
|
||||
, Read
|
||||
, Show
|
||||
, show
|
||||
)
|
||||
|
||||
import Data.Conduit ( (.|)
|
||||
, awaitForever
|
||||
)
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Foundation ( Handler )
|
||||
import Lib.Error ( S9Error(NotFoundE) )
|
||||
import Lib.PkgRepository ( getBestVersion
|
||||
, getIcon
|
||||
, getInstructions
|
||||
, getLicense
|
||||
)
|
||||
import Lib.Types.AppIndex ( PkgId )
|
||||
import Network.HTTP.Types ( status400 )
|
||||
import Util.Shared ( getVersionSpecFromQuery
|
||||
, orThrow
|
||||
, versionPriorityFromQueryIsMin
|
||||
)
|
||||
import Yesod.Core ( FromJSON
|
||||
, ToJSON
|
||||
, TypedContent
|
||||
, addHeader
|
||||
, respondSource
|
||||
, sendChunkBS
|
||||
, sendResponseStatus
|
||||
, typePlain
|
||||
)
|
||||
|
||||
data IconType = PNG | JPG | JPEG | SVG
|
||||
deriving (Eq, Show, Generic, Read)
|
||||
instance ToJSON IconType
|
||||
instance FromJSON IconType
|
||||
|
||||
getIconsR :: PkgId -> Handler TypedContent
|
||||
getIconsR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <- getBestVersion pkg spec preferMin
|
||||
`orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|])
|
||||
(ct, len, src) <- getIcon pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource ct $ src .| awaitForever sendChunkBS
|
||||
|
||||
getLicenseR :: PkgId -> Handler TypedContent
|
||||
getLicenseR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <- getBestVersion pkg spec preferMin
|
||||
`orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|])
|
||||
(len, src) <- getLicense pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typePlain $ src .| awaitForever sendChunkBS
|
||||
|
||||
getInstructionsR :: PkgId -> Handler TypedContent
|
||||
getInstructionsR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <- getBestVersion pkg spec preferMin
|
||||
`orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|])
|
||||
(len, src) <- getInstructions pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typePlain $ src .| awaitForever sendChunkBS
|
||||
@@ -1,451 +0,0 @@
|
||||
{-# 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" "<MISSING>")
|
||||
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
|
||||
59
src/Handler/Package.hs
Normal file
59
src/Handler/Package.hs
Normal file
@@ -0,0 +1,59 @@
|
||||
module Handler.Package where
|
||||
|
||||
import Foundation (Handler)
|
||||
import Handler.Package.V0.Icon qualified
|
||||
import Handler.Package.V0.Index (PackageListRes, getPackageIndexR)
|
||||
import Handler.Package.V0.Info (InfoRes, getInfoR)
|
||||
import Handler.Package.V0.Instructions qualified
|
||||
import Handler.Package.V0.Latest (VersionLatestRes, getVersionLatestR)
|
||||
import Handler.Package.V0.License qualified
|
||||
import Handler.Package.V0.Manifest qualified
|
||||
import Handler.Package.V0.ReleaseNotes (ReleaseNotes, getReleaseNotesR)
|
||||
import Handler.Package.V0.S9PK qualified
|
||||
import Handler.Package.V0.Version (AppVersionRes, getPkgVersionR)
|
||||
import Handler.Types.Api (ApiVersion (..))
|
||||
import Lib.Types.Core (PkgId, S9PK)
|
||||
import Yesod.Core.Types (
|
||||
JSONResponse,
|
||||
TypedContent,
|
||||
)
|
||||
|
||||
|
||||
getInfoR :: ApiVersion -> Handler (JSONResponse InfoRes)
|
||||
getInfoR _ = Handler.Package.V0.Info.getInfoR
|
||||
|
||||
|
||||
getPackageIndexR :: ApiVersion -> Handler PackageListRes
|
||||
getPackageIndexR _ = Handler.Package.V0.Index.getPackageIndexR
|
||||
|
||||
|
||||
getVersionLatestR :: ApiVersion -> Handler VersionLatestRes
|
||||
getVersionLatestR _ = Handler.Package.V0.Latest.getVersionLatestR
|
||||
|
||||
|
||||
getAppR :: ApiVersion -> S9PK -> Handler TypedContent
|
||||
getAppR _ = Handler.Package.V0.S9PK.getAppR
|
||||
|
||||
|
||||
getAppManifestR :: ApiVersion -> PkgId -> Handler TypedContent
|
||||
getAppManifestR _ = Handler.Package.V0.Manifest.getAppManifestR
|
||||
|
||||
|
||||
getReleaseNotesR :: ApiVersion -> PkgId -> Handler ReleaseNotes
|
||||
getReleaseNotesR _ = Handler.Package.V0.ReleaseNotes.getReleaseNotesR
|
||||
|
||||
|
||||
getIconsR :: ApiVersion -> PkgId -> Handler TypedContent
|
||||
getIconsR _ = Handler.Package.V0.Icon.getIconsR
|
||||
|
||||
|
||||
getLicenseR :: ApiVersion -> PkgId -> Handler TypedContent
|
||||
getLicenseR _ = Handler.Package.V0.License.getLicenseR
|
||||
|
||||
|
||||
getInstructionsR :: ApiVersion -> PkgId -> Handler TypedContent
|
||||
getInstructionsR _ = Handler.Package.V0.Instructions.getInstructionsR
|
||||
|
||||
|
||||
getPkgVersionR :: ApiVersion -> PkgId -> Handler AppVersionRes
|
||||
getPkgVersionR _ = Handler.Package.V0.Version.getPkgVersionR
|
||||
32
src/Handler/Package/V0/Icon.hs
Normal file
32
src/Handler/Package/V0/Icon.hs
Normal file
@@ -0,0 +1,32 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Handler.Package.V0.Icon where
|
||||
|
||||
import Conduit (awaitForever, (.|))
|
||||
import Data.String.Interpolate.IsString (
|
||||
i,
|
||||
)
|
||||
import Foundation (Handler)
|
||||
import Handler.Util (
|
||||
getVersionSpecFromQuery,
|
||||
orThrow,
|
||||
versionPriorityFromQueryIsMin,
|
||||
)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (getBestVersion, getIcon)
|
||||
import Lib.Types.Core (PkgId)
|
||||
import Network.HTTP.Types (status400)
|
||||
import Startlude (show, ($))
|
||||
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus)
|
||||
|
||||
|
||||
getIconsR :: PkgId -> Handler TypedContent
|
||||
getIconsR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <-
|
||||
getBestVersion pkg spec preferMin
|
||||
`orThrow` sendResponseStatus status400 (NotFoundE [i|Icon for #{pkg} satisfying #{spec}|])
|
||||
(ct, len, src) <- getIcon pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource ct $ src .| awaitForever sendChunkBS
|
||||
302
src/Handler/Package/V0/Index.hs
Normal file
302
src/Handler/Package/V0/Index.hs
Normal file
@@ -0,0 +1,302 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Handler.Package.V0.Index where
|
||||
|
||||
import Conduit (concatMapC, dropC, mapC, mapMC, runConduit, sinkList, takeC, (.|))
|
||||
import Control.Monad.Reader.Has (Functor (fmap), Has, Monad ((>>=)), MonadReader, ReaderT (runReaderT), ask, lift)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..), Value, decode, eitherDecodeStrict, object, withObject, (.:), (.=))
|
||||
import Data.Attoparsec.Text qualified as Atto
|
||||
import Data.ByteString.Base64 (encodeBase64)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Conduit.List qualified as CL
|
||||
import Data.HashMap.Internal.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.List (lookup)
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Text qualified as T
|
||||
import Database.Persist.Sql (SqlBackend)
|
||||
import Database.Queries (
|
||||
collateVersions,
|
||||
getCategoriesFor,
|
||||
getDependencyVersions,
|
||||
getPkgDataSource,
|
||||
getPkgDependencyData,
|
||||
serviceQuerySource,
|
||||
)
|
||||
import Foundation (Handler, Route (InstructionsR, LicenseR))
|
||||
import Handler.Types.Api (ApiVersion (..))
|
||||
import Handler.Util (basicRender)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (PkgRepo, getIcon, getManifest)
|
||||
import Lib.Types.Core (PkgId)
|
||||
import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies, (<||))
|
||||
import Model (Category (..), Key (..), PkgDependency (..), VersionRecord (..))
|
||||
import Network.HTTP.Types (status400)
|
||||
import Protolude.Unsafe (unsafeFromJust)
|
||||
import Settings (AppSettings)
|
||||
import Startlude (
|
||||
Applicative ((*>)),
|
||||
Bifunctor (..),
|
||||
Bool (..),
|
||||
ByteString,
|
||||
ConvertText (toS),
|
||||
Down (..),
|
||||
Either (..),
|
||||
Eq (..),
|
||||
Generic,
|
||||
Int,
|
||||
Maybe (..),
|
||||
MonadIO,
|
||||
NonEmpty,
|
||||
Num ((*), (-)),
|
||||
Show,
|
||||
Text,
|
||||
Traversable (traverse),
|
||||
catMaybes,
|
||||
const,
|
||||
encodeUtf8,
|
||||
filter,
|
||||
flip,
|
||||
for,
|
||||
fromMaybe,
|
||||
headMay,
|
||||
id,
|
||||
mappend,
|
||||
maximumOn,
|
||||
nonEmpty,
|
||||
note,
|
||||
pure,
|
||||
readMaybe,
|
||||
snd,
|
||||
sortOn,
|
||||
zipWith,
|
||||
zipWithM,
|
||||
($),
|
||||
(&&&),
|
||||
(.),
|
||||
(.*),
|
||||
(<$>),
|
||||
(<&>),
|
||||
(<>),
|
||||
(=<<),
|
||||
)
|
||||
import UnliftIO (Concurrently (..), mapConcurrently)
|
||||
import Yesod (
|
||||
MonadLogger,
|
||||
MonadResource,
|
||||
ToContent (..),
|
||||
ToTypedContent (..),
|
||||
YesodPersist (runDB),
|
||||
lookupGetParam,
|
||||
sendResponseStatus,
|
||||
)
|
||||
import Yesod.Core (logWarn)
|
||||
|
||||
|
||||
data PackageReq = PackageReq
|
||||
{ packageReqId :: !PkgId
|
||||
, packageReqVersion :: !VersionRange
|
||||
}
|
||||
deriving (Show)
|
||||
instance FromJSON PackageReq where
|
||||
parseJSON = withObject "package version" $ \o -> do
|
||||
packageReqId <- o .: "id"
|
||||
packageReqVersion <- o .: "version"
|
||||
pure PackageReq{..}
|
||||
|
||||
|
||||
data PackageRes = PackageRes
|
||||
{ packageResIcon :: !Text
|
||||
, packageResManifest :: !Value -- PackageManifest
|
||||
, packageResCategories :: ![Text]
|
||||
, packageResInstructions :: !Text
|
||||
, packageResLicense :: !Text
|
||||
, packageResVersions :: !(NonEmpty Version)
|
||||
, packageResDependencies :: !(HashMap PkgId DependencyRes)
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
instance ToJSON PackageRes where
|
||||
toJSON PackageRes{..} =
|
||||
object
|
||||
[ "icon" .= packageResIcon
|
||||
, "license" .= packageResLicense
|
||||
, "instructions" .= packageResInstructions
|
||||
, "manifest" .= packageResManifest
|
||||
, "categories" .= packageResCategories
|
||||
, "versions" .= packageResVersions
|
||||
, "dependency-metadata" .= packageResDependencies
|
||||
]
|
||||
|
||||
|
||||
newtype PackageListRes = PackageListRes [PackageRes]
|
||||
deriving (Generic)
|
||||
instance ToJSON PackageListRes
|
||||
instance ToContent PackageListRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent PackageListRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
|
||||
data DependencyRes = DependencyRes
|
||||
{ dependencyResTitle :: !Text
|
||||
, dependencyResIcon :: !Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON DependencyRes where
|
||||
toJSON DependencyRes{..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle]
|
||||
|
||||
|
||||
data PackageMetadata = PackageMetadata
|
||||
{ packageMetadataPkgId :: !PkgId
|
||||
, packageMetadataPkgVersionRecords :: !(NonEmpty VersionRecord)
|
||||
, packageMetadataPkgVersion :: !Version
|
||||
, packageMetadataPkgCategories :: ![Category]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
getPackageIndexR :: Handler PackageListRes
|
||||
getPackageIndexR = do
|
||||
osPredicate <-
|
||||
getOsVersionQuery <&> \case
|
||||
Nothing -> const True
|
||||
Just v -> flip satisfies v
|
||||
pkgIds <- getPkgIdsQuery
|
||||
category <- getCategoryQuery
|
||||
page <- fromMaybe 1 <$> getPageQuery
|
||||
limit' <- fromMaybe 20 <$> getLimitQuery
|
||||
query <- T.strip . fromMaybe "" <$> lookupGetParam "query"
|
||||
let (source, packageRanges) = case pkgIds of
|
||||
Nothing -> (serviceQuerySource category query, const Any)
|
||||
Just packages ->
|
||||
let s = getPkgDataSource (packageReqId <$> packages)
|
||||
r = fromMaybe None . (flip lookup $ (packageReqId &&& packageReqVersion) <$> packages)
|
||||
in (s, r)
|
||||
filteredPackages <-
|
||||
runDB $
|
||||
runConduit $
|
||||
source
|
||||
-- group conduit pipeline by pkg id
|
||||
.| collateVersions
|
||||
-- filter out versions of apps that are incompatible with the OS predicate
|
||||
.| mapC (second (filter (osPredicate . versionRecordOsVersion)))
|
||||
-- prune empty version sets
|
||||
.| concatMapC (\(pkgId, vs) -> (pkgId,) <$> nonEmpty vs)
|
||||
-- grab the latest matching version if it exists
|
||||
.| concatMapC (\(a, b) -> (a,b,) <$> (selectLatestVersionFromSpec packageRanges b))
|
||||
-- construct
|
||||
.| mapMC (\(a, b, c) -> PackageMetadata a b (versionRecordNumber c) <$> getCategoriesFor a)
|
||||
-- pages start at 1 for some reason. TODO: make pages start at 0
|
||||
.| (dropC (limit' * (page - 1)) *> takeC limit')
|
||||
.| 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 <$> runConcurrently (zipWithM (Concurrently .* constructPackageListApiRes) filteredPackages pkgsWithDependencies)
|
||||
|
||||
|
||||
parseQueryParam :: Text -> (Text -> Either Text a) -> Handler (Maybe a)
|
||||
parseQueryParam param parser = do
|
||||
lookupGetParam param >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just x -> case parser x of
|
||||
Left e -> do
|
||||
let err = InvalidParamsE ("get:" <> param) x
|
||||
$logWarn e
|
||||
sendResponseStatus status400 err
|
||||
Right a -> pure (Just a)
|
||||
|
||||
|
||||
getPkgIdsQuery :: Handler (Maybe [PackageReq])
|
||||
getPkgIdsQuery = parseQueryParam "ids" (first toS . eitherDecodeStrict . encodeUtf8)
|
||||
|
||||
|
||||
getCategoryQuery :: Handler (Maybe Text)
|
||||
getCategoryQuery = parseQueryParam "category" ((flip $ note . mappend "Invalid 'category': ") =<< (readMaybe . T.toUpper))
|
||||
|
||||
|
||||
getPageQuery :: Handler (Maybe Int)
|
||||
getPageQuery = parseQueryParam "page" ((flip $ note . mappend "Invalid 'page': ") =<< readMaybe)
|
||||
|
||||
|
||||
getLimitQuery :: Handler (Maybe Int)
|
||||
getLimitQuery = parseQueryParam "per-page" ((flip $ note . mappend "Invalid 'per-page': ") =<< readMaybe)
|
||||
|
||||
|
||||
getOsVersionQuery :: Handler (Maybe VersionRange)
|
||||
getOsVersionQuery = parseQueryParam "eos-version-compat" (first toS . Atto.parseOnly parseRange)
|
||||
|
||||
|
||||
getPackageDependencies ::
|
||||
(MonadIO m, MonadLogger m, MonadResource m, Has PkgRepo r, MonadReader r m) =>
|
||||
(Version -> Bool) ->
|
||||
PackageMetadata ->
|
||||
ReaderT SqlBackend m (HashMap PkgId DependencyRes)
|
||||
getPackageDependencies osPredicate PackageMetadata{packageMetadataPkgId = pkg, packageMetadataPkgVersion = pkgVersion} =
|
||||
do
|
||||
pkgDepInfo <- getPkgDependencyData pkg pkgVersion
|
||||
pkgDepInfoWithVersions <- traverse getDependencyVersions pkgDepInfo
|
||||
let compatiblePkgDepInfo = fmap (filter (osPredicate . versionRecordOsVersion)) pkgDepInfoWithVersions
|
||||
let depMetadata = catMaybes $ zipWith selectDependencyBestVersion pkgDepInfo compatiblePkgDepInfo
|
||||
lift $
|
||||
fmap HM.fromList $
|
||||
for depMetadata $ \(depId, title, v) -> do
|
||||
icon <- encodeBase64 <$> loadIcon depId v
|
||||
pure $ (depId, DependencyRes title icon)
|
||||
|
||||
|
||||
constructPackageListApiRes ::
|
||||
(MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) =>
|
||||
PackageMetadata ->
|
||||
HashMap PkgId DependencyRes ->
|
||||
m PackageRes
|
||||
constructPackageListApiRes PackageMetadata{..} dependencies = do
|
||||
settings <- ask @_ @_ @AppSettings
|
||||
let pkgId = packageMetadataPkgId
|
||||
let pkgCategories = packageMetadataPkgCategories
|
||||
let pkgVersions = packageMetadataPkgVersionRecords
|
||||
let pkgVersion = packageMetadataPkgVersion
|
||||
manifest <-
|
||||
flip runReaderT settings $
|
||||
(snd <$> getManifest pkgId pkgVersion) >>= \bs ->
|
||||
runConduit $ bs .| CL.foldMap LBS.fromStrict
|
||||
icon <- loadIcon pkgId pkgVersion
|
||||
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 V0 pkgId
|
||||
, packageResLicense = basicRender $ LicenseR V0 pkgId
|
||||
, packageResVersions = versionRecordNumber <$> pkgVersions
|
||||
, packageResDependencies = dependencies
|
||||
}
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
selectLatestVersionFromSpec ::
|
||||
(PkgId -> VersionRange) ->
|
||||
NonEmpty VersionRecord ->
|
||||
Maybe VersionRecord
|
||||
selectLatestVersionFromSpec pkgRanges vs =
|
||||
let pkgId = NE.head $ versionRecordPkgId <$> vs
|
||||
spec = pkgRanges (unPkgRecordKey pkgId)
|
||||
in headMay . sortOn (Down . versionRecordNumber) $ NE.filter ((`satisfies` spec) . versionRecordNumber) vs
|
||||
|
||||
|
||||
-- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package)
|
||||
selectDependencyBestVersion :: PkgDependency -> [VersionRecord] -> Maybe (PkgId, Text, Version)
|
||||
selectDependencyBestVersion pkgDepRecord depVersions = do
|
||||
let depId = pkgDependencyDepId pkgDepRecord
|
||||
let versionRequirement = pkgDependencyDepVersionRange pkgDepRecord
|
||||
let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) depVersions
|
||||
case maximumOn versionRecordNumber satisfactory of
|
||||
Just bestVersion -> Just (unPkgRecordKey depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion)
|
||||
Nothing -> Nothing
|
||||
33
src/Handler/Package/V0/Info.hs
Normal file
33
src/Handler/Package/V0/Info.hs
Normal file
@@ -0,0 +1,33 @@
|
||||
module Handler.Package.V0.Info where
|
||||
|
||||
import Data.Aeson (ToJSON (..))
|
||||
import Database.Esqueleto.Experimental (Entity (..), asc, from, orderBy, select, table, (^.))
|
||||
import Foundation (Handler, RegistryCtx (..))
|
||||
import Model (Category (..), EntityField (..))
|
||||
import Settings (AppSettings (..))
|
||||
import Startlude (Generic, Show, Text, pure, ($), (.), (<$>))
|
||||
import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), getsYesod)
|
||||
import Yesod.Core.Types (JSONResponse (..))
|
||||
|
||||
|
||||
data InfoRes = InfoRes
|
||||
{ name :: !Text
|
||||
, categories :: ![Text]
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
instance ToJSON InfoRes
|
||||
instance ToContent InfoRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent InfoRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
|
||||
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
|
||||
26
src/Handler/Package/V0/Instructions.hs
Normal file
26
src/Handler/Package/V0/Instructions.hs
Normal file
@@ -0,0 +1,26 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Handler.Package.V0.Instructions where
|
||||
|
||||
import Conduit (awaitForever, (.|))
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Foundation (Handler)
|
||||
import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (getBestVersion, getInstructions)
|
||||
import Lib.Types.Core (PkgId)
|
||||
import Network.HTTP.Types (status400)
|
||||
import Startlude (show, ($))
|
||||
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain)
|
||||
|
||||
|
||||
getInstructionsR :: PkgId -> Handler TypedContent
|
||||
getInstructionsR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <-
|
||||
getBestVersion pkg spec preferMin
|
||||
`orThrow` sendResponseStatus status400 (NotFoundE [i|Instructions for #{pkg} satisfying #{spec}|])
|
||||
(len, src) <- getInstructions pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typePlain $ src .| awaitForever sendChunkBS
|
||||
48
src/Handler/Package/V0/Latest.hs
Normal file
48
src/Handler/Package/V0/Latest.hs
Normal file
@@ -0,0 +1,48 @@
|
||||
module Handler.Package.V0.Latest where
|
||||
|
||||
import Data.Aeson (ToJSON (..), eitherDecode)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.List (lookup)
|
||||
import Database.Queries (fetchLatestApp)
|
||||
import Foundation (Handler)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.Types.Core (PkgId)
|
||||
import Lib.Types.Emver (Version)
|
||||
import Model (Key (..), VersionRecord (..))
|
||||
import Network.HTTP.Types (status400)
|
||||
import Startlude (Either (..), Generic, Maybe (..), Show, catMaybes, encodeUtf8, fst, pure, snd, traverse, ($), (.), (<$>))
|
||||
import Yesod (Entity (..), ToContent (..), ToTypedContent (..), YesodPersist (runDB), YesodRequest (reqGetParams), getRequest, sendResponseStatus)
|
||||
|
||||
|
||||
newtype VersionLatestRes = VersionLatestRes (HashMap PkgId (Maybe Version))
|
||||
deriving (Show, Generic)
|
||||
instance ToJSON VersionLatestRes
|
||||
instance ToContent VersionLatestRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent VersionLatestRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
|
||||
-- TODO refactor with conduit
|
||||
getVersionLatestR :: Handler VersionLatestRes
|
||||
getVersionLatestR = do
|
||||
getParameters <- reqGetParams <$> getRequest
|
||||
case lookup "ids" getParameters of
|
||||
Nothing -> sendResponseStatus status400 (InvalidParamsE "get:ids" "<MISSING>")
|
||||
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
|
||||
26
src/Handler/Package/V0/License.hs
Normal file
26
src/Handler/Package/V0/License.hs
Normal file
@@ -0,0 +1,26 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Handler.Package.V0.License where
|
||||
|
||||
import Conduit (awaitForever, (.|))
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Foundation (Handler)
|
||||
import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (getBestVersion, getLicense)
|
||||
import Lib.Types.Core (PkgId)
|
||||
import Network.HTTP.Types (status400)
|
||||
import Startlude (show, ($))
|
||||
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain)
|
||||
|
||||
|
||||
getLicenseR :: PkgId -> Handler TypedContent
|
||||
getLicenseR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <-
|
||||
getBestVersion pkg spec preferMin
|
||||
`orThrow` sendResponseStatus status400 (NotFoundE [i|License for #{pkg} satisfying #{spec}|])
|
||||
(len, src) <- getLicense pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typePlain $ src .| awaitForever sendChunkBS
|
||||
27
src/Handler/Package/V0/Manifest.hs
Normal file
27
src/Handler/Package/V0/Manifest.hs
Normal file
@@ -0,0 +1,27 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Handler.Package.V0.Manifest where
|
||||
|
||||
import Conduit (awaitForever, (.|))
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Foundation (Handler)
|
||||
import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (getBestVersion, getManifest)
|
||||
import Lib.Types.Core (PkgId)
|
||||
import Network.HTTP.Types (status404)
|
||||
import Startlude (show, ($))
|
||||
import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typeJson)
|
||||
|
||||
|
||||
getAppManifestR :: PkgId -> Handler TypedContent
|
||||
getAppManifestR pkg = do
|
||||
versionSpec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <-
|
||||
getBestVersion pkg versionSpec preferMin
|
||||
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
|
||||
addPackageHeader pkg version
|
||||
(len, src) <- getManifest pkg version
|
||||
addHeader "Content-Length" (show len)
|
||||
respondSource typeJson $ src .| awaitForever sendChunkBS
|
||||
39
src/Handler/Package/V0/ReleaseNotes.hs
Normal file
39
src/Handler/Package/V0/ReleaseNotes.hs
Normal file
@@ -0,0 +1,39 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Handler.Package.V0.ReleaseNotes where
|
||||
|
||||
import Data.Aeson (ToJSON (..))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Database.Queries (fetchAllAppVersions)
|
||||
import Foundation (Handler, RegistryCtx (..))
|
||||
import Lib.Types.Core (PkgId)
|
||||
import Lib.Types.Emver (Version)
|
||||
import Model (VersionRecord (..))
|
||||
import Startlude (Down (..), Eq, Show, Text, fst, pure, sortOn, ($), (&&&), (.), (<$>))
|
||||
import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), getYesod)
|
||||
|
||||
|
||||
newtype ReleaseNotes = ReleaseNotes {unReleaseNotes :: HashMap Version Text}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON ReleaseNotes where
|
||||
toJSON ReleaseNotes{..} = toJSON unReleaseNotes
|
||||
instance ToContent ReleaseNotes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent ReleaseNotes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
|
||||
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
|
||||
49
src/Handler/Package/V0/S9PK.hs
Normal file
49
src/Handler/Package/V0/S9PK.hs
Normal file
@@ -0,0 +1,49 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Handler.Package.V0.S9PK where
|
||||
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Data.Text qualified as T
|
||||
import Database.Queries (createMetric, fetchAppVersion)
|
||||
import Foundation (Handler)
|
||||
import GHC.Show (show)
|
||||
import Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (getBestVersion, getPackage)
|
||||
import Lib.Types.Core (PkgId (..), S9PK)
|
||||
import Lib.Types.Emver (Version (..))
|
||||
import Network.HTTP.Types (status404)
|
||||
import Startlude (Maybe (..), pure, void, ($), (.), (>>=))
|
||||
import System.FilePath (takeBaseName)
|
||||
import Yesod (Content (..), TypedContent, YesodPersist (runDB), notFound, respond, sendResponseStatus, typeOctet)
|
||||
import Yesod.Core (logError)
|
||||
|
||||
|
||||
getAppR :: S9PK -> Handler TypedContent
|
||||
getAppR file = do
|
||||
let pkg = PkgId . T.pack $ takeBaseName (show file)
|
||||
versionSpec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
version <-
|
||||
getBestVersion pkg versionSpec preferMin
|
||||
`orThrow` sendResponseStatus status404 (NotFoundE [i|#{pkg} satisfying #{versionSpec}|])
|
||||
addPackageHeader pkg version
|
||||
void $ recordMetrics pkg version
|
||||
pkgPath <-
|
||||
getPackage pkg version >>= \case
|
||||
Nothing -> sendResponseStatus status404 (NotFoundE [i|#{pkg}@#{version}|])
|
||||
Just a -> pure a
|
||||
respond typeOctet $ ContentFile pkgPath Nothing
|
||||
|
||||
|
||||
recordMetrics :: PkgId -> Version -> Handler ()
|
||||
recordMetrics pkg appVersion = do
|
||||
existingVersion <- runDB $ fetchAppVersion pkg appVersion
|
||||
case existingVersion of
|
||||
Nothing ->
|
||||
do
|
||||
$logError [i|#{pkg}@#{appVersion} not found in database|]
|
||||
notFound
|
||||
Just _ -> runDB $ createMetric pkg appVersion
|
||||
46
src/Handler/Package/V0/Version.hs
Normal file
46
src/Handler/Package/V0/Version.hs
Normal file
@@ -0,0 +1,46 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Handler.Package.V0.Version where
|
||||
|
||||
import Data.Aeson (ToJSON, object, (.=))
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Foundation (Handler)
|
||||
import Handler.Util (
|
||||
getVersionSpecFromQuery,
|
||||
orThrow,
|
||||
versionPriorityFromQueryIsMin,
|
||||
)
|
||||
import Lib.Error (S9Error (..))
|
||||
import Lib.PkgRepository (getBestVersion)
|
||||
import Lib.Types.Core (PkgId)
|
||||
import Lib.Types.Emver (Version (..))
|
||||
import Network.HTTP.Types (status404)
|
||||
import Startlude (Eq, Maybe, Show, (.), (<$>))
|
||||
import Yesod (ToContent (..), ToTypedContent, sendResponseStatus)
|
||||
import Yesod.Core (ToJSON (..), ToTypedContent (..))
|
||||
|
||||
|
||||
newtype AppVersionRes = AppVersionRes
|
||||
{ appVersionVersion :: Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON AppVersionRes where
|
||||
toJSON AppVersionRes{appVersionVersion} = object ["version" .= appVersionVersion]
|
||||
instance ToContent AppVersionRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent AppVersionRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent (Maybe AppVersionRes) where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent (Maybe AppVersionRes) where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
|
||||
getPkgVersionR :: PkgId -> Handler AppVersionRes
|
||||
getPkgVersionR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
AppVersionRes <$> getBestVersion pkg spec preferMin
|
||||
`orThrow` sendResponseStatus
|
||||
status404
|
||||
(NotFoundE [i|Version for #{pkg} satisfying #{spec}|])
|
||||
36
src/Handler/Types/Api.hs
Normal file
36
src/Handler/Types/Api.hs
Normal file
@@ -0,0 +1,36 @@
|
||||
module Handler.Types.Api where
|
||||
|
||||
import GHC.Read (Read (..))
|
||||
import GHC.Show (show)
|
||||
import Startlude (
|
||||
Eq,
|
||||
Maybe (..),
|
||||
Ord,
|
||||
Show,
|
||||
)
|
||||
import Yesod (PathPiece (..))
|
||||
|
||||
|
||||
data ApiVersion
|
||||
= V0
|
||||
| V1
|
||||
deriving (Eq, Ord)
|
||||
|
||||
|
||||
instance Show ApiVersion where
|
||||
show V0 = "v0"
|
||||
show V1 = "v1"
|
||||
|
||||
|
||||
instance Read ApiVersion where
|
||||
readsPrec _ "v0" = [(V0, "")]
|
||||
readsPrec _ "v1" = [(V1, "")]
|
||||
readsPrec _ _ = []
|
||||
|
||||
|
||||
instance PathPiece ApiVersion where
|
||||
toPathPiece V0 = "v0"
|
||||
toPathPiece V1 = "v1"
|
||||
fromPathPiece "v0" = Just V0
|
||||
fromPathPiece "v1" = Just V1
|
||||
fromPathPiece _ = Nothing
|
||||
@@ -1,163 +0,0 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Handler.Types.Marketplace where
|
||||
import Data.Aeson ( (.:)
|
||||
, FromJSON(parseJSON)
|
||||
, KeyValue((.=))
|
||||
, ToJSON(toJSON)
|
||||
, Value(String)
|
||||
, object
|
||||
, withObject
|
||||
)
|
||||
import qualified Data.HashMap.Internal.Strict as HM
|
||||
import Lib.Types.AppIndex ( PkgId )
|
||||
import Lib.Types.Emver ( Version
|
||||
, VersionRange
|
||||
)
|
||||
import Model ( Category
|
||||
, PkgDependency
|
||||
, PkgRecord
|
||||
, VersionRecord
|
||||
)
|
||||
import Startlude ( ($)
|
||||
, (.)
|
||||
, Applicative(pure)
|
||||
, Eq
|
||||
, Generic
|
||||
, Int
|
||||
, Maybe
|
||||
, Read
|
||||
, Show
|
||||
, Text
|
||||
)
|
||||
import Yesod ( Entity
|
||||
, ToContent(..)
|
||||
, ToTypedContent(..)
|
||||
)
|
||||
|
||||
|
||||
type URL = Text
|
||||
type CategoryTitle = Text
|
||||
data InfoRes = InfoRes
|
||||
{ name :: !Text
|
||||
, categories :: ![CategoryTitle]
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
instance ToJSON InfoRes
|
||||
instance ToContent InfoRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent InfoRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
data PackageRes = PackageRes
|
||||
{ packageResIcon :: !URL
|
||||
, packageResManifest :: !Data.Aeson.Value -- PackageManifest
|
||||
, packageResCategories :: ![CategoryTitle]
|
||||
, packageResInstructions :: !URL
|
||||
, packageResLicense :: !URL
|
||||
, packageResVersions :: ![Version]
|
||||
, packageResDependencies :: !(HM.HashMap PkgId DependencyRes)
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
newtype ReleaseNotes = ReleaseNotes { unReleaseNotes :: HM.HashMap Version Text }
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON ReleaseNotes where
|
||||
toJSON ReleaseNotes {..} = object [ t .= v | (k, v) <- HM.toList unReleaseNotes, let (String t) = toJSON k ]
|
||||
instance ToContent ReleaseNotes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent ReleaseNotes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToJSON PackageRes where
|
||||
toJSON PackageRes {..} = object
|
||||
[ "icon" .= packageResIcon
|
||||
, "license" .= packageResLicense
|
||||
, "instructions" .= packageResInstructions
|
||||
, "manifest" .= packageResManifest
|
||||
, "categories" .= packageResCategories
|
||||
, "versions" .= packageResVersions
|
||||
, "dependency-metadata" .= packageResDependencies
|
||||
]
|
||||
instance FromJSON PackageRes where
|
||||
parseJSON = withObject "PackageRes" $ \o -> do
|
||||
packageResIcon <- o .: "icon"
|
||||
packageResLicense <- o .: "license"
|
||||
packageResInstructions <- o .: "instructions"
|
||||
packageResManifest <- o .: "manifest"
|
||||
packageResCategories <- o .: "categories"
|
||||
packageResVersions <- o .: "versions"
|
||||
packageResDependencies <- o .: "dependency-metadata"
|
||||
pure PackageRes { .. }
|
||||
data DependencyRes = DependencyRes
|
||||
{ dependencyResTitle :: !Text
|
||||
, dependencyResIcon :: !Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON DependencyRes where
|
||||
toJSON DependencyRes {..} = object ["icon" .= dependencyResIcon, "title" .= dependencyResTitle]
|
||||
instance FromJSON DependencyRes where
|
||||
parseJSON = withObject "DependencyRes" $ \o -> do
|
||||
dependencyResIcon <- o .: "icon"
|
||||
dependencyResTitle <- o .: "title"
|
||||
pure DependencyRes { .. }
|
||||
newtype PackageListRes = PackageListRes [PackageRes]
|
||||
deriving (Generic)
|
||||
instance ToJSON PackageListRes
|
||||
instance ToContent PackageListRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent PackageListRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
newtype VersionLatestRes = VersionLatestRes (HM.HashMap PkgId (Maybe Version))
|
||||
deriving (Show, Generic)
|
||||
instance ToJSON VersionLatestRes
|
||||
instance ToContent VersionLatestRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent VersionLatestRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
data OrderArrangement = ASC | DESC
|
||||
deriving (Eq, Show, Read)
|
||||
data PackageListDefaults = PackageListDefaults
|
||||
{ packageListOrder :: !OrderArrangement
|
||||
, packageListPageLimit :: !Int -- the number of items per page
|
||||
, packageListPageNumber :: !Int -- the page you are on
|
||||
, packageListCategory :: !(Maybe CategoryTitle)
|
||||
, packageListQuery :: !Text
|
||||
}
|
||||
deriving (Eq, Show, Read)
|
||||
data EosRes = EosRes
|
||||
{ eosResVersion :: !Version
|
||||
, eosResHeadline :: !Text
|
||||
, eosResReleaseNotes :: !ReleaseNotes
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
instance ToJSON EosRes where
|
||||
toJSON EosRes {..} =
|
||||
object ["version" .= eosResVersion, "headline" .= eosResHeadline, "release-notes" .= eosResReleaseNotes]
|
||||
instance ToContent EosRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent EosRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
|
||||
data PackageReq = PackageReq
|
||||
{ packageReqId :: !PkgId
|
||||
, packageReqVersion :: !VersionRange
|
||||
}
|
||||
deriving Show
|
||||
instance FromJSON PackageReq where
|
||||
parseJSON = withObject "package version" $ \o -> do
|
||||
packageReqId <- o .: "id"
|
||||
packageReqVersion <- o .: "version"
|
||||
pure PackageReq { .. }
|
||||
data PackageMetadata = PackageMetadata
|
||||
{ packageMetadataPkgId :: !PkgId
|
||||
, packageMetadataPkgVersionRecords :: ![Entity VersionRecord]
|
||||
, packageMetadataPkgCategories :: ![Entity Category]
|
||||
, packageMetadataPkgVersion :: !Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
data PackageDependencyMetadata = PackageDependencyMetadata
|
||||
{ packageDependencyMetadataPkgDependencyRecord :: !(Entity PkgDependency)
|
||||
, packageDependencyMetadataDepPkgRecord :: !(Entity PkgRecord)
|
||||
, packageDependencyMetadataDepVersions :: ![Entity VersionRecord]
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -1,37 +0,0 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
{-# HLINT ignore "Use newtype instead of data" #-}
|
||||
module Handler.Types.Status where
|
||||
|
||||
import Startlude ( (.)
|
||||
, Eq
|
||||
, Maybe
|
||||
, Show
|
||||
)
|
||||
|
||||
import Data.Aeson ( KeyValue((.=))
|
||||
, ToJSON(toJSON)
|
||||
, object
|
||||
)
|
||||
import Yesod.Core.Content ( ToContent(..)
|
||||
, ToTypedContent(..)
|
||||
)
|
||||
|
||||
import Lib.Types.Emver ( Version )
|
||||
import Orphans.Emver ( )
|
||||
|
||||
newtype AppVersionRes = AppVersionRes
|
||||
{ appVersionVersion :: Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
instance ToJSON AppVersionRes where
|
||||
toJSON AppVersionRes { appVersionVersion } = object ["version" .= appVersionVersion]
|
||||
instance ToContent AppVersionRes where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent AppVersionRes where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
instance ToContent (Maybe AppVersionRes) where
|
||||
toContent = toContent . toJSON
|
||||
instance ToTypedContent (Maybe AppVersionRes) where
|
||||
toTypedContent = toTypedContent . toJSON
|
||||
103
src/Handler/Util.hs
Normal file
103
src/Handler/Util.hs
Normal file
@@ -0,0 +1,103 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Handler.Util where
|
||||
|
||||
import Control.Monad.Reader.Has (
|
||||
Has,
|
||||
MonadReader,
|
||||
)
|
||||
import Data.Attoparsec.Text (Parser, parseOnly)
|
||||
import Data.String.Interpolate.IsString (i)
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Lazy qualified as TL
|
||||
import Data.Text.Lazy.Builder qualified as TB
|
||||
import Lib.PkgRepository (PkgRepo, getHash)
|
||||
import Lib.Types.Core (PkgId)
|
||||
import Lib.Types.Emver (
|
||||
Version,
|
||||
VersionRange,
|
||||
)
|
||||
import Network.HTTP.Types (
|
||||
Status,
|
||||
status400,
|
||||
)
|
||||
import Startlude (
|
||||
Bool (..),
|
||||
Either (..),
|
||||
Foldable (foldMap),
|
||||
Maybe (..),
|
||||
Monoid (..),
|
||||
Semigroup ((<>)),
|
||||
Text,
|
||||
decodeUtf8,
|
||||
fromMaybe,
|
||||
fst,
|
||||
isSpace,
|
||||
not,
|
||||
pure,
|
||||
readMaybe,
|
||||
($),
|
||||
(.),
|
||||
(<$>),
|
||||
(>>=),
|
||||
)
|
||||
import UnliftIO (MonadUnliftIO)
|
||||
import Yesod (
|
||||
MonadHandler,
|
||||
RenderRoute (..),
|
||||
TypedContent (..),
|
||||
lookupGetParam,
|
||||
sendResponseStatus,
|
||||
toContent,
|
||||
typePlain,
|
||||
)
|
||||
import Yesod.Core (addHeader)
|
||||
|
||||
|
||||
orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
|
||||
orThrow action other =
|
||||
action >>= \case
|
||||
Nothing -> other
|
||||
Just x -> pure x
|
||||
|
||||
|
||||
sendResponseText :: MonadHandler m => Status -> Text -> m a
|
||||
sendResponseText s = sendResponseStatus s . TypedContent typePlain . toContent
|
||||
|
||||
|
||||
getVersionSpecFromQuery :: MonadHandler m => m VersionRange
|
||||
getVersionSpecFromQuery = do
|
||||
specString <- T.filter (not . isSpace) . fromMaybe "*" <$> lookupGetParam "spec"
|
||||
case readMaybe specString of
|
||||
Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text)
|
||||
Just t -> pure t
|
||||
|
||||
|
||||
versionPriorityFromQueryIsMin :: MonadHandler m => m Bool
|
||||
versionPriorityFromQueryIsMin = do
|
||||
priorityString <- lookupGetParam "version-priority"
|
||||
case priorityString of
|
||||
Nothing -> pure False
|
||||
(Just "max") -> pure False
|
||||
(Just "min") -> pure True
|
||||
(Just t) -> sendResponseStatus status400 ("Invalid Version Priority Specification: " <> t)
|
||||
|
||||
|
||||
addPackageHeader :: (MonadUnliftIO m, MonadHandler m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ()
|
||||
addPackageHeader pkg version = do
|
||||
packageHash <- getHash pkg version
|
||||
addHeader "X-S9PK-HASH" $ decodeUtf8 packageHash
|
||||
|
||||
|
||||
basicRender :: RenderRoute a => Route a -> Text
|
||||
basicRender = TL.toStrict . TB.toLazyText . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute
|
||||
|
||||
|
||||
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 ->
|
||||
sendResponseText status400 [i|Invalid Request! The query parameter '#{k}' failed to parse: #{e}|]
|
||||
Right a -> pure (Just a)
|
||||
@@ -1,32 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Handler.Version where
|
||||
|
||||
import Startlude ( (<$>) )
|
||||
|
||||
import Yesod.Core ( sendResponseStatus )
|
||||
|
||||
import Data.String.Interpolate.IsString
|
||||
( i )
|
||||
import Foundation ( Handler )
|
||||
import Handler.Types.Status ( AppVersionRes(AppVersionRes) )
|
||||
import Lib.Error ( S9Error(NotFoundE) )
|
||||
import Lib.PkgRepository ( getBestVersion )
|
||||
import Lib.Types.AppIndex ( PkgId )
|
||||
import Network.HTTP.Types.Status ( status404 )
|
||||
import Util.Shared ( getVersionSpecFromQuery
|
||||
, orThrow
|
||||
, versionPriorityFromQueryIsMin
|
||||
)
|
||||
|
||||
getPkgVersionR :: PkgId -> Handler AppVersionRes
|
||||
getPkgVersionR pkg = do
|
||||
spec <- getVersionSpecFromQuery
|
||||
preferMin <- versionPriorityFromQueryIsMin
|
||||
AppVersionRes <$> getBestVersion pkg spec preferMin `orThrow` sendResponseStatus
|
||||
status404
|
||||
(NotFoundE [i|Version for #{pkg} satisfying #{spec}|])
|
||||
Reference in New Issue
Block a user