Feature/api versioning (#106)

* wip

* finishes initial refactor

* prune unused code

* finished massive refactor

* remove commented deps

* fix import

* fix bug

.gitignore

@@ -36,3 +36,5 @@ start9-registry.hp
 start9-registry.pdf
 start9-registry.aux
 start9-registry.ps
+shell.nix
+testdata/

Makefile

@@ -1,2 +1,4 @@
 all:
 	stack build --local-bin-path dist --copy-bins
+profile:
+	stack build --local-bin-path dist --copy-bins --profile

config/routes

@@ -3,19 +3,16 @@
 /eos/v0/eos.img                            EosR               GET -- get eos.img
 
 -- PACKAGE API V0
-/package/v0/info                           InfoR              GET -- get all marketplace categories
+/package/#ApiVersion/info                           InfoR              GET -- get all marketplace categories
-/package/v0/index                          PackageListR       GET -- filter marketplace services by various query params
+/package/#ApiVersion/index                          PackageIndexR      GET -- filter marketplace services by various query params
-/package/v0/latest                         VersionLatestR     GET -- get latest version of apps in query param id
+/package/#ApiVersion/latest                         VersionLatestR     GET -- get latest version of apps in query param id
-!/package/v0/#S9PK                         AppR               GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec=<emver>
+!/package/#ApiVersion/#S9PK                         AppR               GET -- get most recent appId at appversion spec, defaults to >=0.0.0 -- ?spec=<emver>
-/package/v0/manifest/#PkgId                AppManifestR       GET -- get app manifest from appmgr -- ?spec=<emver>
+/package/#ApiVersion/manifest/#PkgId                AppManifestR       GET -- get app manifest from appmgr -- ?spec=<emver>
-/package/v0/release-notes/#PkgId           ReleaseNotesR      GET -- get release notes for all versions of a package
+/package/#ApiVersion/release-notes/#PkgId           ReleaseNotesR      GET -- get release notes for all versions of a package
-/package/v0/icon/#PkgId                    IconsR             GET -- get icons - can specify version with ?spec=<emver>
+/package/#ApiVersion/icon/#PkgId                    IconsR             GET -- get icons - can specify version with ?spec=<emver>
-/package/v0/license/#PkgId                 LicenseR           GET -- get license - can specify version with ?spec=<emver>
+/package/#ApiVersion/license/#PkgId                 LicenseR           GET -- get license - can specify version with ?spec=<emver>
-/package/v0/instructions/#PkgId            InstructionsR      GET -- get instructions - can specify version with ?spec=<emver>
+/package/#ApiVersion/instructions/#PkgId            InstructionsR      GET -- get instructions - can specify version with ?spec=<emver>
-/package/v0/version/#PkgId                 PkgVersionR        GET -- get most recent appId version
+/package/#ApiVersion/version/#PkgId                 PkgVersionR        GET -- get most recent appId version
-
--- SUPPORT API V0
-/support/v0/error-logs                     ErrorLogsR         POST
 
 -- ADMIN API V0
 /admin/v0/upload                           PkgUploadR         POST !admin

fourmolu.yaml

@@ -0,0 +1,8 @@
+indentation: 4
+comma-style: leading
+record-brace-space: false
+indent-wheres: true
+diff-friendly-import-export: true
+respectful: true
+haddock-style: single-line
+newlines-between-decls: 2

package.yaml

@@ -2,15 +2,10 @@ name: start9-registry
 version: 0.2.1
 
 default-extensions:
-  - FlexibleInstances
-  - GeneralizedNewtypeDeriving
-  - LambdaCase
-  - MultiWayIf
-  - NamedFieldPuns
   - NoImplicitPrelude
-  - NumericUnderscores
+  - GHC2021
+  - LambdaCase
   - OverloadedStrings
-  - StandaloneDeriving
 
 dependencies:
   - base >=4.12 && <5

src/Application.hs

@@ -9,207 +9,219 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-module Application
+
-    ( appMain
+module Application (
-    , develMain
+    appMain,
-    , makeFoundation
+    develMain,
-    , makeLogWare
+    makeFoundation,
-    , shutdownApp
+    makeLogWare,
-    , shutdownAll
+    shutdownApp,
-    , shutdownWeb
+    shutdownAll,
-    , startApp
+    shutdownWeb,
-    , startWeb
+    startApp,
+    startWeb,
+
     -- * for DevelMain
-    , getApplicationRepl
+    getApplicationRepl,
-    , getAppSettings
+    getAppSettings,
+
     -- * for GHCI
-    , handler
+    handler,
-    , db
+    db,
-    ) where
+) where
 
-import           Startlude                      ( ($)
+import Startlude (
-                                                , (++)
+    Applicative (pure),
-                                                , (.)
+    Async (asyncThreadId),
-                                                , (<$>)
+    Bool (False, True),
-                                                , (<||>)
+    Either (Left, Right),
-                                                , Applicative(pure)
+    Eq ((==)),
-                                                , Async(asyncThreadId)
+    ExitCode (ExitSuccess),
-                                                , Bool(False, True)
+    IO,
-                                                , Either(Left, Right)
+    Int,
-                                                , Eq((==))
+    Maybe (Just),
-                                                , ExitCode(ExitSuccess)
+    Monad (return, (>>=)),
-                                                , IO
+    MonadIO (..),
-                                                , Int
+    Print (putStr, putStrLn),
-                                                , Maybe(Just)
+    ReaderT (runReaderT),
-                                                , Monad((>>=), return)
+    Text,
-                                                , MonadIO(..)
+    ThreadId,
-                                                , Print(putStr, putStrLn)
+    async,
-                                                , ReaderT(runReaderT)
+    flip,
-                                                , Text
+    for_,
-                                                , ThreadId
+    forever,
-                                                , async
+    forkIO,
-                                                , flip
+    fromIntegral,
-                                                , for_
+    killThread,
-                                                , forever
+    newEmptyMVar,
-                                                , forkIO
+    newMVar,
-                                                , fromIntegral
+    onException,
-                                                , killThread
+    panic,
-                                                , newEmptyMVar
+    print,
-                                                , newMVar
+    putMVar,
-                                                , onException
+    show,
-                                                , panic
+    stdout,
-                                                , print
+    swapMVar,
-                                                , putMVar
+    takeMVar,
-                                                , show
+    void,
-                                                , stdout
+    waitEitherCatchCancel,
-                                                , swapMVar
+    when,
-                                                , takeMVar
+    ($),
-                                                , void
+    (++),
-                                                , waitEitherCatchCancel
+    (.),
-                                                , when
+    (<$>),
+    (<||>),
  )
 
-import           Control.Monad.Logger           ( LoggingT
+import Control.Monad.Logger (
-                                                , liftLoc
+    LoggingT,
-                                                , runLoggingT
+    liftLoc,
+    runLoggingT,
  )
-import           Data.Default                   ( Default(def) )
+import Data.Default (Default (def))
-import           Database.Persist.Postgresql    ( createPostgresqlPool
+import Database.Persist.Postgresql (
-                                                , pgConnStr
+    createPostgresqlPool,
-                                                , pgPoolSize
+    pgConnStr,
-                                                , runMigration
+    pgPoolSize,
-                                                , runSqlPool
+    runMigration,
+    runSqlPool,
  )
-import           Language.Haskell.TH.Syntax     ( qLocation )
+import Language.Haskell.TH.Syntax (qLocation)
-import           Network.Wai                    ( Application
+import Network.Wai (
-                                                , Middleware
+    Application,
-                                                , Request(requestHeaders)
+    Middleware,
-                                                , ResponseReceived
+    Request (requestHeaders),
+    ResponseReceived,
  )
-import           Network.Wai.Handler.Warp       ( Settings
+import Network.Wai.Handler.Warp (
-                                                , defaultSettings
+    Settings,
-                                                , defaultShouldDisplayException
+    defaultSettings,
-                                                , getPort
+    defaultShouldDisplayException,
-                                                , runSettings
+    getPort,
-                                                , setHTTP2Disabled
+    runSettings,
-                                                , setHost
+    setHTTP2Disabled,
-                                                , setOnException
+    setHost,
-                                                , setPort
+    setOnException,
-                                                , setTimeout
+    setPort,
+    setTimeout,
  )
-import           Network.Wai.Handler.WarpTLS    ( runTLS
+import Network.Wai.Handler.WarpTLS (
-                                                , tlsSettings
+    runTLS,
+    tlsSettings,
  )
-import           Network.Wai.Middleware.AcceptOverride
+import Network.Wai.Middleware.AcceptOverride (
-                                                ( acceptOverride )
+    acceptOverride,
-import           Network.Wai.Middleware.Autohead
-                                                ( autohead )
-import           Network.Wai.Middleware.Cors    ( CorsResourcePolicy(..)
-                                                , cors
-                                                , simpleCorsResourcePolicy
  )
-import           Network.Wai.Middleware.MethodOverride
+import Network.Wai.Middleware.Autohead (
-                                                ( methodOverride )
+    autohead,
-import           Network.Wai.Middleware.RequestLogger
-                                                ( Destination(Logger)
-                                                , OutputFormat(..)
-                                                , destination
-                                                , mkRequestLogger
-                                                , outputFormat
  )
-import           System.IO                      ( BufferMode(..)
+import Network.Wai.Middleware.Cors (
-                                                , hSetBuffering
+    CorsResourcePolicy (..),
+    cors,
+    simpleCorsResourcePolicy,
  )
-import           System.Log.FastLogger          ( defaultBufSize
+import Network.Wai.Middleware.MethodOverride (
-                                                , newStdoutLoggerSet
+    methodOverride,
-                                                , toLogStr
  )
-import           Yesod.Core                     ( HandlerFor
+import Network.Wai.Middleware.RequestLogger (
-                                                , LogLevel(LevelError)
+    Destination (Logger),
-                                                , Yesod(messageLoggerSource)
+    OutputFormat (..),
-                                                , logInfo
+    destination,
-                                                , mkYesodDispatch
+    mkRequestLogger,
-                                                , toWaiAppPlain
+    outputFormat,
-                                                , typeOctet
  )
-import           Yesod.Core.Types               ( Logger(loggerSet) )
+import System.IO (
-import           Yesod.Default.Config2          ( configSettingsYml
+    BufferMode (..),
-                                                , develMainHelper
+    hSetBuffering,
-                                                , getDevSettings
+ )
-                                                , loadYamlSettings
+import System.Log.FastLogger (
-                                                , loadYamlSettingsArgs
+    defaultBufSize,
-                                                , makeYesodLogger
+    newStdoutLoggerSet,
-                                                , useEnv
+    toLogStr,
+ )
+import Yesod.Core (
+    HandlerFor,
+    LogLevel (LevelError),
+    Yesod (messageLoggerSource),
+    logInfo,
+    mkYesodDispatch,
+    toWaiAppPlain,
+    typeOctet,
+ )
+import Yesod.Core.Types (Logger (loggerSet))
+import Yesod.Default.Config2 (
+    configSettingsYml,
+    develMainHelper,
+    getDevSettings,
+    loadYamlSettings,
+    loadYamlSettingsArgs,
+    makeYesodLogger,
+    useEnv,
  )
 
-import           Control.Lens                   ( both )
+import Control.Lens (both)
-import           Data.List                      ( lookup )
+import Data.List (lookup)
-import           Data.String.Interpolate.IsString
+import Data.String.Interpolate.IsString (
-                                                ( i )
+    i,
-import qualified Database.Persist.Migration
-import qualified Database.Persist.Migration.Postgres
-import           Database.Persist.Sql           ( SqlBackend )
-import           Foundation                     ( Handler
-                                                , RegistryCtx(..)
-                                                , Route(..)
-                                                , resourcesRegistryCtx
-                                                , setWebProcessThreadId
-                                                , unsafeHandler
  )
-import           Handler.Admin                  ( deleteCategoryR
+import Database.Persist.Migration qualified
-                                                , deletePkgCategorizeR
+import Database.Persist.Migration.Postgres qualified
-                                                , getPkgDeindexR
+import Database.Persist.Sql (SqlBackend)
-                                                , postCategoryR
+import Foundation (
-                                                , postPkgCategorizeR
+    Handler,
-                                                , postPkgDeindexR
+    RegistryCtx (..),
-                                                , postPkgIndexR
+    Route (..),
-                                                , postPkgUploadR
+    resourcesRegistryCtx,
+    setWebProcessThreadId,
+    unsafeHandler,
  )
-import           Handler.Apps                   ( getAppManifestR
+import Handler.Admin (
-                                                , getAppR
+    deleteCategoryR,
+    deletePkgCategorizeR,
+    getPkgDeindexR,
+    postCategoryR,
+    postPkgCategorizeR,
+    postPkgDeindexR,
+    postPkgIndexR,
+    postPkgUploadR,
  )
-import           Handler.ErrorLogs              ( postErrorLogsR )
+import Handler.Eos (getEosR, getEosVersionR)
-import           Handler.Icons                  ( getIconsR
+import Handler.Package
-                                                , getInstructionsR
+import Lib.PkgRepository (watchEosRepoRoot)
-                                                , getLicenseR
+import Lib.Ssl (
+    doesSslNeedRenew,
+    renewSslCerts,
+    setupSsl,
  )
-import           Handler.Marketplace            ( getEosR
+import Migration (manualMigration)
-                                                , getEosVersionR
+import Model (migrateAll)
-                                                , getInfoR
+import Network.HTTP.Types.Header (hOrigin)
-                                                , getPackageListR
+import Network.Wai.Middleware.Gzip (
-                                                , getReleaseNotesR
+    GzipFiles (GzipCompress),
-                                                , getVersionLatestR
+    GzipSettings (gzipCheckMime, gzipFiles),
+    defaultCheckMime,
+    gzip,
  )
-import           Handler.Version                ( getPkgVersionR )
+import Network.Wai.Middleware.RequestLogger.JSON (
-import           Lib.PkgRepository              ( watchEosRepoRoot )
+    formatAsJSONWithHeaders,
-import           Lib.Ssl                        ( doesSslNeedRenew
-                                                , renewSslCerts
-                                                , setupSsl
  )
-import           Migration                      ( manualMigration )
+import Settings (
-import           Model                          ( migrateAll )
+    AppPort,
-import           Network.HTTP.Types.Header      ( hOrigin )
+    AppSettings (..),
-import           Network.Wai.Middleware.Gzip    ( GzipFiles(GzipCompress)
+    configSettingsYmlValue,
-                                                , GzipSettings(gzipCheckMime, gzipFiles)
-                                                , defaultCheckMime
-                                                , gzip
  )
-import           Network.Wai.Middleware.RequestLogger.JSON
+import System.Directory (createDirectoryIfMissing)
-                                                ( formatAsJSONWithHeaders )
+import System.Posix.Process (exitImmediately)
-import           Settings                       ( AppPort
+import System.Time.Extra (sleep)
-                                                , AppSettings(..)
+import Yesod (YesodPersist (runDB))
-                                                , configSettingsYmlValue
+
-                                                )
-import           System.Directory               ( createDirectoryIfMissing )
-import           System.Posix.Process           ( exitImmediately )
-import           System.Time.Extra              ( sleep )
-import           Yesod                          ( YesodPersist(runDB) )
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
 -- comments there for more details.
 mkYesodDispatch "RegistryCtx" resourcesRegistryCtx
 
+
 -- | This function allocates resources (such as a database connection pool),
 -- performs initialization and returns a foundation datatype value. This is also
 -- the place to put your migrate statements to have automatic database
@@ -228,10 +240,10 @@ makeFoundation appSettings = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appStopFsNotifyEos = RegistryCtx { .. }
+    let mkFoundation appConnPool appStopFsNotifyEos = RegistryCtx{..}
--- The RegistryCtx {..} syntax is an example of record wild cards. For more
+        -- The RegistryCtx {..} syntax is an example of record wild cards. For more
--- information, see:
+        -- information, see:
--- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
+        -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
         tempFoundation =
             mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation")
         logFunc = messageLoggerSource tempFoundation appLogger
@@ -239,8 +251,9 @@ makeFoundation appSettings = do
     createDirectoryIfMissing True (errorLogRoot appSettings)
 
     -- Create the database connection pool
-    pool <- flip runLoggingT logFunc
+    pool <-
-        $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings)
+        flip runLoggingT logFunc $
+            createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings)
 
     stopEosWatch <- runLoggingT (runReaderT (watchEosRepoRoot pool) appSettings) logFunc
 
@@ -253,6 +266,7 @@ makeFoundation appSettings = do
     -- Return the foundation
     return $ mkFoundation pool stopEosWatch
 
+
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.
 makeApplication :: RegistryCtx -> IO Application
@@ -265,7 +279,7 @@ makeApplication foundation = do
             -- TODO: change this to the cached version when we have better release processes
             -- since caches aren't invalidated, publishing a new package/eos won't take effect
             -- because the cached file will be downloaded.
-            def { gzipFiles = GzipCompress, gzipCheckMime = defaultCheckMime <||> (== typeOctet) }
+            def{gzipFiles = GzipCompress, gzipCheckMime = defaultCheckMime <||> (== typeOctet)}
     pure
         . logWare
         . cors dynamicCorsResourcePolicy
@@ -276,13 +290,16 @@ makeApplication foundation = do
         . gzip gzipSettings
         $ appPlain
 
+
 dynamicCorsResourcePolicy :: Request -> Maybe CorsResourcePolicy
 dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders req
     where
-        policy o = simpleCorsResourcePolicy
+        policy o =
+            simpleCorsResourcePolicy
                 { corsOrigins = (\o' -> ([o'], True)) <$> o
                 , corsMethods = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"]
-            , corsRequestHeaders = [ "app-version"
+                , corsRequestHeaders =
+                    [ "app-version"
                     , "Accept"
                     , "Accept-Charset"
                     , "Accept-Encoding"
@@ -341,54 +358,66 @@ dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders
                 , corsIgnoreFailures = True
                 }
 
+
 makeLogWare :: RegistryCtx -> IO Middleware
-makeLogWare foundation = mkRequestLogger def
+makeLogWare foundation =
-    { outputFormat = if appDetailedRequestLogging $ appSettings foundation
+    mkRequestLogger
+        def
+            { outputFormat =
+                if appDetailedRequestLogging $ appSettings foundation
                     then Detailed True
                     else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders
             , destination = Logger $ loggerSet $ appLogger foundation
             }
 
+
 makeAuthWare :: RegistryCtx -> Middleware
 makeAuthWare _ app req res = next
     where
         next :: IO ResponseReceived
         next = app req res
 
+
 -- | Warp settings for the given foundation value.
 warpSettings :: AppPort -> RegistryCtx -> Settings
 warpSettings port foundation =
-    setTimeout 60
+    setTimeout 60 $
-    $ setPort (fromIntegral port)
+        setPort (fromIntegral port) $
-    $ setHost (appHost $ appSettings foundation)
+            setHost (appHost $ appSettings foundation) $
-    $ setOnException (\_req e ->
+                setOnException
-        when (defaultShouldDisplayException e) $ messageLoggerSource
+                    ( \_req e ->
+                        when (defaultShouldDisplayException e) $
+                            messageLoggerSource
                                 foundation
                                 (appLogger foundation)
                                 $(qLocation >>= liftLoc)
                                 "yesod"
                                 LevelError
-            (toLogStr $ "Exception from Warp: " ++ show e))
+                                (toLogStr $ "Exception from Warp: " ++ show e)
+                    )
                     (setHTTP2Disabled defaultSettings)
 
+
 getAppSettings :: IO AppSettings
 getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
 
+
 -- | The @main@ function for an executable running this site.
 appMain :: IO ()
 appMain = do
     hSetBuffering stdout LineBuffering
     -- Get the settings from all relevant sources
-    settings <- loadYamlSettingsArgs
+    settings <-
+        loadYamlSettingsArgs
             -- fall back to compile-time values, set to [] to require values at runtime
             [configSettingsYmlValue]
-
             -- allow environment variables to override
             useEnv
 
     -- Generate the foundation from the settings
     makeFoundation settings >>= startApp
 
+
 startApp :: RegistryCtx -> IO ()
 startApp foundation = do
     when (sslAuto . appSettings $ foundation) $ do
@@ -398,7 +427,9 @@ startApp foundation = do
         runLog $ $logInfo "SSL Setup Complete"
 
         -- certbot renew loop
-        void . forkIO $ forever $ flip runReaderT foundation $ do
+        void . forkIO $
+            forever $
+                flip runReaderT foundation $ do
                     shouldRenew <- doesSslNeedRenew
                     runLog $ $logInfo [i|Checking if SSL Certs should be renewed: #{shouldRenew}|]
                     when shouldRenew $ do
@@ -412,17 +443,20 @@ startApp foundation = do
         runLog :: MonadIO m => LoggingT m a -> m a
         runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation))
 
+
 startWeb :: RegistryCtx -> IO ()
 startWeb foundation = do
     app <- makeApplication foundation
     startWeb' app
     where
         startWeb' app = (`onException` appStopFsNotifyEos foundation) $ do
-            let AppSettings {..} = appSettings foundation
+            let AppSettings{..} = appSettings foundation
             runLog $ $logInfo [i|Launching Tor Web Server on port #{torPort}|]
             torAction <- async $ runSettings (warpSettings torPort foundation) app
             runLog $ $logInfo [i|Launching Web Server on port #{appPort}|]
-            action <- async $ if sslAuto
+            action <-
+                async $
+                    if sslAuto
                         then runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app
                         else runSettings (warpSettings appPort foundation) app
 
@@ -450,22 +484,26 @@ startWeb foundation = do
                 startWeb' app
         runLog a = runLoggingT a (messageLoggerSource foundation (appLogger foundation))
 
+
 restartWeb :: RegistryCtx -> IO ()
 restartWeb foundation = do
     void $ swapMVar (appShouldRestartWeb foundation) True
     shutdownWeb foundation
 
+
 shutdownAll :: [ThreadId] -> IO ()
 shutdownAll threadIds = do
     for_ threadIds killThread
     exitImmediately ExitSuccess
 
+
 -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process
 shutdownWeb :: RegistryCtx -> IO ()
-shutdownWeb RegistryCtx {..} = do
+shutdownWeb RegistryCtx{..} = do
     threadIds <- takeMVar appWebServerThreadId
     void $ both killThread threadIds
 
+
 --------------------------------------------------------------
 -- Functions for DevelMain.hs (a way to run the RegistryCtx from GHCi)
 --------------------------------------------------------------
@@ -478,9 +516,11 @@ getApplicationRepl = do
     app1 <- makeApplication foundation
     return (getPort wsettings, foundation, app1)
 
+
 shutdownApp :: RegistryCtx -> IO ()
 shutdownApp _ = return ()
 
+
 -- | For yesod devel, return the Warp settings and WAI Application.
 getApplicationDev :: AppPort -> IO (Settings, Application)
 getApplicationDev port = do
@@ -490,12 +530,14 @@ getApplicationDev port = do
     wsettings <- getDevSettings $ warpSettings port foundation
     return (wsettings, app)
 
+
 -- | main function for use by yesod devel
 develMain :: IO ()
 develMain = do
     settings <- getAppSettings
     develMainHelper $ getApplicationDev $ appPort settings
 
+
 ---------------------------------------------
 -- Functions for use in development with GHCi
 ---------------------------------------------
@@ -504,6 +546,7 @@ develMain = do
 handler :: Handler a -> IO a
 handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
 
+
 -- | Run DB queries
 db :: ReaderT SqlBackend (HandlerFor RegistryCtx) a -> IO a
 db = handler . runDB

src/Cli/Cli.hs

@@ -8,199 +8,217 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Cli.Cli
+module Cli.Cli (
-    ( cliMain
+    cliMain,
-    ) where
+) where
 
-import           Conduit                        ( (.|)
+import Conduit (
-                                                , foldC
+    foldC,
-                                                , runConduit
+    runConduit,
+    (.|),
  )
-import           Control.Monad.Logger           ( LogLevel(..)
+import Control.Monad.Logger (
-                                                , MonadLogger(monadLoggerLog)
+    LogLevel (..),
-                                                , MonadLoggerIO(askLoggerIO)
+    MonadLogger (monadLoggerLog),
-                                                , ToLogStr
+    MonadLoggerIO (askLoggerIO),
-                                                , fromLogStr
+    ToLogStr,
-                                                , toLogStr
+    fromLogStr,
+    toLogStr,
  )
-import           Crypto.Hash                    ( SHA256(SHA256)
+import Crypto.Hash (
-                                                , hashWith
+    SHA256 (SHA256),
+    hashWith,
  )
-import           Data.Aeson                     ( ToJSON
+import Data.Aeson (
-                                                , eitherDecodeStrict
+    ToJSON,
+    eitherDecodeStrict,
  )
-import           Data.ByteArray.Encoding        ( Base(..)
+import Data.ByteArray.Encoding (
-                                                , convertToBase
+    Base (..),
+    convertToBase,
  )
-import qualified Data.ByteString.Char8         as B8
+import Data.ByteString.Char8 qualified as B8
-import qualified Data.ByteString.Lazy          as LB
+import Data.ByteString.Lazy qualified as LB
-import           Data.Conduit.Process           ( readProcess )
+import Data.Conduit.Process (readProcess)
 import Data.Default
-import           Data.Functor.Contravariant     ( contramap )
+import Data.Functor.Contravariant (contramap)
-import           Data.HashMap.Internal.Strict   ( HashMap
+import Data.HashMap.Internal.Strict (
-                                                , delete
+    HashMap,
-                                                , empty
+    delete,
-                                                , insert
+    empty,
-                                                , lookup
+    insert,
-                                                , traverseWithKey
+    lookup,
+    traverseWithKey,
  )
-import           Data.String.Interpolate.IsString
+import Data.String.Interpolate.IsString (
-                                                ( i )
+    i,
-import           Data.Text                      ( toLower )
-import           Dhall                          ( Encoder(embed)
-                                                , FromDhall(..)
-                                                , Generic
-                                                , ToDhall(..)
-                                                , auto
-                                                , inject
-                                                , inputFile
  )
-import           Dhall.Core                     ( pretty )
+import Data.Text (toLower)
-import           Handler.Admin                  ( AddCategoryReq(AddCategoryReq)
+import Dhall (
-                                                , IndexPkgReq(IndexPkgReq)
+    Encoder (embed),
-                                                , PackageList(..)
+    FromDhall (..),
+    Generic,
+    ToDhall (..),
+    auto,
+    inject,
+    inputFile,
  )
-import           Lib.External.AppMgr            ( sourceManifest )
+import Dhall.Core (pretty)
-import           Lib.Types.AppIndex             ( PackageManifest
+import Handler.Admin (
-                                                    ( PackageManifest
+    AddCategoryReq (AddCategoryReq),
-                                                    , packageManifestId
+    IndexPkgReq (IndexPkgReq),
-                                                    , packageManifestVersion
+    PackageList (..),
  )
-                                                , PkgId(..)
+import Lib.External.AppMgr (sourceManifest)
+import Lib.Types.Core (
+    PkgId (..),
  )
-import           Lib.Types.Emver                ( Version(..) )
+import Lib.Types.Emver (Version (..))
-import           Network.HTTP.Client.Conduit    ( StreamFileStatus(StreamFileStatus, fileSize, readSoFar)
+import Lib.Types.Manifest (PackageManifest (..))
-                                                , applyBasicAuth
+import Network.HTTP.Client.Conduit (
-                                                , httpLbs
+    StreamFileStatus (StreamFileStatus, fileSize, readSoFar),
-                                                , observedStreamFile
+    applyBasicAuth,
+    httpLbs,
+    observedStreamFile,
  )
-import           Network.HTTP.Client.TLS        ( newTlsManager )
+import Network.HTTP.Client.TLS (newTlsManager)
-import           Network.HTTP.Simple            ( getResponseBody
+import Network.HTTP.Simple (
-                                                , getResponseStatus
+    getResponseBody,
-                                                , httpJSON
+    getResponseStatus,
-                                                , httpLBS
+    httpJSON,
-                                                , parseRequest
+    httpLBS,
-                                                , setRequestBody
+    parseRequest,
-                                                , setRequestBodyJSON
+    setRequestBody,
-                                                , setRequestHeaders
+    setRequestBodyJSON,
+    setRequestHeaders,
  )
-import           Network.HTTP.Types             ( status200 )
+import Network.HTTP.Types (status200)
-import           Network.URI                    ( URI
+import Network.URI (
-                                                , parseURI
+    URI,
+    parseURI,
  )
-import           Options.Applicative            ( (<$>)
+import Options.Applicative (
-                                                , (<**>)
+    Alternative ((<|>)),
-                                                , Alternative((<|>))
+    Applicative (liftA2, pure, (<*>)),
-                                                , Applicative((<*>), liftA2, pure)
+    Parser,
-                                                , Parser
+    ParserInfo,
-                                                , ParserInfo
+    auto,
-                                                , auto
+    command,
-                                                , command
+    execParser,
-                                                , execParser
+    fullDesc,
-                                                , fullDesc
+    help,
-                                                , help
+    helper,
-                                                , helper
+    info,
-                                                , info
+    liftA3,
-                                                , liftA3
+    long,
-                                                , long
+    mappend,
-                                                , mappend
+    metavar,
-                                                , metavar
+    option,
-                                                , option
+    optional,
-                                                , optional
+    progDesc,
-                                                , progDesc
+    short,
-                                                , short
+    strArgument,
-                                                , strArgument
+    strOption,
-                                                , strOption
+    subparser,
-                                                , subparser
+    switch,
-                                                , switch
+    (<$>),
+    (<**>),
  )
-import           Rainbow                        ( Chunk
+import Rainbow (
-                                                , Radiant
+    Chunk,
-                                                , blue
+    Radiant,
-                                                , chunk
+    blue,
-                                                , fore
+    chunk,
-                                                , green
+    fore,
-                                                , magenta
+    green,
-                                                , putChunk
+    magenta,
-                                                , putChunkLn
+    putChunk,
-                                                , red
+    putChunkLn,
-                                                , white
+    red,
-                                                , yellow
+    white,
+    yellow,
  )
-import           Startlude                      ( ($)
+import Startlude (
-                                                , ($>)
+    Bool (..),
-                                                , (&)
+    ConvertText (toS),
-                                                , (.)
+    Either (..),
-                                                , (<&>)
+    Eq (..),
-                                                , Bool(..)
+    ExitCode (..),
-                                                , ConvertText(toS)
+    FilePath,
-                                                , Either(..)
+    IO,
-                                                , Eq(..)
+    Int,
-                                                , ExitCode(..)
+    IsString (..),
-                                                , FilePath
+    Maybe (..),
-                                                , IO
+    Monad ((>>=)),
-                                                , Int
+    ReaderT (runReaderT),
-                                                , IsString(..)
+    Semigroup ((<>)),
-                                                , Maybe(..)
+    Show,
-                                                , Monad((>>=))
+    String,
-                                                , ReaderT(runReaderT)
+    appendFile,
-                                                , Semigroup((<>))
+    const,
-                                                , Show
+    decodeUtf8,
-                                                , String
+    exitWith,
-                                                , appendFile
+    filter,
-                                                , const
+    flip,
-                                                , decodeUtf8
+    fmap,
-                                                , exitWith
+    for,
-                                                , filter
+    for_,
-                                                , flip
+    fromIntegral,
-                                                , fmap
+    fromMaybe,
-                                                , for
+    fst,
-                                                , for_
+    headMay,
-                                                , fromIntegral
+    not,
-                                                , fromMaybe
+    panic,
-                                                , fst
+    show,
-                                                , headMay
+    snd,
-                                                , not
+    unlessM,
-                                                , panic
+    void,
-                                                , show
+    when,
-                                                , snd
+    writeFile,
-                                                , unlessM
+    zip,
-                                                , void
+    ($),
-                                                , when
+    ($>),
-                                                , writeFile
+    (&),
-                                                , zip
+    (.),
+    (<&>),
  )
-import           System.Directory               ( createDirectoryIfMissing
+import System.Directory (
-                                                , doesPathExist
+    createDirectoryIfMissing,
-                                                , getCurrentDirectory
+    doesPathExist,
-                                                , getFileSize
+    getCurrentDirectory,
-                                                , getHomeDirectory
+    getFileSize,
-                                                , listDirectory
+    getHomeDirectory,
+    listDirectory,
  )
-import           System.FilePath                ( (</>)
+import System.FilePath (
-                                                , takeDirectory
+    takeDirectory,
-                                                , takeExtension
+    takeExtension,
+    (</>),
  )
-import           System.ProgressBar             ( Progress(..)
+import System.ProgressBar (
-                                                , defStyle
+    Progress (..),
-                                                , newProgressBar
+    defStyle,
-                                                , updateProgress
+    newProgressBar,
+    updateProgress,
  )
-import           Yesod                          ( logError
+import Yesod (
-                                                , logWarn
+    logError,
+    logWarn,
  )
 
+
 data Upload = Upload
     { publishRepoName :: !String
     , publishPkg :: !(Maybe FilePath)
     , publishIndex :: !Bool
     }
-    deriving Show
+    deriving (Show)
+
 
 newtype PublishCfg = PublishCfg
     { publishCfgRepos :: HashMap String PublishCfgRepo
     }
-    deriving Generic
+    deriving (Generic)
 instance FromDhall PublishCfg
 instance ToDhall PublishCfg
 instance Default PublishCfg where
@@ -216,16 +234,20 @@ data PublishCfgRepo = PublishCfgRepo
 instance FromDhall PublishCfgRepo
 instance ToDhall PublishCfgRepo
 
+
 instance FromDhall URI where
     autoWith norm = fromMaybe (panic "Invalid URI for publish target") . parseURI <$> autoWith norm
 
+
 instance ToDhall URI where
     injectWith norm = contramap (show @_ @String) (injectWith norm)
 
+
 instance IsString URI where
     fromString = fromMaybe (panic "Invalid URI for publish target") . parseURI
 
-data Shell = Bash | Fish | Zsh deriving Show
+
+data Shell = Bash | Fish | Zsh deriving (Show)
 data Command
     = CmdInit !(Maybe Shell)
     | CmdRegAdd !String !PublishCfgRepo
@@ -238,73 +260,90 @@ data Command
     | CmdCatDel !String !String
     | CmdPkgCatAdd !String !PkgId !String
     | CmdPkgCatDel !String !PkgId !String
-    deriving Show
+    deriving (Show)
+
 
 cfgLocation :: IO FilePath
 cfgLocation = getHomeDirectory <&> \d -> d </> ".embassy/publish.dhall"
 
+
 parseInit :: Parser (Maybe Shell)
 parseInit = subparser $ command "init" (info go $ progDesc "Initializes embassy-publish config") <> metavar "init"
     where
         shells = [Bash, Fish, Zsh]
         go = headMay . fmap fst . filter snd . zip shells <$> for shells (switch . long . toS . toLower . show)
 
+
 parsePublish :: Parser Upload
-parsePublish = subparser $ command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry") <> metavar
+parsePublish =
+    subparser $
+        command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry")
+            <> metavar
                 "upload"
     where
-        go = liftA3
+        go =
+            liftA3
                 Upload
                 (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall"))
-            (optional $ strOption
+                ( optional $
+                    strOption
                         (short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the package to publish")
                 )
                 (switch (short 'i' <> long "index" <> help "Index the package after uploading"))
 
+
 parseRepoAdd :: Parser Command
 parseRepoAdd = subparser $ command "add" (info go $ progDesc "Add a registry to your config") <> metavar "add"
     where
         go :: Parser Command
         go =
-            let
+            let publishCfgRepoLocation =
-                publishCfgRepoLocation =
                     strOption (short 'l' <> long "location" <> metavar "REGISTRY_URL" <> help "Registry URL")
-                publishCfgRepoUser = strOption
+                publishCfgRepoUser =
+                    strOption
                         (short 'u' <> long "username" <> metavar "USERNAME" <> help "Admin username for this registry")
-                publishCfgRepoPass = strOption
+                publishCfgRepoPass =
+                    strOption
                         (short 'p' <> long "password" <> metavar "PASSWORD" <> help "Admin password for this registry")
                 name =
                     strOption
-                        (short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help
+                        ( short 'n' <> long "name" <> metavar "REGISTRY_NAME"
+                            <> help
                                 "Name to reference this registry in the future"
                         )
                 r = PublishCfgRepo <$> publishCfgRepoLocation <*> publishCfgRepoUser <*> publishCfgRepoPass
-            in
+             in liftA2 CmdRegAdd name r
-                liftA2 CmdRegAdd name r
+
 
 parseRepoDel :: Parser String
 parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry from your config") <> metavar "rm"
     where
-        go = strOption
+        go =
-            (short 'n' <> long "name" <> metavar "REGISTRY_NAME" <> help
+            strOption
+                ( short 'n' <> long "name" <> metavar "REGISTRY_NAME"
+                    <> help
                         "Registry name chosen when this was originally configured"
                 )
 
+
 parseRepoList :: Parser ()
 parseRepoList = subparser $ command "ls" (info (pure ()) $ progDesc "List registries in your config") <> metavar "ls"
 
+
 parseIndex :: Parser Command
 parseIndex =
-    subparser
+    subparser $
-        $  command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version")
+        command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version")
             <> metavar "index"
 
+
 parseDeindex :: Parser Command
 parseDeindex =
-    subparser
+    subparser $
-        $  command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version")
+        command "deindex" (info (parseIndexHelper False) $ progDesc "Deindexes an existing package version")
             <> metavar "deindex"
 
+
 parseIndexHelper :: Bool -> Parser Command
 parseIndexHelper b =
     CmdIndex
@@ -313,13 +352,17 @@ parseIndexHelper b =
         <*> strArgument (metavar "VERSION")
         <*> pure b
 
+
 parseListUnindexed :: Parser String
-parseListUnindexed = subparser $ command
+parseListUnindexed =
+    subparser $
+        command
             "list-unindexed"
-    ( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME"))
+            ( info (strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")) $
-    $ progDesc "Lists unindexed package versions on target registry"
+                progDesc "Lists unindexed package versions on target registry"
             )
 
+
 parseCommand :: Parser Command
 parseCommand =
     (CmdInit <$> parseInit)
@@ -330,12 +373,16 @@ parseCommand =
         <|> (CmdListUnindexed <$> parseListUnindexed)
         <|> parseCat
         <|> parsePkgCat
-    where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList)
+    where
+        reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList)
+
 
 parseCat :: Parser Command
 parseCat = subparser $ command "category" (info (add <|> del) $ progDesc "Manage categories")
     where
-        add = subparser $ command
+        add =
+            subparser $
+                command
                     "add"
                     ( info
                         ( CmdCatAdd
@@ -347,15 +394,19 @@ parseCat = subparser $ command "category" (info (add <|> del) $ progDesc "Manage
                         )
                         $ progDesc "Adds category to registry"
                     )
-        del = subparser $ command
+        del =
+            subparser $
+                command
                     "rm"
                     ( info
-                    (CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME") <*> strArgument
+                        ( CmdCatDel <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
+                            <*> strArgument
                                 (metavar "CATEGORY")
                         )
                         $ progDesc "Removes category from registry"
                     )
 
+
 parsePkgCat :: Parser Command
 parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remove package from category")
     where
@@ -368,11 +419,14 @@ parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remo
                     <*> strArgument (metavar "PACKAGE_ID")
                     <*> strArgument (metavar "CATEGORY")
 
+
 opts :: ParserInfo Command
 opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages")
 
+
 cliMain :: IO ()
-cliMain = execParser opts >>= \case
+cliMain =
+    execParser opts >>= \case
         CmdInit sh -> init sh
         CmdRegAdd s pcr -> regAdd s pcr
         CmdRegDel s -> regRm s
@@ -385,6 +439,7 @@ cliMain = execParser opts >>= \case
         CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat
         CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat
 
+
 init :: Maybe Shell -> IO ()
 init sh = do
     loc <- cfgLocation
@@ -405,7 +460,6 @@ init sh = do
                 writeFile zshcompleter (toS res)
 
 
-
 regAdd :: String -> PublishCfgRepo -> IO ()
 regAdd name val = do
     loc <- cfgLocation
@@ -423,6 +477,7 @@ regAdd name val = do
         . mappend "start9_admin:"
         $ publishCfgRepoPass val
 
+
 regRm :: String -> IO ()
 regRm name = do
     loc <- cfgLocation
@@ -430,6 +485,7 @@ regRm name = do
     let cfg' = delete name cfg
     writeFile loc (pretty $ embed inject $ PublishCfg cfg')
 
+
 regLs :: IO ()
 regLs = do
     loc <- cfgLocation
@@ -440,9 +496,10 @@ regLs = do
             putChunk $ fromString (k <> ": ") & fore yellow
             putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta
 
+
 upload :: Upload -> IO ()
 upload (Upload name mpkg shouldIndex) = do
-    PublishCfgRepo {..} <- findNameInCfg name
+    PublishCfgRepo{..} <- findNameInCfg name
     pkg <- case mpkg of
         Nothing -> do
             cwd <- getCurrentDirectory
@@ -452,7 +509,7 @@ upload (Upload name mpkg shouldIndex) = do
                 [] -> do
                     $logError "No package specified, and could not find one in this directory"
                     exitWith $ ExitFailure 1
-                [p        ] -> pure (cwd </> p)
+                [p] -> pure (cwd </> p)
                 (_ : _ : _) -> do
                     $logWarn "Ambiguous package upload request, found multiple candidates:"
                     for_ pkgs $ \f -> $logWarn (fromString f)
@@ -469,8 +526,8 @@ upload (Upload name mpkg shouldIndex) = do
     manager <- newTlsManager
     res <- runReaderT (httpLbs withBody) manager
     if getResponseStatus res == status200
-        -- no output is successful
+        then -- no output is successful
-        then pure ()
+            pure ()
         else do
             $logError (decodeUtf8 . LB.toStrict $ getResponseBody res)
             exitWith $ ExitFailure 1
@@ -478,7 +535,7 @@ upload (Upload name mpkg shouldIndex) = do
     when shouldIndex $ do
         home <- getHomeDirectory
         manifestBytes <- sourceManifest (home </> ".cargo/bin") pkg $ \c -> runConduit (c .| foldC)
-        PackageManifest { packageManifestId, packageManifestVersion } <- case eitherDecodeStrict manifestBytes of
+        PackageManifest{packageManifestId, packageManifestVersion} <- case eitherDecodeStrict manifestBytes of
             Left s -> do
                 $logError $ "Could not parse the manifest of the package: " <> toS s
                 exitWith $ ExitFailure 1
@@ -486,42 +543,50 @@ upload (Upload name mpkg shouldIndex) = do
         let pkgId = toS $ unPkgId packageManifestId
         index name pkgId packageManifestVersion
         putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green
-
     where
         sfs2prog :: StreamFileStatus -> Progress ()
-        sfs2prog StreamFileStatus {..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
+        sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
+
 
 index :: String -> String -> Version -> IO ()
 index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v)
 
+
 deindex :: String -> String -> Version -> IO ()
 deindex name pkg v = performHttp name "POST" [i|/admin/v0/deindex|] (IndexPkgReq (PkgId $ toS pkg) v)
 
+
 listUnindexed :: String -> IO ()
 listUnindexed name = do
-    PublishCfgRepo {..} <- findNameInCfg name
+    PublishCfgRepo{..} <- findNameInCfg name
     noBody <-
         parseRequest (show publishCfgRepoLocation <> "/admin/v0/deindex")
             <&> setRequestHeaders [("accept", "application/json")]
             <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
-    PackageList {..} <- getResponseBody <$> httpJSON noBody
+    PackageList{..} <- getResponseBody <$> httpJSON noBody
-    void $ flip traverseWithKey unPackageList $ \k v -> do
+    void $
+        flip traverseWithKey unPackageList $ \k v -> do
             putChunk (chunk (unPkgId k <> ": ") & fore blue)
             putChunkLn $ chunk (show v) & fore yellow
 
+
 catAdd :: String -> String -> Maybe String -> Maybe Int -> IO ()
 catAdd target name desc pri =
     performHttp target "POST" [i|/admin/v0/category/#{name}|] (AddCategoryReq (toS <$> desc) pri)
 
+
 catDel :: String -> String -> IO ()
 catDel target name = performHttp target "DELETE" [i|/admin/v0/category/#{name}|] ()
 
+
 pkgCatAdd :: String -> PkgId -> String -> IO ()
 pkgCatAdd target pkg cat = performHttp target "POST" [i|/admin/v0/categorize/#{cat}/#{pkg}|] ()
 
+
 pkgCatDel :: String -> PkgId -> String -> IO ()
 pkgCatDel target pkg cat = performHttp target "DELETE" [i|/admin/v0/categorize/#{cat}/#{pkg}|] ()
 
+
 findNameInCfg :: String -> IO PublishCfgRepo
 findNameInCfg name = do
     loc <- cfgLocation
@@ -532,9 +597,10 @@ findNameInCfg name = do
             exitWith $ ExitFailure 1
         Just pcr -> pure pcr
 
+
 performHttp :: ToJSON a => String -> String -> String -> a -> IO ()
 performHttp target method route body = do
-    PublishCfgRepo {..} <- findNameInCfg target
+    PublishCfgRepo{..} <- findNameInCfg target
     noBody <-
         parseRequest (method <> " " <> show publishCfgRepoLocation <> route)
             <&> setRequestHeaders [("accept", "text/plain")]
@@ -555,6 +621,7 @@ instance MonadLogger IO where
     monadLoggerLog _ _ LevelError = putChunkLn . colorLog red
     monadLoggerLog _ _ (LevelOther _) = putChunkLn . colorLog magenta
 
+
 colorLog :: ToLogStr msg => Radiant -> msg -> Chunk
 colorLog c m = fore c $ chunk . decodeUtf8 . fromLogStr . toLogStr $ m
 instance MonadLoggerIO IO where

src/Database/Marketplace.hs

@@ -1,225 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-{-# HLINT ignore "Fuse on/on" #-}
-
-module Database.Marketplace where
-
-import           Conduit                        ( ConduitT
-                                                , MonadResource
-                                                , MonadUnliftIO
-                                                , awaitForever
-                                                , leftover
-                                                , yield
-                                                )
-import           Control.Monad.Loops            ( unfoldM )
-import           Data.Conduit                   ( await )
-import           Database.Esqueleto.Experimental
-                                                ( (%)
-                                                , (&&.)
-                                                , (++.)
-                                                , (:&)(..)
-                                                , (==.)
-                                                , (^.)
-                                                , asc
-                                                , desc
-                                                , from
-                                                , groupBy
-                                                , ilike
-                                                , in_
-                                                , innerJoin
-                                                , on
-                                                , orderBy
-                                                , select
-                                                , selectSource
-                                                , table
-                                                , val
-                                                , valList
-                                                , where_
-                                                , (||.)
-                                                )
-import qualified Database.Persist              as P
-import           Database.Persist.Postgresql    ( ConnectionPool
-                                                , Entity(entityKey, entityVal)
-                                                , PersistEntity(Key)
-                                                , SqlBackend
-                                                , runSqlPool
-                                                )
-import           Handler.Types.Marketplace      ( PackageDependencyMetadata(..) )
-import           Lib.Types.AppIndex             ( PkgId )
-import           Lib.Types.Emver                ( Version )
-import           Model                          ( Category
-                                                , EntityField
-                                                    ( CategoryId
-                                                    , CategoryName
-                                                    , PkgCategoryCategoryId
-                                                    , PkgCategoryPkgId
-                                                    , PkgDependencyDepId
-                                                    , PkgDependencyPkgId
-                                                    , PkgDependencyPkgVersion
-                                                    , PkgRecordId
-                                                    , VersionRecordDescLong
-                                                    , VersionRecordDescShort
-                                                    , VersionRecordNumber
-                                                    , VersionRecordPkgId
-                                                    , VersionRecordTitle
-                                                    , VersionRecordUpdatedAt
-                                                    )
-                                                , Key(PkgRecordKey, unPkgRecordKey)
-                                                , PkgCategory
-                                                , PkgDependency
-                                                , PkgRecord
-                                                , VersionRecord(versionRecordNumber, versionRecordPkgId)
-                                                )
-import           Startlude                      ( ($)
-                                                , ($>)
-                                                , (.)
-                                                , (<$>)
-                                                , Applicative(pure)
-                                                , Down(Down)
-                                                , Eq((==))
-                                                , Functor(fmap)
-                                                , Maybe(..)
-                                                , Monad
-                                                , MonadIO
-                                                , ReaderT
-                                                , Text
-                                                , headMay
-                                                , lift
-                                                , snd
-                                                , sortOn
-                                                )
-
-type CategoryTitle = Text
-
-searchServices :: (MonadResource m, MonadIO m)
-               => Maybe CategoryTitle
-               -> Text
-               -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
-searchServices Nothing query = selectSource $ do
-    service <- from $ table @VersionRecord
-    where_
-        (   (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
-        ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
-        ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
-        )
-    groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber)
-    orderBy
-        [ asc (service ^. VersionRecordPkgId)
-        , desc (service ^. VersionRecordNumber)
-        , desc (service ^. VersionRecordUpdatedAt)
-        ]
-    pure service
-searchServices (Just category) query = selectSource $ do
-    services <- from
-        (do
-            (service :& _ :& cat) <-
-                from
-                $           table @VersionRecord
-                `innerJoin` table @PkgCategory
-                `on`        (\(s :& sc) -> sc ^. PkgCategoryPkgId ==. s ^. VersionRecordPkgId)
-                `innerJoin` table @Category
-                `on`        (\(_ :& sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
-            -- if there is a cateogry, only search in category
-            -- weight title, short, long (bitcoin should equal Bitcoin Core)
-            where_
-                $   cat
-                ^.  CategoryName
-                ==. val category
-                &&. (   (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
-                    ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
-                    ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
-                    )
-            pure service
-        )
-    groupBy (services ^. VersionRecordPkgId, services ^. VersionRecordNumber)
-    orderBy
-        [ asc (services ^. VersionRecordPkgId)
-        , desc (services ^. VersionRecordNumber)
-        , desc (services ^. VersionRecordUpdatedAt)
-        ]
-    pure services
-
-getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
-getPkgData pkgs = selectSource $ do
-    pkgData <- from $ table @VersionRecord
-    where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
-    pure pkgData
-
-getPkgDependencyData :: MonadIO m
-                     => Key PkgRecord
-                     -> Version
-                     -> ReaderT SqlBackend m [(Entity PkgDependency, Entity PkgRecord)]
-getPkgDependencyData pkgId pkgVersion = select $ do
-    from
-        (do
-            (pkgDepRecord :& depPkgRecord) <-
-                from
-                $           table @PkgDependency
-                `innerJoin` table @PkgRecord
-                `on`        (\(pdr :& dpr) -> dpr ^. PkgRecordId ==. pdr ^. PkgDependencyDepId)
-            where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val pkgId)
-            where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion)
-            pure (pkgDepRecord, depPkgRecord)
-        )
-
-zipCategories :: MonadUnliftIO m
-              => ConduitT
-                     (PkgId, [Entity VersionRecord])
-                     (PkgId, [Entity VersionRecord], [Entity Category])
-                     (ReaderT SqlBackend m)
-                     ()
-zipCategories = awaitForever $ \(pkg, vers) -> do
-    raw <- lift $ select $ do
-        (sc :& cat) <-
-            from
-            $           table @PkgCategory
-            `innerJoin` table @Category
-            `on`        (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
-        where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg))
-        pure cat
-    yield (pkg, vers, raw)
-
-collateVersions :: MonadUnliftIO m
-                => ConduitT (Entity VersionRecord) (PkgId, [Entity VersionRecord]) (ReaderT SqlBackend m) ()
-collateVersions = awaitForever $ \v0 -> do
-    let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0
-    let pull = do
-            mvn <- await
-            case mvn of
-                Nothing -> pure Nothing
-                Just vn -> do
-                    let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal vn
-                    if pkg == pkg' then pure (Just vn) else leftover vn $> Nothing
-    ls <- unfoldM pull
-    yield (pkg, v0 : ls)
-
-zipDependencyVersions :: (Monad m, MonadIO m)
-                      => (Entity PkgDependency, Entity PkgRecord)
-                      -> ReaderT SqlBackend m PackageDependencyMetadata
-zipDependencyVersions (pkgDepRecord, depRecord) = do
-    let pkgDbId = entityKey depRecord
-    depVers <- select $ do
-        v <- from $ table @VersionRecord
-        where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
-        pure v
-    pure $ PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord
-                                     , packageDependencyMetadataDepPkgRecord        = depRecord
-                                     , packageDependencyMetadataDepVersions         = depVers
-                                     }
-
-fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
-fetchAllAppVersions appConnPool appId = do
-    entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
-    pure $ entityVal <$> entityAppVersions
-
-fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
-fetchLatestApp appId = fmap headMay . sortResults . select $ do
-    (service :& version) <-
-        from
-        $           table @PkgRecord
-        `innerJoin` table @VersionRecord
-        `on`        (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
-    where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId))
-    pure (service, version)
-    where sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd)

src/Database/Queries.hs

@@ -1,56 +1,271 @@
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Database.Queries where
 
-import           Database.Persist.Sql           ( PersistStoreRead(get)
+import Database.Persist.Sql (
-                                                , PersistStoreWrite(insertKey, insert_, repsert)
+    PersistStoreRead (get),
-                                                , SqlBackend
+    PersistStoreWrite (insertKey, insert_, repsert),
+    SqlBackend,
  )
-import           Lib.Types.AppIndex             ( PackageManifest(..)
+import Lib.Types.Core (
-                                                , PkgId
+    PkgId,
  )
-import           Lib.Types.Emver                ( Version )
+import Lib.Types.Emver (Version)
-import           Model                          ( Key(PkgRecordKey, VersionRecordKey)
+import Model (
-                                                , Metric(Metric)
+    Key (PkgRecordKey, VersionRecordKey),
-                                                , PkgRecord(PkgRecord)
+    Metric (Metric),
-                                                , VersionRecord(VersionRecord)
+    PkgDependency (..),
+    PkgRecord (PkgRecord),
+    VersionRecord (VersionRecord),
  )
-import           Orphans.Emver                  ( )
+import Orphans.Emver ()
-import           Startlude                      ( ($)
+import Startlude (
-                                                , (.)
+    ConvertText (toS),
-                                                , ConvertText(toS)
+    Maybe (..),
-                                                , Maybe(..)
+    MonadIO (..),
-                                                , MonadIO(..)
+    ReaderT,
-                                                , ReaderT
+    SomeException,
-                                                , SomeException
+    getCurrentTime,
-                                                , getCurrentTime
+    maybe,
-                                                , maybe
+    ($),
+    (.),
  )
-import           System.FilePath                ( takeExtension )
+import System.FilePath (takeExtension)
-import           UnliftIO                       ( MonadUnliftIO
+import UnliftIO (
-                                                , try
+    MonadUnliftIO,
+    try,
  )
 
-fetchApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe PkgRecord)
+import Conduit (
-fetchApp = get . PkgRecordKey
+    ConduitT,
+    MonadResource,
+    awaitForever,
+    leftover,
+    yield,
+ )
+import Control.Monad.Loops (unfoldM)
+import Data.Conduit (await)
+import Database.Esqueleto.Experimental (
+    PersistEntity,
+    SqlExpr,
+    Value,
+    asc,
+    desc,
+    from,
+    groupBy,
+    ilike,
+    in_,
+    innerJoin,
+    on,
+    orderBy,
+    select,
+    selectSource,
+    table,
+    val,
+    valList,
+    where_,
+    (%),
+    (&&.),
+    (++.),
+    (:&) (..),
+    (==.),
+    (^.),
+    (||.),
+ )
+import Database.Persist qualified as P
+import Database.Persist.Postgresql (
+    ConnectionPool,
+    Entity (entityVal),
+    runSqlPool,
+ )
+import Lib.Types.Manifest (PackageManifest (..))
+import Model (
+    Category,
+    EntityField (
+        CategoryId,
+        CategoryName,
+        PkgCategoryCategoryId,
+        PkgCategoryPkgId,
+        PkgDependencyPkgId,
+        PkgDependencyPkgVersion,
+        PkgRecordId,
+        VersionRecordDescLong,
+        VersionRecordDescShort,
+        VersionRecordNumber,
+        VersionRecordPkgId,
+        VersionRecordTitle,
+        VersionRecordUpdatedAt
+    ),
+    Key (unPkgRecordKey),
+    PkgCategory,
+    VersionRecord (versionRecordNumber, versionRecordPkgId),
+ )
+import Startlude (
+    Applicative (pure),
+    Bool,
+    Down (Down),
+    Eq ((==)),
+    Functor (fmap),
+    Monad,
+    Text,
+    headMay,
+    snd,
+    sortOn,
+    ($>),
+    (<$>),
+ )
+
+
+serviceQuerySource ::
+    (MonadResource m, MonadIO m) =>
+    Maybe Text ->
+    Text ->
+    ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
+serviceQuerySource mCat query = selectSource $ do
+    service <- case mCat of
+        Nothing -> do
+            service <- from $ table @VersionRecord
+            where_ $ queryInMetadata query service
+            pure service
+        Just category -> do
+            (service :& _ :& cat) <-
+                from $
+                    table @VersionRecord
+                        `innerJoin` table @PkgCategory `on` (VersionRecordPkgId === PkgCategoryPkgId)
+                        `innerJoin` table @Category `on` (\(_ :& a :& b) -> (PkgCategoryCategoryId === CategoryId) (a :& b))
+            -- if there is a cateogry, only search in category
+            -- weight title, short, long (bitcoin should equal Bitcoin Core)
+            where_ $ cat ^. CategoryName ==. val category &&. queryInMetadata query service
+            pure service
+    groupBy (service ^. VersionRecordPkgId, service ^. VersionRecordNumber)
+    orderBy
+        [ asc (service ^. VersionRecordPkgId)
+        , desc (service ^. VersionRecordNumber)
+        , desc (service ^. VersionRecordUpdatedAt)
+        ]
+    pure service
+
+
+queryInMetadata :: Text -> SqlExpr (Entity VersionRecord) -> (SqlExpr (Value Bool))
+queryInMetadata query service =
+    (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
+        ||. (service ^. VersionRecordDescLong `ilike` (%) ++. val query ++. (%))
+        ||. (service ^. VersionRecordTitle `ilike` (%) ++. val query ++. (%))
+
+
+getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
+getPkgDataSource pkgs = selectSource $ do
+    pkgData <- from $ table @VersionRecord
+    where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
+    pure pkgData
+
+
+getPkgDependencyData ::
+    MonadIO m =>
+    PkgId ->
+    Version ->
+    ReaderT SqlBackend m [PkgDependency]
+getPkgDependencyData pkgId pkgVersion = fmap (fmap entityVal) $
+    select $
+        from $ do
+            pkgDepRecord <- from $ table @PkgDependency
+            where_ (pkgDepRecord ^. PkgDependencyPkgId ==. val (PkgRecordKey pkgId))
+            where_ (pkgDepRecord ^. PkgDependencyPkgVersion ==. val pkgVersion)
+            pure pkgDepRecord
+
+
+(===) ::
+    (PersistEntity val1, PersistEntity val2, P.PersistField typ) =>
+    EntityField val1 typ ->
+    EntityField val2 typ ->
+    (SqlExpr (Entity val1) :& SqlExpr (Entity val2)) ->
+    SqlExpr (Value Bool)
+(===) a' b' (a :& b) = a ^. a' ==. b ^. b'
+
+
+getCategoriesFor ::
+    MonadUnliftIO m =>
+    PkgId ->
+    ReaderT SqlBackend m [Category]
+getCategoriesFor pkg = fmap (fmap entityVal) $
+    select $ do
+        (sc :& cat) <-
+            from $
+                table @PkgCategory
+                    `innerJoin` table @Category `on` (PkgCategoryCategoryId === CategoryId)
+        where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg))
+        pure cat
+
+
+collateVersions ::
+    MonadUnliftIO m =>
+    ConduitT (Entity VersionRecord) (PkgId, [VersionRecord]) (ReaderT SqlBackend m) ()
+collateVersions = awaitForever $ \v0 -> do
+    let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0
+    let pull = do
+            mvn <- await
+            case mvn of
+                Nothing -> pure Nothing
+                Just vn -> do
+                    let pkg' = unPkgRecordKey . versionRecordPkgId $ entityVal vn
+                    if pkg == pkg' then pure (Just vn) else leftover vn $> Nothing
+    ls <- unfoldM pull
+    yield (pkg, fmap entityVal $ v0 : ls)
+
+
+getDependencyVersions ::
+    (Monad m, MonadIO m) =>
+    PkgDependency ->
+    ReaderT SqlBackend m [VersionRecord]
+getDependencyVersions pkgDepRecord = do
+    let pkgDbId = pkgDependencyDepId pkgDepRecord
+    depVers <- select $ do
+        v <- from $ table @VersionRecord
+        where_ $ v ^. VersionRecordPkgId ==. val pkgDbId
+        pure v
+    pure $ entityVal <$> depVers
+
+
+fetchAllAppVersions :: MonadUnliftIO m => ConnectionPool -> PkgId -> m [VersionRecord]
+fetchAllAppVersions appConnPool appId = do
+    entityAppVersions <- runSqlPool (P.selectList [VersionRecordPkgId P.==. PkgRecordKey appId] []) appConnPool
+    pure $ entityVal <$> entityAppVersions
+
 
 fetchAppVersion :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m (Maybe VersionRecord)
 fetchAppVersion pkgId version = get (VersionRecordKey (PkgRecordKey pkgId) version)
 
+
+fetchLatestApp :: MonadIO m => PkgId -> ReaderT SqlBackend m (Maybe (P.Entity PkgRecord, P.Entity VersionRecord))
+fetchLatestApp appId = fmap headMay . sortResults . select $ do
+    (service :& version) <-
+        from $
+            table @PkgRecord
+                `innerJoin` table @VersionRecord
+                `on` (\(service :& version) -> service ^. PkgRecordId ==. version ^. VersionRecordPkgId)
+    where_ (service ^. PkgRecordId ==. val (PkgRecordKey appId))
+    pure (service, version)
+    where
+        sortResults = fmap $ sortOn (Down . versionRecordNumber . entityVal . snd)
+
+
 createMetric :: MonadIO m => PkgId -> Version -> ReaderT SqlBackend m ()
 createMetric appId version = do
     time <- liftIO getCurrentTime
     insert_ $ Metric time (PkgRecordKey appId) version
 
+
 upsertPackageVersion :: (MonadUnliftIO m) => PackageManifest -> ReaderT SqlBackend m ()
-upsertPackageVersion PackageManifest {..} = do
+upsertPackageVersion PackageManifest{..} = do
     now <- liftIO getCurrentTime
     let iconType = maybe "png" (toS . takeExtension . toS) packageManifestIcon
     let pkgId = PkgRecordKey packageManifestId
-    let ins = VersionRecord now
+    let ins =
+            VersionRecord
+                now
                 (Just now)
                 pkgId
                 packageManifestVersion

src/Foundation.hs

@@ -1,148 +1,161 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ViewPatterns          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Foundation where
 
-import           Startlude                      ( ($)
+import Startlude (
-                                                , (.)
+    Applicative (pure),
-                                                , (<$>)
+    Bool (False),
-                                                , (<&>)
+    Eq ((==)),
-                                                , (<**>)
+    IO,
-                                                , (=<<)
+    MVar,
-                                                , Applicative(pure)
+    Maybe (..),
-                                                , Bool(False)
+    Monad (return),
-                                                , Eq((==))
+    Monoid (mempty),
-                                                , IO
+    Semigroup ((<>)),
-                                                , MVar
+    String,
-                                                , Maybe(..)
+    Text,
-                                                , Monad(return)
+    ThreadId,
-                                                , Monoid(mempty)
+    Word64,
-                                                , Semigroup((<>))
+    decodeUtf8,
-                                                , String
+    drop,
-                                                , Text
+    encodeUtf8,
-                                                , ThreadId
+    flip,
-                                                , Word64
+    fst,
-                                                , decodeUtf8
+    isJust,
-                                                , drop
+    otherwise,
-                                                , encodeUtf8
+    putMVar,
-                                                , flip
+    show,
-                                                , fst
+    when,
-                                                , isJust
+    ($),
-                                                , otherwise
+    (.),
-                                                , putMVar
+    (<$>),
-                                                , show
+    (<&>),
-                                                , when
+    (<**>),
-                                                , (||)
+    (=<<),
+    (||),
  )
 
-import           Control.Monad.Logger           ( Loc
+import Control.Monad.Logger (
-                                                , LogSource
+    Loc,
-                                                , LogStr
+    LogSource,
-                                                , ToLogStr(toLogStr)
+    LogStr,
-                                                , fromLogStr
+    ToLogStr (toLogStr),
+    fromLogStr,
  )
-import           Database.Persist.Sql           ( ConnectionPool
+import Database.Persist.Sql (
-                                                , LogFunc
+    ConnectionPool,
-                                                , PersistStoreRead(get)
+    LogFunc,
-                                                , SqlBackend
+    PersistStoreRead (get),
-                                                , SqlPersistT
+    SqlBackend,
-                                                , runSqlPool
+    SqlPersistT,
+    runSqlPool,
  )
-import           Lib.Registry                   ( S9PK )
+import Yesod.Core (
-import           Yesod.Core                     ( AuthResult(Authorized, Unauthorized)
+    AuthResult (Authorized, Unauthorized),
-                                                , LogLevel(..)
+    LogLevel (..),
-                                                , MonadHandler(liftHandler)
+    MonadHandler (liftHandler),
-                                                , RenderMessage(..)
+    RenderMessage (..),
-                                                , RenderRoute(Route, renderRoute)
+    RenderRoute (Route, renderRoute),
-                                                , RouteAttrs(routeAttrs)
+    RouteAttrs (routeAttrs),
-                                                , SessionBackend
+    SessionBackend,
-                                                , ToTypedContent
+    ToTypedContent,
-                                                , Yesod
+    Yesod (
-                                                    ( isAuthorized
+        isAuthorized,
-                                                    , makeLogger
+        makeLogger,
-                                                    , makeSessionBackend
+        makeSessionBackend,
-                                                    , maximumContentLengthIO
+        maximumContentLengthIO,
-                                                    , messageLoggerSource
+        messageLoggerSource,
-                                                    , shouldLogIO
+        shouldLogIO,
-                                                    , yesodMiddleware
+        yesodMiddleware
+    ),
+    defaultYesodMiddleware,
+    getYesod,
+    getsYesod,
+    mkYesodData,
+    parseRoutesFile,
  )
-                                                , defaultYesodMiddleware
+import Yesod.Core.Types (
-                                                , getYesod
+    HandlerData (handlerEnv),
-                                                , getsYesod
+    Logger (loggerDate),
-                                                , mkYesodData
+    RunHandlerEnv (rheChild, rheSite),
-                                                , parseRoutesFile
+    loggerPutStr,
  )
-import           Yesod.Core.Types               ( HandlerData(handlerEnv)
+import Yesod.Core.Unsafe qualified as Unsafe
-                                                , Logger(loggerDate)
-                                                , RunHandlerEnv(rheChild, rheSite)
-                                                , loggerPutStr
-                                                )
-import qualified Yesod.Core.Unsafe             as Unsafe
 
-import           Control.Monad.Logger.Extras    ( wrapSGRCode )
+import Control.Monad.Logger.Extras (wrapSGRCode)
-import           Control.Monad.Reader.Has       ( Has(extract, update) )
+import Control.Monad.Reader.Has (Has (extract, update))
-import           Crypto.Hash                    ( SHA256(SHA256)
+import Crypto.Hash (
-                                                , hashWith
+    SHA256 (SHA256),
+    hashWith,
  )
-import           Data.Set                       ( member )
+import Data.Set (member)
-import           Data.String.Interpolate.IsString
+import Data.String.Interpolate.IsString (
-                                                ( i )
+    i,
-import qualified Data.Text                     as T
-import           Language.Haskell.TH            ( Loc(..) )
-import           Lib.PkgRepository              ( EosRepo
-                                                , PkgRepo
  )
-import           Lib.Types.AppIndex             ( PkgId )
+import Data.Text qualified as T
-import           Model                          ( Admin(..)
+import Handler.Types.Api (ApiVersion (..))
-                                                , Key(AdminKey)
+import Language.Haskell.TH (Loc (..))
+import Lib.PkgRepository (
+    EosRepo,
+    PkgRepo,
  )
-import           Settings                       ( AppSettings(appShouldLogAll) )
+import Lib.Types.Core (PkgId, S9PK)
-import           System.Console.ANSI.Codes      ( Color(..)
+import Model (
-                                                , ColorIntensity(..)
+    Admin (..),
-                                                , ConsoleLayer(Foreground)
+    Key (AdminKey),
-                                                , SGR(SetColor)
  )
-import           Yesod                          ( FormMessage
+import Settings (AppSettings (appShouldLogAll))
-                                                , defaultFormMessage
+import System.Console.ANSI.Codes (
+    Color (..),
+    ColorIntensity (..),
+    ConsoleLayer (Foreground),
+    SGR (SetColor),
  )
-import           Yesod.Auth                     ( AuthEntity
+import Yesod (
-                                                , Creds(credsIdent)
+    FormMessage,
-                                                , YesodAuth
+    defaultFormMessage,
-                                                    ( AuthId
-                                                    , authPlugins
-                                                    , getAuthId
-                                                    , loginDest
-                                                    , logoutDest
-                                                    , maybeAuthId
  )
-                                                , YesodAuthPersist(getAuthEntity)
+import Yesod.Auth (
+    AuthEntity,
+    Creds (credsIdent),
+    YesodAuth (
+        AuthId,
+        authPlugins,
+        getAuthId,
+        loginDest,
+        logoutDest,
+        maybeAuthId
+    ),
+    YesodAuthPersist (getAuthEntity),
  )
-import           Yesod.Auth.Http.Basic          ( defaultAuthSettings
+import Yesod.Auth.Http.Basic (
-                                                , defaultMaybeBasicAuthId
+    defaultAuthSettings,
+    defaultMaybeBasicAuthId,
  )
-import           Yesod.Persist.Core             ( DBRunner
+import Yesod.Persist.Core (
-                                                , YesodPersist(..)
+    DBRunner,
-                                                , YesodPersistRunner(..)
+    YesodPersist (..),
-                                                , defaultGetDBRunner
+    YesodPersistRunner (..),
+    defaultGetDBRunner,
  )
 
+
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
-
-
 data RegistryCtx = RegistryCtx
     { appSettings :: AppSettings
     , appLogger :: Logger
@@ -151,6 +164,8 @@ data RegistryCtx = RegistryCtx
     , appConnPool :: ConnectionPool
     , appStopFsNotifyEos :: IO Bool
     }
+
+
 instance Has PkgRepo RegistryCtx where
     extract = transitiveExtract @AppSettings
     update = transitiveUpdate @AppSettings
@@ -158,27 +173,30 @@ instance Has a r => Has a (HandlerData r r) where
     extract = extract . rheSite . handlerEnv
     update f r =
         let ctx = update f (rheSite $ handlerEnv r)
-            rhe = (handlerEnv r) { rheSite = ctx, rheChild = ctx }
+            rhe = (handlerEnv r){rheSite = ctx, rheChild = ctx}
-        in  r { handlerEnv = rhe }
+         in r{handlerEnv = rhe}
 instance Has AppSettings RegistryCtx where
     extract = appSettings
-    update f ctx = ctx { appSettings = f (appSettings ctx) }
+    update f ctx = ctx{appSettings = f (appSettings ctx)}
 instance Has EosRepo RegistryCtx where
     extract = transitiveExtract @AppSettings
     update = transitiveUpdate @AppSettings
 
+
 {-# INLINE transitiveExtract #-}
-transitiveExtract :: forall b a c . (Has a b, Has b c) => c -> a
+transitiveExtract :: forall b a c. (Has a b, Has b c) => c -> a
 transitiveExtract = extract @a . extract @b
 
+
 {-# INLINE transitiveUpdate #-}
-transitiveUpdate :: forall b a c . (Has a b, Has b c) => (a -> a) -> (c -> c)
+transitiveUpdate :: forall b a c. (Has a b, Has b c) => (a -> a) -> (c -> c)
 transitiveUpdate f = update (update @a @b f)
 
 
 setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO ()
 setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
 
+
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers
@@ -193,41 +211,44 @@ setWebProcessThreadId tid@(!_, !_) a = putMVar (appWebServerThreadId a) tid
 -- type Handler = HandlerT RegistryCtx IO
 mkYesodData "RegistryCtx" $(parseRoutesFile "config/routes")
 
+
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
 instance Yesod RegistryCtx where
-
+    -- Store session data on the client in encrypted cookies,
--- Store session data on the client in encrypted cookies,
+    -- default session idle timeout is 120 minutes
--- default session idle timeout is 120 minutes
     makeSessionBackend :: RegistryCtx -> IO (Maybe SessionBackend)
     makeSessionBackend _ = pure Nothing
 
--- Yesod Middleware allows you to run code before and after each handler function.
+
--- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
+    -- Yesod Middleware allows you to run code before and after each handler function.
--- Some users may also want to add the defaultCsrfMiddleware, which:
+    -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
---   a) Sets a cookie with a CSRF token in it.
+    -- Some users may also want to add the defaultCsrfMiddleware, which:
---   b) Validates that incoming write requests include that token in either a header or POST parameter.
+    --   a) Sets a cookie with a CSRF token in it.
--- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
+    --   b) Validates that incoming write requests include that token in either a header or POST parameter.
--- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
+    -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
+    -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
     yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
     yesodMiddleware = defaultYesodMiddleware
 
--- What messages should be logged. The following includes all messages when
+
--- in development, and warnings and errors in production.
+    -- What messages should be logged. The following includes all messages when
+    -- in development, and warnings and errors in production.
     shouldLogIO :: RegistryCtx -> LogSource -> LogLevel -> IO Bool
     shouldLogIO app _source level =
         return $ appShouldLogAll (appSettings app) || level == LevelInfo || level == LevelWarn || level == LevelError
 
+
     makeLogger :: RegistryCtx -> IO Logger
     makeLogger = return . appLogger
 
+
     messageLoggerSource :: RegistryCtx -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
     messageLoggerSource ctx logger = \loc src lvl str -> do
         shouldLog <- shouldLogIO ctx src lvl
         when shouldLog $ do
             date <- loggerDate logger
-            let
+            let formatted =
-                formatted =
                     toLogStr date
                         <> ( toLogStr
                                 . wrapSGRCode [SetColor Foreground Vivid (colorFor lvl)]
@@ -240,7 +261,8 @@ instance Yesod RegistryCtx where
                                     )
                            )
                         <> toLogStr
-                               (wrapSGRCode [SetColor Foreground Dull White]
+                            ( wrapSGRCode
+                                [SetColor Foreground Dull White]
                                 [i| @ #{loc_filename loc}:#{fst $ loc_start loc}\n|]
                             )
             loggerPutStr logger formatted
@@ -255,6 +277,7 @@ instance Yesod RegistryCtx where
                 LevelError -> Red
                 LevelOther _ -> White
 
+
     isAuthorized :: Route RegistryCtx -> Bool -> Handler AuthResult
     isAuthorized route _
         | "admin" `member` routeAttrs route = do
@@ -262,20 +285,24 @@ instance Yesod RegistryCtx where
             pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only"
         | otherwise = pure Authorized
 
+
     maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64)
     maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing
     maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default
 
+
 -- How to run database actions.
 instance YesodPersist RegistryCtx where
     type YesodPersistBackend RegistryCtx = SqlBackend
     runDB :: SqlPersistT Handler a -> Handler a
     runDB action = runSqlPool action . appConnPool =<< getYesod
 
+
 instance YesodPersistRunner RegistryCtx where
     getDBRunner :: Handler (DBRunner RegistryCtx, Handler ())
     getDBRunner = defaultGetDBRunner appConnPool
 
+
 instance RenderMessage RegistryCtx FormMessage where
     renderMessage _ _ = defaultFormMessage
 instance YesodAuth RegistryCtx where
@@ -287,22 +314,23 @@ instance YesodAuth RegistryCtx where
                 let passHash = hashWith SHA256 . encodeUtf8 . ("start9_admin:" <>) $ decodeUtf8 s
                 get (AdminKey $ decodeUtf8 k) <&> \case
                     Nothing -> False
-                    Just Admin { adminPassHash } -> adminPassHash == passHash
+                    Just Admin{adminPassHash} -> adminPassHash == passHash
 
         defaultMaybeBasicAuthId checkCreds defaultAuthSettings
-    loginDest _ = PackageListR
+    loginDest _ = PackageIndexR V1
-    logoutDest _ = PackageListR
+    logoutDest _ = PackageIndexR V1
     authPlugins _ = []
 
+
 instance YesodAuthPersist RegistryCtx where
     type AuthEntity RegistryCtx = Admin
     getAuthEntity = liftHandler . runDB . get . AdminKey
 
 
-
 unsafeHandler :: RegistryCtx -> Handler a -> IO a
 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 
+
 -- Note: Some functionality previously present in the scaffolding has been
 -- moved to documentation in the Wiki. Following are some hopefully helpful
 -- links:

src/Handler/Admin.hs

@@ -1,128 +1,148 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+
 module Handler.Admin where
 
-import           Conduit                        ( (.|)
+import Conduit (
-                                                , runConduit
+    runConduit,
-                                                , sinkFile
+    sinkFile,
+    (.|),
  )
-import           Control.Exception              ( ErrorCall(ErrorCall) )
+import Control.Exception (ErrorCall (ErrorCall))
-import           Control.Monad.Reader.Has       ( ask )
+import Control.Monad.Reader.Has (ask)
-import           Control.Monad.Trans.Maybe      ( MaybeT(..) )
+import Control.Monad.Trans.Maybe (MaybeT (..))
-import           Data.Aeson                     ( (.:)
+import Data.Aeson (
-                                                , (.:?)
+    FromJSON (parseJSON),
-                                                , (.=)
+    ToJSON,
-                                                , FromJSON(parseJSON)
+    decodeFileStrict,
-                                                , ToJSON
+    object,
-                                                , decodeFileStrict
+    withObject,
-                                                , object
+    (.:),
-                                                , withObject
+    (.:?),
+    (.=),
  )
-import           Data.HashMap.Internal.Strict   ( HashMap
+import Data.HashMap.Internal.Strict (
-                                                , differenceWith
+    HashMap,
-                                                , filter
+    differenceWith,
-                                                , fromListWith
+    filter,
+    fromListWith,
  )
-import           Data.List                      ( (\\)
+import Data.List (
-                                                , null
+    null,
+    (\\),
  )
-import           Data.String.Interpolate.IsString
+import Data.String.Interpolate.IsString (
-                                                ( i )
+    i,
-import           Database.Persist               ( Entity(entityKey)
-                                                , PersistStoreRead(get)
-                                                , PersistUniqueRead(getBy)
-                                                , PersistUniqueWrite(deleteBy, insertUnique, upsert)
-                                                , entityVal
-                                                , insert_
-                                                , selectList
  )
-import           Database.Persist.Postgresql    ( runSqlPoolNoTransaction )
+import Database.Persist (
-import           Database.Queries               ( upsertPackageVersion )
+    Entity (entityKey),
-import           Foundation                     ( Handler
+    PersistStoreRead (get),
-                                                , RegistryCtx(..)
+    PersistUniqueRead (getBy),
+    PersistUniqueWrite (deleteBy, insertUnique, upsert),
+    entityVal,
+    insert_,
+    selectList,
  )
-import           Lib.PkgRepository              ( PkgRepo(PkgRepo, pkgRepoFileRoot)
+import Database.Persist.Postgresql (runSqlPoolNoTransaction)
-                                                , extractPkg
+import Database.Queries (upsertPackageVersion)
-                                                , getManifestLocation
+import Foundation (
-                                                , getPackages
+    Handler,
-                                                , getVersionsFor
+    RegistryCtx (..),
  )
-import           Lib.Types.AppIndex             ( PackageManifest(..)
+import Handler.Util (
-                                                , PkgId(unPkgId)
+    orThrow,
+    sendResponseText,
  )
-import           Lib.Types.Emver                ( Version(..) )
+import Lib.PkgRepository (
-import           Model                          ( Category(..)
+    PkgRepo (PkgRepo, pkgRepoFileRoot),
-                                                , Key(AdminKey, PkgRecordKey, VersionRecordKey)
+    extractPkg,
-                                                , PkgCategory(PkgCategory)
+    getManifestLocation,
-                                                , Unique(UniqueName, UniquePkgCategory)
+    getPackages,
-                                                , Upload(..)
+    getVersionsFor,
-                                                , VersionRecord(versionRecordNumber, versionRecordPkgId)
-                                                , unPkgRecordKey
  )
-import           Network.HTTP.Types             ( status403
+import Lib.Types.Core (
-                                                , status404
+    PkgId (unPkgId),
-                                                , status500
+ )
+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                      ( ($)
+import Startlude (
-                                                , (&&&)
+    Applicative (pure),
-                                                , (.)
+    Bool (..),
-                                                , (<$>)
+    Eq,
-                                                , (<<$>>)
+    Int,
-                                                , (<>)
+    Maybe (..),
-                                                , Applicative(pure)
+    Monad ((>>=)),
-                                                , Bool(..)
+    Show,
-                                                , Eq
+    SomeException (..),
-                                                , Int
+    Text,
-                                                , Maybe(..)
+    asum,
-                                                , Monad((>>=))
+    fmap,
-                                                , Show
+    fromMaybe,
-                                                , SomeException(..)
+    getCurrentTime,
-                                                , Text
+    guarded,
-                                                , asum
+    hush,
-                                                , fmap
+    isNothing,
-                                                , fromMaybe
+    liftIO,
-                                                , getCurrentTime
+    not,
-                                                , guarded
+    replicate,
-                                                , hush
+    show,
-                                                , isNothing
+    throwIO,
-                                                , liftIO
+    toS,
-                                                , not
+    traverse,
-                                                , replicate
+    void,
-                                                , show
+    when,
-                                                , throwIO
+    zip,
-                                                , toS
+    ($),
-                                                , traverse
+    (&&&),
-                                                , void
+    (.),
-                                                , when
+    (.*),
-                                                , zip
+    (<$>),
+    (<<$>>),
+    (<>),
  )
-import           System.FilePath                ( (<.>)
+import System.FilePath (
-                                                , (</>)
+    (<.>),
+    (</>),
  )
-import           UnliftIO                       ( try
+import UnliftIO (
-                                                , withTempDirectory
+    try,
+    withTempDirectory,
  )
-import           UnliftIO.Directory             ( createDirectoryIfMissing
+import UnliftIO.Directory (
-                                                , removePathForcibly
+    createDirectoryIfMissing,
-                                                , renameDirectory
+    removePathForcibly,
-                                                , renameFile
+    renameDirectory,
+    renameFile,
  )
-import           Util.Shared                    ( orThrow
+import Yesod (
-                                                , sendResponseText
+    ToJSON (..),
+    delete,
+    getsYesod,
+    logError,
+    rawRequestBody,
+    requireCheckJsonBody,
+    runDB,
  )
-import           Yesod                          ( ToJSON(..)
+import Yesod.Auth (YesodAuth (maybeAuthId))
-                                                , delete
+import Yesod.Core.Types (JSONResponse (JSONResponse))
-                                                , getsYesod
+
-                                                , logError
-                                                , rawRequestBody
-                                                , requireCheckJsonBody
-                                                , runDB
-                                                )
-import           Yesod.Auth                     ( YesodAuth(maybeAuthId) )
-import           Yesod.Core.Types               ( JSONResponse(JSONResponse) )
 
 postPkgUploadR :: Handler ()
 postPkgUploadR = do
@@ -132,12 +152,13 @@ postPkgUploadR = do
         let path = dir </> "temp" <.> "s9pk"
         runConduit $ rawRequestBody .| sinkFile path
         pool <- getsYesod appConnPool
-        PkgRepo {..} <- ask
+        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"))
+        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
@@ -153,7 +174,8 @@ 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
@@ -165,36 +187,42 @@ instance FromJSON IndexPkgReq where
     parseJSON = withObject "Index Package Request" $ \o -> do
         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
+    IndexPkgReq{..} <- requireCheckJsonBody
     manifest <- getManifestLocation indexPkgReqId indexPkgReqVersion
-    man              <- liftIO (decodeFileStrict manifest) `orThrow` sendResponseText
+    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
+        runDB $
-        $     (unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber)
+            (unPkgRecordKey . versionRecordPkgId &&& (: []) . versionRecordNumber)
                 . entityVal
                 <<$>> selectList [] []
     let inDb = fromListWith (<>) dbList
@@ -202,10 +230,6 @@ getPkgDeindexR = do
     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)
@@ -215,30 +239,35 @@ instance FromJSON AddCategoryReq where
     parseJSON = withObject "AddCategoryReq" $ \o -> do
         addCategoryDescription <- o .:? "description"
         addCategoryPriority <- o .:? "priority"
-        pure AddCategoryReq { .. }
+        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
+    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|]
     _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
+    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))
-

src/Handler/Apps.hs

@@ -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
-

src/Handler/Eos.hs

@@ -0,0 +1,5 @@
+module Handler.Eos (module X) where
+
+import Handler.Eos.V0.EosImg as X
+import Handler.Eos.V0.Latest as X
+

src/Handler/Eos/V0/EosImg.hs

@@ -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

src/Handler/Eos/V0/Latest.hs

@@ -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
+                }

src/Handler/ErrorLogs.hs

@@ -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]

src/Handler/Icons.hs

@@ -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

src/Handler/Marketplace.hs

@@ -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

src/Handler/Package.hs

@@ -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

src/Handler/Package/V0/Icon.hs

@@ -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

src/Handler/Package/V0/Index.hs

@@ -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

src/Handler/Package/V0/Info.hs

@@ -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

src/Handler/Package/V0/Instructions.hs

@@ -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

src/Handler/Package/V0/Latest.hs

@@ -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

src/Handler/Package/V0/License.hs

@@ -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

src/Handler/Package/V0/Manifest.hs

@@ -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

src/Handler/Package/V0/ReleaseNotes.hs

@@ -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

src/Handler/Package/V0/S9PK.hs

@@ -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

src/Handler/Package/V0/Version.hs

@@ -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}|])

src/Handler/Types/Api.hs

@@ -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

src/Handler/Types/Marketplace.hs

@@ -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)

src/Handler/Types/Status.hs

@@ -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

src/Handler/Util.hs

@@ -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)

src/Handler/Version.hs

@@ -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}|])

src/Lib/External/AppMgr.hs

@@ -1,158 +1,148 @@
-{-# LANGUAGE DataKinds        #-}
-{-# LANGUAGE GADTs            #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards  #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies     #-}
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Lib.External.AppMgr where
+module Lib.External.AppMgr (
+    sourceManifest,
+    getPackageHash,
+    sourceInstructions,
+    sourceLicense,
+    sourceIcon,
+) where
 
-import           Startlude                      ( ($)
+import Startlude (
-                                                , (&&)
+    Applicative (pure, (*>)),
-                                                , (<$>)
+    ByteString,
-                                                , Applicative((*>), pure)
+    Eq ((==)),
-                                                , ByteString
+    FilePath,
-                                                , Eq((==))
+    String,
-                                                , ExitCode
+    id,
-                                                , FilePath
+    stderr,
-                                                , Monad
+    throwIO,
-                                                , MonadIO(..)
+    ($),
-                                                , Monoid
+    (&&),
-                                                , String
-                                                , atomically
-                                                , id
-                                                , liftA3
-                                                , stderr
-                                                , throwIO
  )
 
-import qualified Data.ByteString.Lazy          as LBS
+import Data.ByteString.Lazy qualified as LBS
-import           Data.String.Interpolate.IsString
+import Data.String.Interpolate.IsString (
-                                                ( i )
+    i,
-import           System.Process.Typed           ( ExitCodeException(eceExitCode)
+ )
-                                                , Process
+import System.Process.Typed (
-                                                , ProcessConfig
+    ExitCodeException (eceExitCode),
-                                                , byteStringInput
+    Process,
-                                                , byteStringOutput
+    ProcessConfig,
-                                                , getStderr
+    byteStringInput,
-                                                , getStdout
+    getStdout,
-                                                , proc
+    proc,
-                                                , setEnvInherit
+    setEnvInherit,
-                                                , setStderr
+    setStderr,
-                                                , setStdin
+    setStdin,
-                                                , setStdout
+    setStdout,
-                                                , startProcess
+    startProcess,
-                                                , stopProcess
+    stopProcess,
-                                                , useHandleOpen
+    useHandleOpen,
-                                                , waitExitCodeSTM
-                                                , withProcessWait
  )
 
-import           Conduit                        ( (.|)
+import Conduit (
-                                                , ConduitT
+    ConduitT,
-                                                , runConduit
+    runConduit,
+    (.|),
  )
-import           Control.Monad.Logger           ( MonadLoggerIO
+import Control.Monad.Logger (
-                                                , logErrorSH
+    MonadLoggerIO,
+    logErrorSH,
  )
-import qualified Data.Conduit.List             as CL
+import Data.Conduit.List qualified as CL
-import           Data.Conduit.Process.Typed     ( createSource )
+import Data.Conduit.Process.Typed (createSource)
-import           GHC.IO.Exception               ( IOErrorType(NoSuchThing)
+import GHC.IO.Exception (
-                                                , IOException(ioe_description, ioe_type)
+    IOErrorType (NoSuchThing),
+    IOException (ioe_description, ioe_type),
  )
-import           Lib.Error                      ( S9Error(AppMgrE) )
+import Lib.Error (S9Error (AppMgrE))
-import           System.FilePath                ( (</>) )
+import System.FilePath ((</>))
-import           UnliftIO                       ( MonadUnliftIO
+import UnliftIO (
-                                                , bracket
+    MonadUnliftIO,
-                                                , catch
+    bracket,
+    catch,
  )
 
-readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
-readProcessWithExitCode' a b c = liftIO $ do
-    let pc =
-            setStdin (byteStringInput $ LBS.fromStrict c)
-                $ setStderr byteStringOutput
-                $ setEnvInherit
-                $ setStdout byteStringOutput
-                $ System.Process.Typed.proc a b
-    withProcessWait pc $ \process -> atomically $ liftA3 (,,)
-                                                         (waitExitCodeSTM process)
-                                                         (LBS.toStrict <$> getStdout process)
-                                                         (LBS.toStrict <$> getStderr process)
 
-readProcessInheritStderr :: forall m a
+readProcessInheritStderr ::
-                          . MonadUnliftIO m
+    forall m a.
-                         => String
+    MonadUnliftIO m =>
-                         -> [String]
+    String ->
-                         -> ByteString
+    [String] ->
-                         -> (ConduitT () ByteString m () -> m a) -- this is because we can't clean up the process in the unCPS'ed version of this
+    ByteString ->
-                         -> m a
+    (ConduitT () ByteString m () -> m a) -> -- this is because we can't clean up the process in the unCPS'ed version of this
+    m a
 readProcessInheritStderr a b c sink = do
     let pc =
-            setStdin (byteStringInput $ LBS.fromStrict c)
+            setStdin (byteStringInput $ LBS.fromStrict c) $
-                $ setEnvInherit
+                setEnvInherit $
-                $ setStderr (useHandleOpen stderr)
+                    setStderr (useHandleOpen stderr) $
-                $ setStdout createSource
+                        setStdout createSource $
-                $ System.Process.Typed.proc a b
+                            System.Process.Typed.proc a b
     withProcessTerm' pc $ \p -> sink (getStdout p)
     where
         -- We need this to deal with https://github.com/haskell/process/issues/215
-        withProcessTerm' :: (MonadUnliftIO m)
+        withProcessTerm' ::
-                         => ProcessConfig stdin stdout stderr
+            (MonadUnliftIO m) =>
-                         -> (Process stdin stdout stderr -> m a)
+            ProcessConfig stdin stdout stderr ->
-                         -> m a
+            (Process stdin stdout stderr -> m a) ->
+            m a
         withProcessTerm' cfg = bracket (startProcess cfg) $ \p -> do
             stopProcess p
-                `catch` (\e -> if ioe_type e == NoSuchThing && ioe_description e == "No child processes"
+                `catch` ( \e ->
+                            if ioe_type e == NoSuchThing && ioe_description e == "No child processes"
                                 then pure ()
                                 else throwIO e
                         )
 
-sourceManifest :: (MonadUnliftIO m, MonadLoggerIO m)
+
-               => FilePath
+sourceManifest ::
-               -> FilePath
+    (MonadUnliftIO m, MonadLoggerIO m) =>
-               -> (ConduitT () ByteString m () -> m r)
+    FilePath ->
-               -> m r
+    FilePath ->
+    (ConduitT () ByteString m () -> m r) ->
+    m r
 sourceManifest appmgrPath pkgFile sink = do
     let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "manifest", pkgFile] ""
     appmgr sink `catch` \ece ->
         $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect manifest #{pkgFile}|] (eceExitCode ece))
 
+
 sourceIcon :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> (ConduitT () ByteString m () -> m r) -> m r
 sourceIcon appmgrPath pkgFile sink = do
     let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "icon", pkgFile] ""
     appmgr sink `catch` \ece ->
         $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect icon #{pkgFile}|] (eceExitCode ece))
 
+
 getPackageHash :: (MonadUnliftIO m, MonadLoggerIO m) => FilePath -> FilePath -> m ByteString
 getPackageHash appmgrPath pkgFile = do
     let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "hash", pkgFile] ""
     appmgr (\bsSource -> runConduit $ bsSource .| CL.foldMap id) `catch` \ece ->
         $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect hash #{pkgFile}|] (eceExitCode ece))
 
-sourceInstructions :: (MonadUnliftIO m, MonadLoggerIO m)
+
-                   => FilePath
+sourceInstructions ::
-                   -> FilePath
+    (MonadUnliftIO m, MonadLoggerIO m) =>
-                   -> (ConduitT () ByteString m () -> m r)
+    FilePath ->
-                   -> m r
+    FilePath ->
+    (ConduitT () ByteString m () -> m r) ->
+    m r
 sourceInstructions appmgrPath pkgFile sink = do
     let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "instructions", pkgFile] ""
     appmgr sink `catch` \ece ->
         $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect instructions #{pkgFile}|] (eceExitCode ece))
 
-sourceLicense :: (MonadUnliftIO m, MonadLoggerIO m)
+
-              => FilePath
+sourceLicense ::
-              -> FilePath
+    (MonadUnliftIO m, MonadLoggerIO m) =>
-              -> (ConduitT () ByteString m () -> m r)
+    FilePath ->
-              -> m r
+    FilePath ->
+    (ConduitT () ByteString m () -> m r) ->
+    m r
 sourceLicense appmgrPath pkgFile sink = do
     let appmgr = readProcessInheritStderr (appmgrPath </> "embassy-sdk") ["inspect", "license", pkgFile] ""
     appmgr sink `catch` \ece ->
         $logErrorSH ece *> throwIO (AppMgrE [i|embassy-sdk inspect license #{pkgFile}|] (eceExitCode ece))
-
-sinkMem :: (Monad m, Monoid a) => ConduitT () a m () -> m a
-sinkMem c = runConduit $ c .| CL.foldMap id

src/Lib/PkgRepository.hs

@@ -1,180 +1,199 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
-{-# LANGUAGE GADTs #-}
 
 module Lib.PkgRepository where
 
-import           Conduit                        ( (.|)
+import Conduit (
-                                                , ConduitT
+    ConduitT,
-                                                , MonadResource
+    MonadResource,
-                                                , runConduit
+    runConduit,
-                                                , runResourceT
+    runResourceT,
-                                                , sinkFileCautious
+    sinkFileCautious,
-                                                , sourceFile
+    sourceFile,
+    (.|),
  )
-import           Control.Monad.Logger           ( MonadLogger
+import Control.Monad.Logger (
-                                                , MonadLoggerIO
+    MonadLogger,
-                                                , logError
+    MonadLoggerIO,
-                                                , logInfo
+    logError,
-                                                , logWarn
+    logInfo,
+    logWarn,
  )
-import           Control.Monad.Reader.Has       ( Has
+import Control.Monad.Reader.Has (
-                                                , ask
+    Has,
-                                                , asks
+    ask,
+    asks,
  )
-import           Crypto.Hash                    ( SHA256 )
+import Crypto.Hash (SHA256)
-import           Crypto.Hash.Conduit            ( hashFile )
+import Crypto.Hash.Conduit (hashFile)
-import           Data.Aeson                     ( eitherDecodeFileStrict' )
+import Data.Aeson (eitherDecodeFileStrict')
-import qualified Data.Attoparsec.Text          as Atto
+import Data.Attoparsec.Text (parseOnly)
-import           Data.Attoparsec.Text           ( parseOnly )
+import Data.Attoparsec.Text qualified as Atto
-import           Data.ByteArray.Encoding        ( Base(Base16)
+import Data.ByteArray.Encoding (
-                                                , convertToBase
+    Base (Base16),
+    convertToBase,
  )
-import           Data.ByteString                ( readFile
+import Data.ByteString (
-                                                , writeFile
+    readFile,
+    writeFile,
  )
-import qualified Data.HashMap.Strict           as HM
+import Data.HashMap.Strict qualified as HM
-import           Data.String.Interpolate.IsString
+import Data.String.Interpolate.IsString (
-                                                ( i )
+    i,
-import qualified Data.Text                     as T
-import           Data.Time                      ( getCurrentTime )
-import           Database.Esqueleto.Experimental
-                                                ( ConnectionPool
-                                                , insertUnique
-                                                , runSqlPool
  )
-import           Database.Persist               ( (=.)
+import Data.Text qualified as T
-                                                , insertKey
+import Data.Time (getCurrentTime)
-                                                , update
+import Database.Esqueleto.Experimental (
-                                                , upsert
+    ConnectionPool,
+    insertUnique,
+    runSqlPool,
  )
-import           Database.Persist.Sql           ( SqlPersistT
+import Database.Persist (
-                                                , runSqlPoolNoTransaction
+    insertKey,
+    update,
+    upsert,
+    (=.),
  )
-import           Database.PostgreSQL.Simple     ( SqlError(sqlState) )
+import Database.Persist.Sql (
-import           Lib.Error                      ( S9Error(NotFoundE) )
+    SqlPersistT,
-import qualified Lib.External.AppMgr           as AppMgr
+    runSqlPoolNoTransaction,
-import           Lib.Types.AppIndex             ( PackageDependency(..)
-                                                , PackageManifest(..)
-                                                , PkgId(..)
-                                                , packageDependencyVersion
-                                                , packageManifestDependencies
  )
-import           Lib.Types.Emver                ( Version
+import Database.PostgreSQL.Simple (SqlError (sqlState))
-                                                , VersionRange
+import Lib.Error (S9Error (NotFoundE))
-                                                , parseVersion
+import Lib.External.AppMgr qualified as AppMgr
-                                                , satisfies
+import Lib.Types.Core (
+    PkgId (..),
  )
-import           Model                          ( EntityField(EosHashHash, PkgRecordUpdatedAt)
+import Lib.Types.Emver (
-                                                , EosHash(EosHash)
+    Version,
-                                                , Key(PkgRecordKey)
+    VersionRange,
-                                                , PkgDependency(PkgDependency)
+    parseVersion,
-                                                , PkgRecord(PkgRecord)
+    satisfies,
  )
-import           Startlude                      ( ($)
+import Lib.Types.Manifest (PackageDependency (..), PackageManifest (..))
-                                                , (&&)
+import Model (
-                                                , (.)
+    EntityField (EosHashHash, PkgRecordUpdatedAt),
-                                                , (/=)
+    EosHash (EosHash),
-                                                , (<$>)
+    Key (PkgRecordKey),
-                                                , Bool(..)
+    PkgDependency (PkgDependency),
-                                                , ByteString
+    PkgRecord (PkgRecord),
-                                                , Down(..)
-                                                , Either(..)
-                                                , Eq((==))
-                                                , Exception
-                                                , FilePath
-                                                , IO
-                                                , Integer
-                                                , Maybe(..)
-                                                , MonadIO(liftIO)
-                                                , MonadReader
-                                                , Ord(compare)
-                                                , Show
-                                                , SomeException(..)
-                                                , decodeUtf8
-                                                , filter
-                                                , find
-                                                , first
-                                                , flip
-                                                , for_
-                                                , fst
-                                                , headMay
-                                                , not
-                                                , on
-                                                , partitionEithers
-                                                , pure
-                                                , show
-                                                , snd
-                                                , sortBy
-                                                , throwIO
-                                                , toS
-                                                , void
  )
-import           System.FSNotify                ( ActionPredicate
+import Startlude (
-                                                , Event(..)
+    Bool (..),
-                                                , eventPath
+    ByteString,
-                                                , watchTree
+    Down (..),
-                                                , withManager
+    Either (..),
+    Eq ((==)),
+    Exception,
+    FilePath,
+    IO,
+    Integer,
+    Maybe (..),
+    MonadIO (liftIO),
+    MonadReader,
+    Ord (compare),
+    Show,
+    SomeException (..),
+    decodeUtf8,
+    filter,
+    find,
+    first,
+    flip,
+    for_,
+    fst,
+    headMay,
+    not,
+    on,
+    partitionEithers,
+    pure,
+    show,
+    snd,
+    sortBy,
+    throwIO,
+    toS,
+    void,
+    ($),
+    (&&),
+    (.),
+    (/=),
+    (<$>),
  )
-import           System.FilePath                ( (<.>)
+import System.FSNotify (
-                                                , (</>)
+    ActionPredicate,
-                                                , takeBaseName
+    Event (..),
-                                                , takeDirectory
+    eventPath,
-                                                , takeExtension
+    watchTree,
-                                                , takeFileName
+    withManager,
  )
-import           UnliftIO                       ( MonadUnliftIO
+import System.FilePath (
-                                                , askRunInIO
+    takeBaseName,
-                                                , async
+    takeDirectory,
-                                                , catch
+    takeExtension,
-                                                , mapConcurrently_
+    takeFileName,
-                                                , newEmptyMVar
+    (<.>),
-                                                , takeMVar
+    (</>),
-                                                , tryPutMVar
-                                                , wait
  )
-import           UnliftIO.Concurrent            ( forkIO )
+import UnliftIO (
-import           UnliftIO.Directory             ( doesDirectoryExist
+    MonadUnliftIO,
-                                                , doesPathExist
+    askRunInIO,
-                                                , getFileSize
+    async,
-                                                , listDirectory
+    catch,
-                                                , removeFile
+    mapConcurrently_,
-                                                , renameFile
+    newEmptyMVar,
+    takeMVar,
+    tryPutMVar,
+    wait,
  )
-import           UnliftIO.Exception             ( handle )
+import UnliftIO.Concurrent (forkIO)
-import           Yesod.Core.Content             ( typeGif
+import UnliftIO.Directory (
-                                                , typeJpeg
+    doesDirectoryExist,
-                                                , typePlain
+    doesPathExist,
-                                                , typePng
+    getFileSize,
-                                                , typeSvg
+    listDirectory,
+    removeFile,
+    renameFile,
  )
-import           Yesod.Core.Types               ( ContentType )
+import UnliftIO.Exception (handle)
+import Yesod.Core.Content (
+    typeGif,
+    typeJpeg,
+    typePlain,
+    typePng,
+    typeSvg,
+ )
+import Yesod.Core.Types (ContentType)
+
 
 newtype ManifestParseException = ManifestParseException FilePath
-    deriving Show
+    deriving (Show)
 instance Exception ManifestParseException
 
+
 data PkgRepo = PkgRepo
     { pkgRepoFileRoot :: !FilePath
     , pkgRepoAppMgrBin :: !FilePath
     }
 
+
 newtype EosRepo = EosRepo
     { eosRepoFileRoot :: FilePath
     }
 
+
 getPackages :: (MonadIO m, MonadReader r m, Has PkgRepo r) => m [PkgId]
 getPackages = do
     root <- asks pkgRepoFileRoot
     paths <- listDirectory root
     pure $ PkgId . toS <$> paths
 
+
 getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version]
 getVersionsFor pkg = do
     root <- asks pkgRepoFileRoot
@@ -188,16 +207,21 @@ getVersionsFor pkg = do
             pure successes
         else pure []
 
+
 getViableVersions :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> VersionRange -> m [Version]
 getViableVersions pkg spec = filter (`satisfies` spec) <$> getVersionsFor pkg
 
-getBestVersion :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m)
+
-               => PkgId
+getBestVersion ::
-               -> VersionRange
+    (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) =>
-               -> Bool
+    PkgId ->
-               -> m (Maybe Version)
+    VersionRange ->
+    Bool ->
+    m (Maybe Version)
 getBestVersion pkg spec preferMin = headMay . sortBy comparator <$> getViableVersions pkg spec
-    where comparator = if preferMin then compare else compare `on` Down
+    where
+        comparator = if preferMin then compare else compare `on` Down
+
 
 loadPkgDependencies :: MonadUnliftIO m => ConnectionPool -> PackageManifest -> m ()
 loadPkgDependencies appConnPool manifest = do
@@ -205,32 +229,41 @@ loadPkgDependencies appConnPool manifest = do
     let pkgVersion = packageManifestVersion manifest
     let deps = packageManifestDependencies manifest
     time <- liftIO getCurrentTime
-    _    <- runWith appConnPool $ insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) ->
+    _ <-
+        runWith appConnPool $
+            insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) ->
                 -- 23505 is "already exists"
                 if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e
     let deps' = first PkgRecordKey <$> HM.toList deps
     for_
         deps'
-        (\d -> flip runSqlPool appConnPool $ do
+        ( \d -> flip runSqlPool appConnPool $ do
-            _ <- runWith appConnPool $ insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) ->
+            _ <-
+                runWith appConnPool $
+                    insertKey (fst d) (PkgRecord time Nothing) `catch` \(e :: SqlError) ->
                         -- 23505 is "already exists"
                         if sqlState e == "23505" then update (fst d) [PkgRecordUpdatedAt =. Just time] else throwIO e
-            insertUnique
+            insertUnique $
-                $ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d)
+                PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d)
         )
     where
         runWith :: MonadUnliftIO m => ConnectionPool -> SqlPersistT m a -> m a
         runWith pool action = runSqlPoolNoTransaction action pool Nothing
 
+
 -- extract all package assets into their own respective files
 extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m ()
 extractPkg pool fp = handle @_ @SomeException cleanup $ do
     $logInfo [i|Extracting package: #{fp}|]
-    PkgRepo { pkgRepoAppMgrBin = appmgr } <- ask
+    PkgRepo{pkgRepoAppMgrBin = appmgr} <- ask
     let pkgRoot = takeDirectory fp
     manifestTask <- async $ runResourceT $ AppMgr.sourceManifest appmgr fp $ sinkIt (pkgRoot </> "manifest.json")
     pkgHashTask <- async $ AppMgr.getPackageHash appmgr fp
-    instructionsTask <- async $ runResourceT $ AppMgr.sourceInstructions appmgr fp $ sinkIt
+    instructionsTask <-
+        async $
+            runResourceT $
+                AppMgr.sourceInstructions appmgr fp $
+                    sinkIt
                         (pkgRoot </> "instructions.md")
     licenseTask <- async $ runResourceT $ AppMgr.sourceLicense appmgr fp $ sinkIt (pkgRoot </> "license.md")
     iconTask <- async $ runResourceT $ AppMgr.sourceIcon appmgr fp $ sinkIt (pkgRoot </> "icon.tmp")
@@ -242,7 +275,8 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do
             liftIO . throwIO $ ManifestParseException (pkgRoot </> "manifest.json")
         Right manifest -> do
             wait iconTask
-            let iconDest = "icon" <.> case packageManifestIcon manifest of
+            let iconDest =
+                    "icon" <.> case packageManifestIcon manifest of
                         Nothing -> "png"
                         Just x -> case takeExtension (T.unpack x) of
                             "" -> "png"
@@ -263,16 +297,20 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do
             mapConcurrently_ (removeFile . (pkgRoot </>)) toRemove
             throwIO e
 
+
 watchEosRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has EosRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool)
 watchEosRepoRoot pool = do
     $logInfo "Starting FSNotify Watch Manager: EOS"
     root <- asks eosRepoFileRoot
     runInIO <- askRunInIO
     box <- newEmptyMVar @_ @()
-    _       <- forkIO $ liftIO $ withManager $ \watchManager -> do
+    _ <- forkIO $
+        liftIO $
+            withManager $ \watchManager -> do
                 stop <- watchTree watchManager root shouldIndex $ \evt -> do
                     let os = eventPath evt
-            void . forkIO $ runInIO $ do
+                    void . forkIO $
+                        runInIO $ do
                             indexOs pool os
                 takeMVar box
                 stop
@@ -293,44 +331,53 @@ watchEosRepoRoot pool = do
                 Right version ->
                     void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText]
 
+
 getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath
 getManifestLocation pkg version = do
     root <- asks pkgRepoFileRoot
     pure $ root </> show pkg </> show version </> "manifest.json"
 
-getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r)
+
-            => PkgId
+getManifest ::
-            -> Version
+    (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-            -> m (Integer, ConduitT () ByteString m ())
+    PkgId ->
+    Version ->
+    m (Integer, ConduitT () ByteString m ())
 getManifest pkg version = do
     manifestPath <- getManifestLocation pkg version
     n <- getFileSize manifestPath
     pure (n, sourceFile manifestPath)
 
-getInstructions :: (MonadResource m, MonadReader r m, Has PkgRepo r)
+
-                => PkgId
+getInstructions ::
-                -> Version
+    (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-                -> m (Integer, ConduitT () ByteString m ())
+    PkgId ->
+    Version ->
+    m (Integer, ConduitT () ByteString m ())
 getInstructions pkg version = do
     root <- asks pkgRepoFileRoot
     let instructionsPath = root </> show pkg </> show version </> "instructions.md"
     n <- getFileSize instructionsPath
     pure (n, sourceFile instructionsPath)
 
-getLicense :: (MonadResource m, MonadReader r m, Has PkgRepo r)
+
-           => PkgId
+getLicense ::
-           -> Version
+    (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-           -> m (Integer, ConduitT () ByteString m ())
+    PkgId ->
+    Version ->
+    m (Integer, ConduitT () ByteString m ())
 getLicense pkg version = do
     root <- asks pkgRepoFileRoot
     let licensePath = root </> show pkg </> show version </> "license.md"
     n <- getFileSize licensePath
     pure (n, sourceFile licensePath)
 
-getIcon :: (MonadResource m, MonadReader r m, Has PkgRepo r)
+
-        => PkgId
+getIcon ::
-        -> Version
+    (MonadResource m, MonadReader r m, Has PkgRepo r) =>
-        -> m (ContentType, Integer, ConduitT () ByteString m ())
+    PkgId ->
+    Version ->
+    m (ContentType, Integer, ConduitT () ByteString m ())
 getIcon pkg version = do
     root <- asks pkgRepoFileRoot
     let pkgRoot = root </> show pkg </> show version
@@ -348,12 +395,14 @@ getIcon pkg version = do
             n <- getFileSize (pkgRoot </> x)
             pure (ct, n, sourceFile (pkgRoot </> x))
 
+
 getHash :: (MonadIO m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m ByteString
 getHash pkg version = do
     root <- asks pkgRepoFileRoot
     let hashPath = root </> show pkg </> show version </> "hash.bin"
     liftIO $ readFile hashPath
 
+
 getPackage :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m (Maybe FilePath)
 getPackage pkg version = do
     root <- asks pkgRepoFileRoot

src/Lib/Registry.hs

@@ -1,47 +0,0 @@
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-
-module Lib.Registry where
-
-import           Startlude                      ( ($)
-                                                , (.)
-                                                , ConvertText(toS)
-                                                , Eq((==))
-                                                , KnownSymbol
-                                                , Proxy(Proxy)
-                                                , Read
-                                                , Show
-                                                , String
-                                                , Symbol
-                                                , readMaybe
-                                                , show
-                                                , symbolVal
-                                                )
-
-import qualified GHC.Read                       ( Read(..) )
-import qualified GHC.Show                       ( Show(..) )
-import           System.FilePath                ( (<.>)
-                                                , splitExtension
-                                                )
-import           Yesod.Core                     ( PathPiece(..) )
-
-newtype Extension (a :: Symbol) = Extension String deriving (Eq)
-type S9PK = Extension "s9pk"
-
-extension :: KnownSymbol a => Extension a -> String
-extension = symbolVal
-
-instance KnownSymbol a => Show (Extension a) where
-    show e@(Extension file) = file <.> extension e
-
-instance KnownSymbol a => Read (Extension a) where
-    readsPrec _ s = case symbolVal $ Proxy @a of
-        ""    -> [(Extension s, "")]
-        other -> [ (Extension file, "") | ext' == "" <.> other ]
-        where (file, ext') = splitExtension s
-
-instance KnownSymbol a => PathPiece (Extension a) where
-    fromPathPiece = readMaybe . toS
-    toPathPiece   = show

src/Lib/Types/AppIndex.hs

@@ -1,267 +0,0 @@
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE QuasiQuotes #-}
-module Lib.Types.AppIndex where
-
-import           Startlude
-
--- NOTE: leave eitherDecode for inline test evaluation below
-import           Control.Monad                  ( fail )
-import           Data.Aeson                     ( (.:)
-                                                , (.:?)
-                                                , FromJSON(..)
-                                                , FromJSONKey(..)
-                                                , ToJSON(..)
-                                                , ToJSONKey(..)
-                                                , withObject
-                                                )
-import qualified Data.ByteString.Lazy          as BS
-import           Data.Functor.Contravariant     ( contramap )
-import qualified Data.HashMap.Strict           as HM
-import           Data.String.Interpolate.IsString
-                                                ( i )
-import qualified Data.Text                     as T
-import           Database.Persist               ( PersistField(..)
-                                                , PersistValue(PersistText)
-                                                , SqlType(..)
-                                                )
-import           Database.Persist.Sql           ( PersistFieldSql(sqlType) )
-import           GHC.Read                       ( Read(readsPrec) )
-import           Lib.Types.Emver                ( Version
-                                                , VersionRange
-                                                )
-import           Orphans.Emver                  ( )
-import qualified Protolude.Base                as P
-                                                ( Show(..) )
-import           Web.HttpApiData                ( FromHttpApiData
-                                                , ToHttpApiData
-                                                )
-import           Yesod                          ( PathPiece(..) )
-newtype PkgId = PkgId { unPkgId :: Text }
-    deriving stock (Eq, Ord)
-    deriving newtype (FromHttpApiData, ToHttpApiData)
-instance IsString PkgId where
-    fromString = PkgId . fromString
-instance P.Show PkgId where
-    show = toS . unPkgId
-instance Read PkgId where
-    readsPrec _ s = [(PkgId $ toS s, "")]
-instance Hashable PkgId where
-    hashWithSalt n = hashWithSalt n . unPkgId
-instance FromJSON PkgId where
-    parseJSON = fmap PkgId . parseJSON
-instance ToJSON PkgId where
-    toJSON = toJSON . unPkgId
-instance FromJSONKey PkgId where
-    fromJSONKey = fmap PkgId fromJSONKey
-instance ToJSONKey PkgId where
-    toJSONKey = contramap unPkgId toJSONKey
-instance PersistField PkgId where
-    toPersistValue = PersistText . show
-    fromPersistValue (PersistText t) = Right . PkgId $ toS t
-    fromPersistValue other           = Left [i|Invalid AppId: #{other}|]
-instance PersistFieldSql PkgId where
-    sqlType _ = SqlString
-instance PathPiece PkgId where
-    fromPathPiece = fmap PkgId . fromPathPiece
-    toPathPiece   = unPkgId
-data VersionInfo = VersionInfo
-    { versionInfoVersion      :: !Version
-    , versionInfoReleaseNotes :: !Text
-    , versionInfoDependencies :: !(HM.HashMap PkgId VersionRange)
-    , versionInfoOsVersion    :: !Version
-    , versionInfoInstallAlert :: !(Maybe Text)
-    }
-    deriving (Eq, Show)
-
-data PackageDependency = PackageDependency
-    { packageDependencyOptional    :: !(Maybe Text)
-    , packageDependencyVersion     :: !VersionRange
-    , packageDependencyDescription :: !(Maybe Text)
-    }
-    deriving Show
-instance FromJSON PackageDependency where
-    parseJSON = withObject "service dependency info" $ \o -> do
-        packageDependencyOptional    <- o .:? "optional"
-        packageDependencyVersion     <- o .: "version"
-        packageDependencyDescription <- o .:? "description"
-        pure PackageDependency { .. }
-data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP
-    deriving (Show, Eq, Generic, Hashable, Read)
-data PackageManifest = PackageManifest
-    { packageManifestId               :: !PkgId
-    , packageManifestTitle            :: !Text
-    , packageManifestVersion          :: !Version
-    , packageManifestDescriptionLong  :: !Text
-    , packageManifestDescriptionShort :: !Text
-    , packageManifestReleaseNotes     :: !Text
-    , packageManifestIcon             :: !(Maybe Text)
-    , packageManifestAlerts           :: !(HM.HashMap ServiceAlert (Maybe Text))
-    , packageManifestDependencies     :: !(HM.HashMap PkgId PackageDependency)
-    , packageManifestEosVersion       :: !Version
-    }
-    deriving Show
-instance FromJSON PackageManifest where
-    parseJSON = withObject "service manifest" $ \o -> do
-        packageManifestId               <- o .: "id"
-        packageManifestTitle            <- o .: "title"
-        packageManifestVersion          <- o .: "version"
-        packageManifestDescriptionLong  <- o .: "description" >>= (.: "long")
-        packageManifestDescriptionShort <- o .: "description" >>= (.: "short")
-        packageManifestIcon             <- o .: "assets" >>= (.: "icon")
-        packageManifestReleaseNotes     <- o .: "release-notes"
-        alerts                          <- o .: "alerts"
-        a                               <- for (HM.toList alerts) $ \(key, value) -> do
-            alertType <- case readMaybe $ T.toUpper key of
-                Nothing -> fail "could not parse alert key as ServiceAlert"
-                Just t  -> pure t
-            alertDesc <- parseJSON value
-            pure (alertType, alertDesc)
-        let packageManifestAlerts = HM.fromList a
-        packageManifestDependencies <- o .: "dependencies"
-        packageManifestEosVersion   <- o .: "eos-version"
-        pure PackageManifest { .. }
-
--- >>> eitherDecode testManifest :: Either String PackageManifest
-testManifest :: BS.ByteString
-testManifest = [i|{
-  "id": "embassy-pages",
-  "title": "Embassy Pages",
-  "version": "0.1.3",
-  "description": {
-    "short": "Create Tor websites, hosted on your Embassy.",
-    "long": "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites."
-  },
-  "assets": {
-    "license": "LICENSE",
-    "icon": "icon.png",
-    "docker-images": "image.tar",
-    "instructions": "instructions.md"
-  },
-  "build": [
-    "make"
-  ],
-  "release-notes": "Upgrade to EmbassyOS v0.3.0",
-  "license": "nginx",
-  "wrapper-repo": "https://github.com/Start9Labs/embassy-pages-wrapper",
-  "upstream-repo": "http://hg.nginx.org/nginx/",
-  "support-site": null,
-  "marketing-site": null,
-  "alerts": {
-    "install": null,
-    "uninstall": null,
-    "restore": null,
-    "start": null,
-    "stop": null
-  },
-  "main": {
-    "type": "docker",
-    "image": "main",
-    "system": false,
-    "entrypoint": "/usr/local/bin/docker_entrypoint.sh",
-    "args": [],
-    "mounts": {
-      "filebrowser": "/mnt/filebrowser"
-    },
-    "io-format": "yaml",
-    "inject": false,
-    "shm-size-mb": null
-  },
-  "health-checks": {},
-  "config": {
-    "get": {
-      "type": "docker",
-      "image": "compat",
-      "system": true,
-      "entrypoint": "config",
-      "args": [
-        "get",
-        "/root"
-      ],
-      "mounts": {},
-      "io-format": "yaml",
-      "inject": false,
-      "shm-size-mb": null
-    },
-    "set": {
-      "type": "docker",
-      "image": "compat",
-      "system": true,
-      "entrypoint": "config",
-      "args": [
-        "set",
-        "/root"
-      ],
-      "mounts": {},
-      "io-format": "yaml",
-      "inject": false,
-      "shm-size-mb": null
-    }
-  },
-  "volumes": {
-    "filebrowser": {
-      "type": "pointer",
-      "package-id": "filebrowser",
-      "volume-id": "main",
-      "path": "/",
-      "readonly": true
-    }
-  },
-  "min-os-version": "0.3.0",
-  "interfaces": {
-    "main": {
-      "tor-config": {
-        "port-mapping": {
-          "80": "80"
-        }
-      },
-      "lan-config": null,
-      "ui": true,
-      "protocols": [
-        "tcp",
-        "http"
-      ]
-    }
-  },
-  "backup": {
-    "create": {
-      "type": "docker",
-      "image": "compat",
-      "system": true,
-      "entrypoint": "true",
-      "args": [],
-      "mounts": {},
-      "io-format": null,
-      "inject": false,
-      "shm-size-mb": null
-    },
-    "restore": {
-      "type": "docker",
-      "image": "compat",
-      "system": true,
-      "entrypoint": "true",
-      "args": [],
-      "mounts": {},
-      "io-format": null,
-      "inject": false,
-      "shm-size-mb": null
-    }
-  },
-  "migrations": {
-    "from": {},
-    "to": {}
-  },
-  "actions": {},
-  "dependencies": {
-    "filebrowser": {
-      "version": ">=2.14.1.1 <3.0.0",
-      "optional": null,
-      "description": "Used to upload files to serve.",
-      "critical": false,
-      "config": null
-    }
-  }
-}|]

src/Lib/Types/Core.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Lib.Types.Core where
+
+import Startlude (
+    ConvertText (toS),
+    Either (Left, Right),
+    Eq ((==)),
+    Functor (fmap),
+    Hashable (hashWithSalt),
+    IsString (..),
+    KnownSymbol,
+    Ord,
+    Proxy (Proxy),
+    Read,
+    Show,
+    String,
+    Symbol,
+    Text,
+    readMaybe,
+    show,
+    symbolVal,
+    ($),
+    (.),
+ )
+
+import Data.Aeson (
+    FromJSON (..),
+    FromJSONKey (..),
+    ToJSON (..),
+    ToJSONKey (..),
+ )
+import Data.Functor.Contravariant (contramap)
+import Data.String.Interpolate.IsString (
+    i,
+ )
+import Database.Persist (
+    PersistField (..),
+    PersistValue (PersistText),
+    SqlType (..),
+ )
+import Database.Persist.Sql (PersistFieldSql (sqlType))
+import GHC.Read (Read (readsPrec))
+import Orphans.Emver ()
+import Protolude.Base qualified as P (
+    Show (..),
+ )
+import System.FilePath (splitExtension, (<.>))
+import Web.HttpApiData (
+    FromHttpApiData,
+    ToHttpApiData,
+ )
+import Yesod (PathPiece (..))
+
+
+newtype PkgId = PkgId {unPkgId :: Text}
+    deriving stock (Eq, Ord)
+    deriving newtype (FromHttpApiData, ToHttpApiData)
+instance IsString PkgId where
+    fromString = PkgId . fromString
+instance P.Show PkgId where
+    show = toS . unPkgId
+instance Read PkgId where
+    readsPrec _ s = [(PkgId $ toS s, "")]
+instance Hashable PkgId where
+    hashWithSalt n = hashWithSalt n . unPkgId
+instance FromJSON PkgId where
+    parseJSON = fmap PkgId . parseJSON
+instance ToJSON PkgId where
+    toJSON = toJSON . unPkgId
+instance FromJSONKey PkgId where
+    fromJSONKey = fmap PkgId fromJSONKey
+instance ToJSONKey PkgId where
+    toJSONKey = contramap unPkgId toJSONKey
+instance PersistField PkgId where
+    toPersistValue = PersistText . show
+    fromPersistValue (PersistText t) = Right . PkgId $ toS t
+    fromPersistValue other = Left [i|Invalid AppId: #{other}|]
+instance PersistFieldSql PkgId where
+    sqlType _ = SqlString
+instance PathPiece PkgId where
+    fromPathPiece = fmap PkgId . fromPathPiece
+    toPathPiece = unPkgId
+
+
+newtype Extension (a :: Symbol) = Extension String deriving (Eq)
+type S9PK = Extension "s9pk"
+instance KnownSymbol a => Show (Extension a) where
+    show e@(Extension file) = file <.> extension e
+instance KnownSymbol a => Read (Extension a) where
+    readsPrec _ s = case symbolVal $ Proxy @a of
+        "" -> [(Extension s, "")]
+        other -> [(Extension file, "") | ext' == "" <.> other]
+        where
+            (file, ext') = splitExtension s
+instance KnownSymbol a => PathPiece (Extension a) where
+    fromPathPiece = readMaybe . toS
+    toPathPiece = show
+
+
+extension :: KnownSymbol a => Extension a -> String
+extension = symbolVal

src/Lib/Types/Manifest.hs

@@ -0,0 +1,211 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Lib.Types.Manifest where
+
+import Control.Monad.Fail (MonadFail (..))
+import Data.Aeson (FromJSON (..), withObject, (.:), (.:?))
+import Data.HashMap.Internal.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Data.String.Interpolate.IsString (i)
+import Data.Text qualified as T
+import Lib.Types.Core (PkgId)
+import Lib.Types.Emver (Version (..), VersionRange)
+import Startlude (ByteString, Eq, Generic, Hashable, Maybe (..), Monad ((>>=)), Read, Show, Text, for, pure, readMaybe, ($))
+
+
+data PackageManifest = PackageManifest
+    { packageManifestId :: !PkgId
+    , packageManifestTitle :: !Text
+    , packageManifestVersion :: !Version
+    , packageManifestDescriptionLong :: !Text
+    , packageManifestDescriptionShort :: !Text
+    , packageManifestReleaseNotes :: !Text
+    , packageManifestIcon :: !(Maybe Text)
+    , packageManifestAlerts :: !(HashMap ServiceAlert (Maybe Text))
+    , packageManifestDependencies :: !(HashMap PkgId PackageDependency)
+    , packageManifestEosVersion :: !Version
+    }
+    deriving (Show)
+instance FromJSON PackageManifest where
+    parseJSON = withObject "service manifest" $ \o -> do
+        packageManifestId <- o .: "id"
+        packageManifestTitle <- o .: "title"
+        packageManifestVersion <- o .: "version"
+        packageManifestDescriptionLong <- o .: "description" >>= (.: "long")
+        packageManifestDescriptionShort <- o .: "description" >>= (.: "short")
+        packageManifestIcon <- o .: "assets" >>= (.: "icon")
+        packageManifestReleaseNotes <- o .: "release-notes"
+        alerts <- o .: "alerts"
+        a <- for (HM.toList alerts) $ \(key, value) -> do
+            alertType <- case readMaybe $ T.toUpper key of
+                Nothing -> fail "could not parse alert key as ServiceAlert"
+                Just t -> pure t
+            alertDesc <- parseJSON value
+            pure (alertType, alertDesc)
+        let packageManifestAlerts = HM.fromList a
+        packageManifestDependencies <- o .: "dependencies"
+        packageManifestEosVersion <- o .: "eos-version"
+        pure PackageManifest{..}
+
+
+data PackageDependency = PackageDependency
+    { packageDependencyOptional :: !(Maybe Text)
+    , packageDependencyVersion :: !VersionRange
+    , packageDependencyDescription :: !(Maybe Text)
+    }
+    deriving (Show)
+instance FromJSON PackageDependency where
+    parseJSON = withObject "service dependency info" $ \o -> do
+        packageDependencyOptional <- o .:? "optional"
+        packageDependencyVersion <- o .: "version"
+        packageDependencyDescription <- o .:? "description"
+        pure PackageDependency{..}
+
+
+data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP
+    deriving (Show, Eq, Generic, Hashable, Read)
+
+
+-- >>> eitherDecode testManifest :: Either String PackageManifest
+testManifest :: ByteString
+testManifest =
+    [i|{
+  "id": "embassy-pages",
+  "title": "Embassy Pages",
+  "version": "0.1.3",
+  "description": {
+    "short": "Create Tor websites, hosted on your Embassy.",
+    "long": "Embassy Pages is a simple web server that uses directories inside File Browser to serve Tor websites."
+  },
+  "assets": {
+    "license": "LICENSE",
+    "icon": "icon.png",
+    "docker-images": "image.tar",
+    "instructions": "instructions.md"
+  },
+  "build": [
+    "make"
+  ],
+  "release-notes": "Upgrade to EmbassyOS v0.3.0",
+  "license": "nginx",
+  "wrapper-repo": "https://github.com/Start9Labs/embassy-pages-wrapper",
+  "upstream-repo": "http://hg.nginx.org/nginx/",
+  "support-site": null,
+  "marketing-site": null,
+  "alerts": {
+    "install": null,
+    "uninstall": null,
+    "restore": null,
+    "start": null,
+    "stop": null
+  },
+  "main": {
+    "type": "docker",
+    "image": "main",
+    "system": false,
+    "entrypoint": "/usr/local/bin/docker_entrypoint.sh",
+    "args": [],
+    "mounts": {
+      "filebrowser": "/mnt/filebrowser"
+    },
+    "io-format": "yaml",
+    "inject": false,
+    "shm-size-mb": null
+  },
+  "health-checks": {},
+  "config": {
+    "get": {
+      "type": "docker",
+      "image": "compat",
+      "system": true,
+      "entrypoint": "config",
+      "args": [
+        "get",
+        "/root"
+      ],
+      "mounts": {},
+      "io-format": "yaml",
+      "inject": false,
+      "shm-size-mb": null
+    },
+    "set": {
+      "type": "docker",
+      "image": "compat",
+      "system": true,
+      "entrypoint": "config",
+      "args": [
+        "set",
+        "/root"
+      ],
+      "mounts": {},
+      "io-format": "yaml",
+      "inject": false,
+      "shm-size-mb": null
+    }
+  },
+  "volumes": {
+    "filebrowser": {
+      "type": "pointer",
+      "package-id": "filebrowser",
+      "volume-id": "main",
+      "path": "/",
+      "readonly": true
+    }
+  },
+  "min-os-version": "0.3.0",
+  "interfaces": {
+    "main": {
+      "tor-config": {
+        "port-mapping": {
+          "80": "80"
+        }
+      },
+      "lan-config": null,
+      "ui": true,
+      "protocols": [
+        "tcp",
+        "http"
+      ]
+    }
+  },
+  "backup": {
+    "create": {
+      "type": "docker",
+      "image": "compat",
+      "system": true,
+      "entrypoint": "true",
+      "args": [],
+      "mounts": {},
+      "io-format": null,
+      "inject": false,
+      "shm-size-mb": null
+    },
+    "restore": {
+      "type": "docker",
+      "image": "compat",
+      "system": true,
+      "entrypoint": "true",
+      "args": [],
+      "mounts": {},
+      "io-format": null,
+      "inject": false,
+      "shm-size-mb": null
+    }
+  },
+  "migrations": {
+    "from": {},
+    "to": {}
+  },
+  "actions": {},
+  "dependencies": {
+    "filebrowser": {
+      "version": ">=2.14.1.1 <3.0.0",
+      "optional": null,
+      "description": "Used to upload files to serve.",
+      "critical": false,
+      "config": null
+    }
+  }
+}|]

src/Model.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -11,30 +11,37 @@
 
 module Model where
 
-import           Crypto.Hash                    ( Digest
+import Crypto.Hash (
-                                                , SHA256
+    Digest,
+    SHA256,
  )
-import           Database.Persist.TH            ( mkMigrate
+import Database.Persist.TH (
-                                                , mkPersist
+    mkMigrate,
-                                                , persistLowerCase
+    mkPersist,
-                                                , share
+    persistLowerCase,
-                                                , sqlSettings
+    share,
+    sqlSettings,
  )
-import           Lib.Types.AppIndex             ( PkgId(PkgId) )
+import Lib.Types.Core (PkgId (PkgId))
-import           Lib.Types.Emver                ( Version
+import Lib.Types.Emver (
-                                                , VersionRange
+    Version,
+    VersionRange,
  )
-import           Orphans.Cryptonite             ( )
+import Orphans.Cryptonite ()
-import           Orphans.Emver                  ( )
+import Orphans.Emver ()
-import           Startlude                      ( Eq
+import Startlude (
-                                                , Int
+    Eq,
-                                                , Show
+    Int,
-                                                , Text
+    Show,
-                                                , UTCTime
+    Text,
-                                                , Word32
+    UTCTime,
+    Word32,
  )
 
-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+
+share
+    [mkPersist sqlSettings, mkMigrate "migrateAll"]
+    [persistLowerCase|
 PkgRecord
     Id PkgId sql=pkg_id
     createdAt UTCTime

src/Startlude.hs

@@ -1,33 +1,51 @@
-module Startlude
+module Startlude (
-    ( module X
+    module X,
-    , module Startlude
+    module Startlude,
-    ) where
+) where
 
-import           Control.Arrow                 as X
+import Control.Arrow as X (
-                                                ( (&&&) )
+    (&&&),
+ )
 import Control.Error.Util as X
 import Data.Coerce as X
-import           Data.String                   as X
+import Data.String as X (
-                                                ( String
+    String,
-                                                , fromString
+    fromString,
  )
 import Data.Time.Clock as X
-import           Protolude                     as X
+import Protolude as X hiding (
-                                         hiding ( (<.>)
+    bool,
-                                                , bool
+    hush,
-                                                , hush
+    isLeft,
-                                                , isLeft
+    isRight,
-                                                , isRight
+    note,
-                                                , note
+    readMaybe,
-                                                , readMaybe
+    tryIO,
-                                                , tryIO
+    (<.>),
  )
-import qualified Protolude                     as P
+import Protolude qualified as P (
-                                                ( readMaybe )
+    readMaybe,
+ )
+
 
 id :: a -> a
 id = identity
 
-readMaybe :: Read a => Text -> Maybe a
+
-readMaybe = P.readMaybe . toS
+readMaybe :: (Read a) => Text -> Maybe a
+readMaybe = P.readMaybe
 {-# INLINE readMaybe #-}
+
+
+maximumOn :: forall a b t. (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
+maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
+
+
+maxOn :: Ord b => (a -> b) -> a -> a -> a
+maxOn f x y = if f x > f y then x else y
+
+
+{-# INLINE (.*) #-}
+infixr 8 .*
+(.*) :: (b -> c) -> (a1 -> a2 -> b) -> a1 -> a2 -> c
+(.*) = (.) . (.)

src/Util/Shared.hs

@@ -1,171 +0,0 @@
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-
-module Util.Shared where
-
-
-import qualified Data.Text                     as T
-import           Network.HTTP.Types             ( Status
-                                                , status400
-                                                )
-import           Yesod.Core                     ( MonadHandler
-                                                , MonadLogger
-                                                , MonadUnliftIO
-                                                , ToContent(toContent)
-                                                , TypedContent(TypedContent)
-                                                , addHeader
-                                                , logInfo
-                                                , lookupGetParam
-                                                , sendResponseStatus
-                                                , typePlain
-                                                )
-
-import           Conduit                        ( ConduitT
-                                                , awaitForever
-                                                , yield
-                                                )
-import           Control.Monad.Reader.Has       ( Has
-                                                , MonadReader
-                                                )
-import           Data.Semigroup                 ( (<>) )
-import           Data.String.Interpolate.IsString
-                                                ( i )
-import           Database.Esqueleto.Experimental
-                                                ( Entity
-                                                , Key
-                                                , entityVal
-                                                )
-import           Foundation                     ( Handler )
-import           GHC.List                       ( lookup )
-import           Handler.Types.Marketplace      ( PackageDependencyMetadata(..)
-                                                , PackageMetadata(..)
-                                                )
-import           Lib.PkgRepository              ( PkgRepo
-                                                , getHash
-                                                )
-import           Lib.Types.AppIndex             ( PkgId )
-import           Lib.Types.Emver                ( (<||)
-                                                , Version
-                                                , VersionRange(Any)
-                                                , satisfies
-                                                )
-import           Model                          ( Category
-                                                , PkgDependency(pkgDependencyDepId, pkgDependencyDepVersionRange)
-                                                , PkgRecord
-                                                , VersionRecord(..)
-                                                , pkgDependencyPkgId
-                                                )
-import           Startlude                      ( ($)
-                                                , (.)
-                                                , (<$>)
-                                                , Alternative((<|>))
-                                                , Applicative(pure)
-                                                , Bool(..)
-                                                , Down(Down)
-                                                , Foldable(foldr, null)
-                                                , Functor(fmap)
-                                                , Maybe(..)
-                                                , Monad((>>=))
-                                                , Ord((>))
-                                                , Text
-                                                , decodeUtf8
-                                                , filter
-                                                , fromMaybe
-                                                , headMay
-                                                , isSpace
-                                                , not
-                                                , readMaybe
-                                                , sortOn
-                                                , unless
-                                                )
-
-getVersionSpecFromQuery :: Handler VersionRange
-getVersionSpecFromQuery = do
-    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 :: Handler 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
-
-orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
-orThrow action other = action >>= \case
-    Nothing -> other
-    Just x  -> pure x
-
-filterPkgOsCompatible :: Monad m => (Version -> Bool) -> ConduitT PackageMetadata PackageMetadata m ()
-filterPkgOsCompatible p =
-    awaitForever
-        $ \PackageMetadata { packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = versions, packageMetadataPkgCategories = cats, packageMetadataPkgVersion = requestedVersion } ->
-              do
-                  let compatible = filter (p . versionRecordOsVersion . entityVal) versions
-                  unless (null compatible) $ yield PackageMetadata { packageMetadataPkgId             = pkg
-                                                                   , packageMetadataPkgVersionRecords = compatible
-                                                                   , packageMetadataPkgCategories     = cats
-                                                                   , packageMetadataPkgVersion        = requestedVersion
-                                                                   }
-
-filterDependencyOsCompatible :: (Version -> Bool) -> PackageDependencyMetadata -> PackageDependencyMetadata
-filterDependencyOsCompatible p PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDeps, packageDependencyMetadataDepPkgRecord = pkg, packageDependencyMetadataDepVersions = depVersions }
-    = do
-        let compatible = filter (p . versionRecordOsVersion . entityVal) depVersions
-        PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDeps
-                                  , packageDependencyMetadataDepPkgRecord        = pkg
-                                  , packageDependencyMetadataDepVersions         = compatible
-                                  }
-
-filterLatestVersionFromSpec :: (Monad m, MonadLogger m)
-                            => [(PkgId, VersionRange)]
-                            -> ConduitT (PkgId, [Entity VersionRecord], [Entity Category]) PackageMetadata m ()
-filterLatestVersionFromSpec versionMap = awaitForever $ \(pkgId, vs, cats) -> do
-    -- if no packages are specified, the VersionRange is implicitly `*`
-    let spec = fromMaybe Any $ lookup pkgId versionMap
-    case headMay . sortOn Down $ filter (`satisfies` spec) $ fmap (versionRecordNumber . entityVal) vs of
-        Nothing -> $logInfo [i|No version for #{pkgId} satisfying #{spec}|]
-        Just v  -> yield $ PackageMetadata { packageMetadataPkgId             = pkgId
-                                           , packageMetadataPkgVersionRecords = vs
-                                           , packageMetadataPkgCategories     = cats
-                                           , packageMetadataPkgVersion        = v
-                                           }
-
--- get best version of the dependency based on what is specified in the db (ie. what is specified in the manifest for the package)
-filterDependencyBestVersion :: MonadLogger m => PackageDependencyMetadata -> m (Maybe (Key PkgRecord, Text, Version))
-filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadataPkgDependencyRecord = pkgDepRecord, packageDependencyMetadataDepVersions = depVersions }
-    = do
-        -- get best version from VersionRange of dependency
-        let pkgId              = pkgDependencyPkgId $ entityVal pkgDepRecord
-        let depId              = pkgDependencyDepId $ entityVal pkgDepRecord
-        let versionRequirement = pkgDependencyDepVersionRange $ entityVal pkgDepRecord
-        let satisfactory = filter ((<|| versionRequirement) . versionRecordNumber) (entityVal <$> depVersions)
-        case maximumOn versionRecordNumber satisfactory of
-            Just bestVersion -> pure $ Just (depId, versionRecordTitle bestVersion, versionRecordNumber bestVersion)
-            Nothing          -> do
-                $logInfo
-                    [i|No satisfactory version of #{depId} for dependent package #{pkgId}, needs #{versionRequirement}|]
-                pure Nothing
-
-sendResponseText :: MonadHandler m => Status -> Text -> m a
-sendResponseText s = sendResponseStatus s . TypedContent typePlain . toContent
-
-maximumOn :: forall a b t . (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
-maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing
-
-maxOn :: Ord b => (a -> b) -> a -> a -> a
-maxOn f x y = if f x > f y then x else y

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-18.11
+resolver: nightly-2022-06-06
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.
@@ -40,15 +40,9 @@ packages:
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
 #
 extra-deps:
-  - protolude-0.3.0
+  - protolude-0.3.1
-  - esqueleto-3.5.1.0
   - monad-logger-extras-0.1.1.1
   - persistent-migration-0.3.0
-  - rainbow-0.34.2.2
-  - terminal-progress-bar-0.4.1
-  - wai-request-spec-0.10.2.4
-  - warp-3.3.19
-  - yesod-auth-basic-0.1.0.3
 # Override default flag values for local packages and extra-deps
 # flags: {}