finishes initial refactor

config/routes

@@ -14,9 +14,6 @@
 /package/#ApiVersion/instructions/#PkgId            InstructionsR      GET -- get instructions - can specify version with ?spec=<emver>
 /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
 /admin/v0/index                            PkgIndexR          POST !admin

src/Application.hs

@@ -1,204 +1,227 @@
-{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections         #-}
+{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns          #-}
+{-# 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           Database.Persist.Postgresql    ( createPostgresqlPool
+import Data.Default (Default (def))
-                                                , pgConnStr
+import Database.Persist.Postgresql (
-                                                , pgPoolSize
+    createPostgresqlPool,
-                                                , runMigration
+    pgConnStr,
-                                                , runSqlPool
+    pgPoolSize,
-                                                )
+    runMigration,
-import           Language.Haskell.TH.Syntax     ( qLocation )
+    runSqlPool,
-import           Network.Wai                    ( Application
+ )
-                                                , Middleware
+import Language.Haskell.TH.Syntax (qLocation)
-                                                , Request(requestHeaders)
+import Network.Wai (
-                                                , ResponseReceived
+    Application,
-                                                )
+    Middleware,
-import           Network.Wai.Handler.Warp       ( Settings
+    Request (requestHeaders),
-                                                , defaultSettings
+    ResponseReceived,
-                                                , defaultShouldDisplayException
+ )
-                                                , getPort
+import Network.Wai.Handler.Warp (
-                                                , runSettings
+    Settings,
-                                                , setHTTP2Disabled
+    defaultSettings,
-                                                , setHost
+    defaultShouldDisplayException,
-                                                , setOnException
+    getPort,
-                                                , setPort
+    runSettings,
-                                                , setTimeout
+    setHTTP2Disabled,
-                                                )
+    setHost,
-import           Network.Wai.Handler.WarpTLS    ( runTLS
+    setOnException,
-                                                , tlsSettings
+    setPort,
-                                                )
+    setTimeout,
-import           Network.Wai.Middleware.AcceptOverride
+ )
-                                                ( acceptOverride )
+import Network.Wai.Handler.WarpTLS (
-import           Network.Wai.Middleware.Autohead
+    runTLS,
-                                                ( autohead )
+    tlsSettings,
-import           Network.Wai.Middleware.Cors    ( CorsResourcePolicy(..)
+ )
-                                                , cors
+import Network.Wai.Middleware.AcceptOverride (
-                                                , simpleCorsResourcePolicy
+    acceptOverride,
-                                                )
+ )
-import           Network.Wai.Middleware.MethodOverride
+import Network.Wai.Middleware.Autohead (
-                                                ( methodOverride )
+    autohead,
-import           Network.Wai.Middleware.RequestLogger
+ )
-                                                ( Destination(Logger)
+import Network.Wai.Middleware.Cors (
-                                                , OutputFormat(..)
+    CorsResourcePolicy (..),
-                                                , destination
+    cors,
-                                                , mkRequestLogger
+    simpleCorsResourcePolicy,
-                                                , outputFormat
+ )
-                                                )
+import Network.Wai.Middleware.MethodOverride (
-import           System.IO                      ( BufferMode(..)
+    methodOverride,
-                                                , hSetBuffering
+ )
-                                                )
+import Network.Wai.Middleware.RequestLogger (
-import           System.Log.FastLogger          ( defaultBufSize
+    Destination (Logger),
-                                                , newStdoutLoggerSet
+    OutputFormat (..),
-                                                , toLogStr
+    destination,
-                                                )
+    mkRequestLogger,
-import           Yesod.Core                     ( HandlerFor
+    outputFormat,
-                                                , LogLevel(LevelError)
+ )
-                                                , Yesod(messageLoggerSource)
+import System.IO (
-                                                , logInfo
+    BufferMode (..),
-                                                , mkYesodDispatch
+    hSetBuffering,
-                                                , toWaiAppPlain
+ )
-                                                , typeOctet
+import System.Log.FastLogger (
-                                                )
+    defaultBufSize,
-import           Yesod.Core.Types               ( Logger(loggerSet) )
+    newStdoutLoggerSet,
-import           Yesod.Default.Config2          ( configSettingsYml
+    toLogStr,
-                                                , develMainHelper
+ )
-                                                , getDevSettings
+import Yesod.Core (
-                                                , loadYamlSettings
+    HandlerFor,
-                                                , loadYamlSettingsArgs
+    LogLevel (LevelError),
-                                                , makeYesodLogger
+    Yesod (messageLoggerSource),
-                                                , useEnv
+    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 Data.List (lookup)
+import Data.String.Interpolate.IsString (
+    i,
+ )
+import Database.Persist.Migration qualified
+import Database.Persist.Migration.Postgres qualified
+import Database.Persist.Sql (SqlBackend)
+import Foundation (
+    Handler,
+    RegistryCtx (..),
+    Route (..),
+    resourcesRegistryCtx,
+    setWebProcessThreadId,
+    unsafeHandler,
+ )
+import Handler.Admin (
+    deleteCategoryR,
+    deletePkgCategorizeR,
+    getPkgDeindexR,
+    postCategoryR,
+    postPkgCategorizeR,
+    postPkgDeindexR,
+    postPkgIndexR,
+    postPkgUploadR,
+ )
+import Handler.Eos (getEosR, getEosVersionR)
+import Handler.Package
+import Lib.PkgRepository (watchEosRepoRoot)
+import Lib.Ssl (
+    doesSslNeedRenew,
+    renewSslCerts,
+    setupSsl,
+ )
+import Migration (manualMigration)
+import Model (migrateAll)
+import Network.HTTP.Types.Header (hOrigin)
+import Network.Wai.Middleware.Gzip (
+    GzipFiles (GzipCompress),
+    GzipSettings (gzipCheckMime, gzipFiles),
+    defaultCheckMime,
+    gzip,
+ )
+import Network.Wai.Middleware.RequestLogger.JSON (
+    formatAsJSONWithHeaders,
+ )
+import Settings (
+    AppPort,
+    AppSettings (..),
+    configSettingsYmlValue,
+ )
+import System.Directory (createDirectoryIfMissing)
+import System.Posix.Process (exitImmediately)
+import System.Time.Extra (sleep)
+import Yesod (YesodPersist (runDB))
 
-import           Control.Lens                   ( both )
-import           Data.List                      ( lookup )
-import           Data.String.Interpolate.IsString
-                                                ( 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
-                                                , deletePkgCategorizeR
-                                                , getPkgDeindexR
-                                                , postCategoryR
-                                                , postPkgCategorizeR
-                                                , postPkgDeindexR
-                                                , postPkgIndexR
-                                                , postPkgUploadR
-                                                )
-import           Handler.ErrorLogs              ( postErrorLogsR )
-import           Handler.Marketplace            ( getEosR
-                                                , getEosVersionR
-                                                )
-import           Handler.Package
-import           Lib.PkgRepository              ( watchEosRepoRoot )
-import           Lib.Ssl                        ( doesSslNeedRenew
-                                                , renewSslCerts
-                                                , setupSsl
-                                                )
-import           Migration                      ( manualMigration )
-import           Model                          ( migrateAll )
-import           Network.HTTP.Types.Header      ( hOrigin )
-import           Network.Wai.Middleware.Gzip    ( GzipFiles(GzipCompress)
-                                                , GzipSettings(gzipCheckMime, gzipFiles)
-                                                , defaultCheckMime
-                                                , gzip
-                                                )
-import           Network.Wai.Middleware.RequestLogger.JSON
-                                                ( formatAsJSONWithHeaders )
-import           Settings                       ( AppPort
-                                                , AppSettings(..)
-                                                , 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
@@ -207,20 +230,20 @@ makeFoundation :: AppSettings -> IO RegistryCtx
 makeFoundation appSettings = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
-    appLogger            <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
+    appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
 
     appWebServerThreadId <- newEmptyMVar
-    appShouldRestartWeb  <- newMVar False
+    appShouldRestartWeb <- newMVar False
 
     -- We need a log function to create a connection pool. We need a connection
     -- pool to create our foundation. And we need our foundation to get a
     -- 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
@@ -228,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
 
@@ -242,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
@@ -254,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
@@ -265,78 +290,86 @@ makeApplication foundation = do
         . gzip gzipSettings
         $ appPlain
 
+
 dynamicCorsResourcePolicy :: Request -> Maybe CorsResourcePolicy
 dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders req
     where
-        policy o = simpleCorsResourcePolicy
+        policy o =
-            { corsOrigins        = (\o' -> ([o'], True)) <$> o
+            simpleCorsResourcePolicy
-            , corsMethods        = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"]
+                { corsOrigins = (\o' -> ([o'], True)) <$> o
-            , corsRequestHeaders = [ "app-version"
+                , corsMethods = ["GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT", "OPTIONS", "PATCH"]
-                                   , "Accept"
+                , corsRequestHeaders =
-                                   , "Accept-Charset"
+                    [ "app-version"
-                                   , "Accept-Encoding"
+                    , "Accept"
-                                   , "Accept-Language"
+                    , "Accept-Charset"
-                                   , "Accept-Ranges"
+                    , "Accept-Encoding"
-                                   , "Age"
+                    , "Accept-Language"
-                                   , "Allow"
+                    , "Accept-Ranges"
-                                   , "Authorization"
+                    , "Age"
-                                   , "Cache-Control"
+                    , "Allow"
-                                   , "Connection"
+                    , "Authorization"
-                                   , "Content-Encoding"
+                    , "Cache-Control"
-                                   , "Content-Language"
+                    , "Connection"
-                                   , "Content-Length"
+                    , "Content-Encoding"
-                                   , "Content-Location"
+                    , "Content-Language"
-                                   , "Content-MD5"
+                    , "Content-Length"
-                                   , "Content-Range"
+                    , "Content-Location"
-                                   , "Content-Type"
+                    , "Content-MD5"
-                                   , "Date"
+                    , "Content-Range"
-                                   , "ETag"
+                    , "Content-Type"
-                                   , "Expect"
+                    , "Date"
-                                   , "Expires"
+                    , "ETag"
-                                   , "From"
+                    , "Expect"
-                                   , "Host"
+                    , "Expires"
-                                   , "If-Match"
+                    , "From"
-                                   , "If-Modified-Since"
+                    , "Host"
-                                   , "If-None-Match"
+                    , "If-Match"
-                                   , "If-Range"
+                    , "If-Modified-Since"
-                                   , "If-Unmodified-Since"
+                    , "If-None-Match"
-                                   , "Last-Modified"
+                    , "If-Range"
-                                   , "Location"
+                    , "If-Unmodified-Since"
-                                   , "Max-Forwards"
+                    , "Last-Modified"
-                                   , "Pragma"
+                    , "Location"
-                                   , "Proxy-Authenticate"
+                    , "Max-Forwards"
-                                   , "Proxy-Authorization"
+                    , "Pragma"
-                                   , "Range"
+                    , "Proxy-Authenticate"
-                                   , "Referer"
+                    , "Proxy-Authorization"
-                                   , "Retry-After"
+                    , "Range"
-                                   , "Server"
+                    , "Referer"
-                                   , "TE"
+                    , "Retry-After"
-                                   , "Trailer"
+                    , "Server"
-                                   , "Transfer-Encoding"
+                    , "TE"
-                                   , "Upgrade"
+                    , "Trailer"
-                                   , "User-Agent"
+                    , "Transfer-Encoding"
-                                   , "Vary"
+                    , "Upgrade"
-                                   , "Via"
+                    , "User-Agent"
-                                   , "WWW-Authenticate"
+                    , "Vary"
-                                   , "Warning"
+                    , "Via"
-                                   , "Content-Disposition"
+                    , "WWW-Authenticate"
-                                   , "MIME-Version"
+                    , "Warning"
-                                   , "Cookie"
+                    , "Content-Disposition"
-                                   , "Set-Cookie"
+                    , "MIME-Version"
-                                   , "Origin"
+                    , "Cookie"
-                                   , "Prefer"
+                    , "Set-Cookie"
-                                   , "Preference-Applied"
+                    , "Origin"
-                                   ]
+                    , "Prefer"
-            , corsIgnoreFailures = True
+                    , "Preference-Applied"
-            }
+                    ]
+                , corsIgnoreFailures = True
+                }
+
 
 makeLogWare :: RegistryCtx -> IO Middleware
-makeLogWare foundation = mkRequestLogger def
+makeLogWare foundation =
-    { outputFormat = if appDetailedRequestLogging $ appSettings foundation
+    mkRequestLogger
-                         then Detailed True
+        def
-                         else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders
+            { outputFormat =
-    , destination  = Logger $ loggerSet $ appLogger foundation
+                if appDetailedRequestLogging $ appSettings foundation
-    }
+                    then Detailed True
+                    else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders
+            , destination = Logger $ loggerSet $ appLogger foundation
+            }
+
 
 makeAuthWare :: RegistryCtx -> Middleware
 makeAuthWare _ app req res = next
@@ -344,40 +377,47 @@ makeAuthWare _ app req res = next
         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 ->
-            foundation
+                        when (defaultShouldDisplayException e) $
-            (appLogger foundation)
+                            messageLoggerSource
-            $(qLocation >>= liftLoc)
+                                foundation
-            "yesod"
+                                (appLogger foundation)
-            LevelError
+                                $(qLocation >>= liftLoc)
-            (toLogStr $ "Exception from Warp: " ++ show e))
+                                "yesod"
-      (setHTTP2Disabled defaultSettings)
+                                LevelError
+                                (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 <-
-        -- fall back to compile-time values, set to [] to require values at runtime
+        loadYamlSettingsArgs
-                                     [configSettingsYmlValue]
+            -- fall back to compile-time values, set to [] to require values at runtime
-
+            [configSettingsYmlValue]
-        -- allow environment variables to override
+            -- allow environment variables to override
-                                     useEnv
+            useEnv
 
     -- Generate the foundation from the settings
     makeFoundation settings >>= startApp
 
+
 startApp :: RegistryCtx -> IO ()
 startApp foundation = do
     when (sslAuto . appSettings $ foundation) $ do
@@ -387,33 +427,38 @@ startApp foundation = do
         runLog $ $logInfo "SSL Setup Complete"
 
         -- certbot renew loop
-        void . forkIO $ forever $ flip runReaderT foundation $ do
+        void . forkIO $
-            shouldRenew <- doesSslNeedRenew
+            forever $
-            runLog $ $logInfo [i|Checking if SSL Certs should be renewed: #{shouldRenew}|]
+                flip runReaderT foundation $ do
-            when shouldRenew $ do
+                    shouldRenew <- doesSslNeedRenew
-                runLog $ $logInfo "Renewing SSL Certs."
+                    runLog $ $logInfo [i|Checking if SSL Certs should be renewed: #{shouldRenew}|]
-                renewSslCerts
+                    when shouldRenew $ do
-                liftIO $ restartWeb foundation
+                        runLog $ $logInfo "Renewing SSL Certs."
-            liftIO $ sleep 86_400
+                        renewSslCerts
+                        liftIO $ restartWeb foundation
+                    liftIO $ sleep 86_400
 
     startWeb foundation
     where
         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 <-
-                then runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app
+                async $
-                else runSettings (warpSettings appPort foundation) app
+                    if sslAuto
+                        then runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app
+                        else runSettings (warpSettings appPort foundation) app
 
             setWebProcessThreadId (asyncThreadId action, asyncThreadId torAction) foundation
             res <- waitEitherCatchCancel action torAction
@@ -439,52 +484,60 @@ 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)
 --------------------------------------------------------------
 
 getApplicationRepl :: IO (Int, RegistryCtx, Application)
 getApplicationRepl = do
-    settings   <- getAppSettings
+    settings <- getAppSettings
     foundation <- getAppSettings >>= makeFoundation
-    wsettings  <- getDevSettings $ warpSettings (appPort settings) foundation
+    wsettings <- getDevSettings $ warpSettings (appPort settings) foundation
-    app1       <- makeApplication foundation
+    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
-    settings   <- getAppSettings
+    settings <- getAppSettings
     foundation <- makeFoundation settings
-    app        <- makeApplication foundation
+    app <- makeApplication foundation
-    wsettings  <- getDevSettings $ warpSettings port foundation
+    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
 ---------------------------------------------
@@ -493,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/Database/Marketplace.hs

@@ -1,9 +1,10 @@
+{-# LANGUAGE BlockArguments #-}
+{-# HLINT ignore "Fuse on/on" #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
-{-# HLINT ignore "Fuse on/on" #-}
-
 module Database.Marketplace where
 
 import Conduit (
@@ -82,25 +83,26 @@ import Startlude (
     Maybe (..),
     Monad,
     MonadIO,
+    NonEmpty,
     ReaderT,
     Show,
     Text,
     headMay,
-    lift,
     snd,
     sortOn,
     ($),
     ($>),
     (.),
     (<$>),
+    (<<$>>),
  )
 
 
 data PackageMetadata = PackageMetadata
     { packageMetadataPkgId :: !PkgId
-    , packageMetadataPkgVersionRecords :: ![Entity VersionRecord]
+    , packageMetadataPkgVersionRecords :: !(NonEmpty VersionRecord)
-    , packageMetadataPkgCategories :: ![Entity Category]
     , packageMetadataPkgVersion :: !Version
+    , packageMetadataPkgCategories :: ![Category]
     }
     deriving (Eq, Show)
 data PackageDependencyMetadata = PackageDependencyMetadata
@@ -111,12 +113,12 @@ data PackageDependencyMetadata = PackageDependencyMetadata
     deriving (Eq, Show)
 
 
-searchServices ::
+serviceQuerySource ::
     (MonadResource m, MonadIO m) =>
     Maybe Text ->
     Text ->
     ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
-searchServices Nothing query = selectSource $ do
+serviceQuerySource Nothing query = selectSource $ do
     service <- from $ table @VersionRecord
     where_
         ( (service ^. VersionRecordDescShort `ilike` (%) ++. val query ++. (%))
@@ -130,7 +132,7 @@ searchServices Nothing query = selectSource $ do
         , desc (service ^. VersionRecordUpdatedAt)
         ]
     pure service
-searchServices (Just category) query = selectSource $ do
+serviceQuerySource (Just category) query = selectSource $ do
     services <-
         from
             ( do
@@ -162,8 +164,8 @@ searchServices (Just category) query = selectSource $ do
     pure services
 
 
-getPkgData :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
+getPkgDataSource :: (MonadResource m, MonadIO m) => [PkgId] -> ConduitT () (Entity VersionRecord) (ReaderT SqlBackend m) ()
-getPkgData pkgs = selectSource $ do
+getPkgDataSource pkgs = selectSource $ do
     pkgData <- from $ table @VersionRecord
     where_ (pkgData ^. VersionRecordPkgId `in_` valList (PkgRecordKey <$> pkgs))
     pure pkgData
@@ -188,29 +190,24 @@ getPkgDependencyData pkgId pkgVersion = select $ do
         )
 
 
-zipCategories ::
+getCategoriesFor ::
     MonadUnliftIO m =>
-    ConduitT
+    PkgId ->
-        (PkgId, [Entity VersionRecord])
+    ReaderT SqlBackend m [Category]
-        (PkgId, [Entity VersionRecord], [Entity Category])
+getCategoriesFor pkg =
-        (ReaderT SqlBackend m)
+    entityVal <<$>> select do
-        ()
+        (sc :& cat) <-
-zipCategories = awaitForever $ \(pkg, vers) -> do
+            from $
-    raw <- lift $
+                table @PkgCategory
-        select $ do
+                    `innerJoin` table @Category
-            (sc :& cat) <-
+                    `on` (\(sc :& cat) -> sc ^. PkgCategoryCategoryId ==. cat ^. CategoryId)
-                from $
+        where_ (sc ^. PkgCategoryPkgId ==. val (PkgRecordKey pkg))
-                    table @PkgCategory
+        pure cat
-                        `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) ()
+    ConduitT (Entity VersionRecord) (PkgId, [VersionRecord]) (ReaderT SqlBackend m) ()
 collateVersions = awaitForever $ \v0 -> do
     let pkg = unPkgRecordKey . versionRecordPkgId $ entityVal v0
     let pull = do
@@ -221,7 +218,7 @@ collateVersions = awaitForever $ \v0 -> 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)
+    yield (pkg, fmap entityVal $ v0 : ls)
 
 
 zipDependencyVersions ::

src/Foundation.hs

@@ -62,7 +62,6 @@ import Database.Persist.Sql (
     SqlPersistT,
     runSqlPool,
  )
-import Lib.Registry (S9PK)
 import Yesod.Core (
     AuthResult (Authorized, Unauthorized),
     LogLevel (..),
@@ -112,7 +111,7 @@ import Lib.PkgRepository (
     EosRepo,
     PkgRepo,
  )
-import Lib.Types.AppIndex (PkgId)
+import Lib.Types.AppIndex (PkgId, S9PK)
 import Model (
     Admin (..),
     Key (AdminKey),

src/Handler/Apps.hs

@@ -1,121 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Handler.Apps where
-
-import Startlude (
-    Applicative (pure),
-    FilePath,
-    Maybe (..),
-    Monad ((>>=)),
-    Show,
-    String,
-    show,
-    void,
-    ($),
-    (.),
- )
-
-import Control.Monad.Logger (logError)
-import Data.Text qualified as T
-import GHC.Show qualified (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 Handler.Util (addPackageHeader, getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
-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)
-
-
-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

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

@@ -3,11 +3,25 @@
 module Handler.Eos.V0.Latest where
 
 import Data.Aeson (ToJSON (toJSON), object, (.=))
-import Handler.Package.V0.ReleaseNotes (ReleaseNotes)
+import Data.HashMap.Strict qualified as HM
-import Lib.Types.Emver (Version)
+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 (Eq, Generic, Show, Text, (.))
+import Startlude (Bool (..), Down (..), Eq, Generic, Maybe, Ord ((<)), Show, Text, const, filter, fst, head, maybe, pure, sortOn, ($), (&&&), (.), (<$>), (<&>))
-import Yesod (ToContent (toContent), ToTypedContent (..))
+import Yesod (ToContent (toContent), ToTypedContent (..), YesodPersist (runDB))
+import Yesod.Core.Types (JSONResponse (..))
 
 
 data EosRes = EosRes
@@ -22,4 +36,30 @@ instance ToJSON EosRes where
 instance ToContent EosRes where
     toContent = toContent . toJSON
 instance ToTypedContent EosRes where
-    toTypedContent = toTypedContent . toJSON
+    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,18 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
-
-module Handler.Icons where
-
-import Data.Aeson (FromJSON, ToJSON)
-import Startlude (Eq, Generic, Read, Show)
-
-
-data IconType = PNG | JPG | JPEG | SVG
-    deriving (Eq, Show, Generic, Read)
-instance ToJSON IconType
-instance FromJSON IconType

src/Handler/Marketplace.hs

@@ -1,306 +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 Data.Attoparsec.Text qualified as Atto
-
-import Data.Attoparsec.Text (
-    Parser,
-    parseOnly,
- )
-import Data.ByteArray.Encoding (
-    Base (..),
-    convertToBase,
- )
-import Data.ByteString.Base64 (encodeBase64)
-import Data.ByteString.Lazy qualified as LBS
-import Data.Conduit.List qualified as CL
-import Data.HashMap.Strict qualified as HM
-import Data.List (
-    lookup,
-    sortOn,
- )
-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 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.Util (getVersionSpecFromQuery)
-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,
- )
-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

src/Handler/Package.hs

@@ -1,14 +1,18 @@
 module Handler.Package where
 
 import Foundation (Handler)
-import Handler.Package.V0.Index (PackageListRes)
+import Handler.Package.V0.Icon qualified
-import Handler.Package.V0.Info (InfoRes)
+import Handler.Package.V0.Index (PackageListRes, getPackageIndexR)
-import Handler.Package.V0.Latest (VersionLatestRes)
+import Handler.Package.V0.Info (InfoRes, getInfoR)
-import Handler.Package.V0.ReleaseNotes (ReleaseNotes)
+import Handler.Package.V0.Instructions qualified
-import Handler.Types.Api (ApiVersion)
+import Handler.Package.V0.Latest (VersionLatestRes, getVersionLatestR)
-import Handler.Types.Status (AppVersionRes)
+import Handler.Package.V0.License qualified
-import Lib.Registry (S9PK)
+import Handler.Package.V0.Manifest qualified
-import Lib.Types.AppIndex (PkgId)
+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.AppIndex (PkgId, S9PK)
 import Yesod.Core.Types (
     JSONResponse,
     TypedContent,
@@ -16,40 +20,40 @@ import Yesod.Core.Types (
 
 
 getInfoR :: ApiVersion -> Handler (JSONResponse InfoRes)
-getInfoR = _
+getInfoR _ = Handler.Package.V0.Info.getInfoR
 
 
-getPackageListR :: ApiVersion -> Handler PackageListRes
+getPackageIndexR :: ApiVersion -> Handler PackageListRes
-getPackageListR = _
+getPackageIndexR _ = Handler.Package.V0.Index.getPackageIndexR
 
 
 getVersionLatestR :: ApiVersion -> Handler VersionLatestRes
-getVersionLatestR = _
+getVersionLatestR _ = Handler.Package.V0.Latest.getVersionLatestR
 
 
 getAppR :: ApiVersion -> S9PK -> Handler TypedContent
-getAppR = _
+getAppR _ = Handler.Package.V0.S9PK.getAppR
 
 
 getAppManifestR :: ApiVersion -> PkgId -> Handler TypedContent
-getAppManifestR = _
+getAppManifestR _ = Handler.Package.V0.Manifest.getAppManifestR
 
 
 getReleaseNotesR :: ApiVersion -> PkgId -> Handler ReleaseNotes
-getReleaseNotesR = _
+getReleaseNotesR _ = Handler.Package.V0.ReleaseNotes.getReleaseNotesR
 
 
 getIconsR :: ApiVersion -> PkgId -> Handler TypedContent
-getIconsR = _
+getIconsR _ = Handler.Package.V0.Icon.getIconsR
 
 
 getLicenseR :: ApiVersion -> PkgId -> Handler TypedContent
-getLicenseR = _
+getLicenseR _ = Handler.Package.V0.License.getLicenseR
 
 
 getInstructionsR :: ApiVersion -> PkgId -> Handler TypedContent
-getInstructionsR = _
+getInstructionsR _ = Handler.Package.V0.Instructions.getInstructionsR
 
 
 getPkgVersionR :: ApiVersion -> PkgId -> Handler AppVersionRes
-getPkgVersionR = _
+getPkgVersionR _ = Handler.Package.V0.Version.getPkgVersionR

src/Handler/Package/V0/Index.hs

@@ -3,28 +3,36 @@
 
 module Handler.Package.V0.Index where
 
-import Conduit (runConduit, (.|))
+import Conduit (concatMapC, dropC, mapC, mapMC, runConduit, sinkList, takeC, (.|))
 import Control.Monad.Reader.Has (Functor (fmap), Has, Monad ((>>=)), MonadReader, ReaderT (runReaderT), ask)
-import Data.Aeson (FromJSON (..), ToJSON (..), Value, decode, object, withObject, (.:), (.=))
+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.Marketplace (PackageMetadata (..), collateVersions, getPkgDependencyData, searchServices, zipDependencyVersions)
+import Database.Marketplace (PackageMetadata (..), collateVersions, getCategoriesFor, getPkgDataSource, getPkgDependencyData, serviceQuerySource, zipDependencyVersions)
-import Database.Persist (Entity (..), Key)
+import Database.Persist (Key)
 import Database.Persist.Sql (SqlBackend)
 import Foundation (Handler, Route (InstructionsR, LicenseR))
+import Handler.Types.Api (ApiVersion (..))
+import Handler.Util (basicRender)
+import Lib.Conduit (filterDependencyBestVersion, filterDependencyOsCompatible, selectLatestVersionFromSpec)
 import Lib.Error (S9Error (..))
 import Lib.PkgRepository (PkgRepo, getIcon, getManifest)
 import Lib.Types.AppIndex (PkgId)
-import Lib.Types.Emver (Version, VersionRange, parseRange, satisfies)
+import Lib.Types.Emver (Version, VersionRange (..), parseRange, satisfies)
 import Model (Category (..), Key (..), PkgRecord (..), VersionRecord (..))
+import Network.HTTP.Types (status400)
+import Protolude.Unsafe (unsafeFromJust)
 import Settings (AppSettings)
-import Startlude (Bool (..), ByteString, Either (..), Eq, Generic, Int, Maybe (..), MonadIO, Read, Show, Text, Traversable (traverse), catMaybes, const, flip, fromMaybe, id, pure, snd, ($), (.), (<$>), (<&>))
+import Startlude (Applicative ((*>)), Bifunctor (second), Bool (..), ByteString, Either (..), Eq, Generic, Int, Maybe (..), MonadIO, Num ((*), (-)), Read, Show, Text, Traversable (traverse), catMaybes, const, encodeUtf8, filter, flip, fromMaybe, id, nonEmpty, pure, readMaybe, show, snd, ($), (&&&), (.), (<$>), (<&>))
-import Yesod (MonadLogger, MonadResource, ToContent (..), ToTypedContent (..), YesodPersist (runDB), lookupGetParam)
+import UnliftIO (mapConcurrently)
+import Yesod (MonadLogger, MonadResource, ToContent (..), ToTypedContent (..), YesodPersist (runDB), lookupGetParam, sendResponseStatus)
 import Yesod.Core (logWarn)
 
 
@@ -108,8 +116,8 @@ data OrderArrangement = ASC | DESC
     deriving (Eq, Show, Read)
 
 
-getPackageListR :: Handler PackageListRes
+getPackageIndexR :: Handler PackageListRes
-getPackageListR = do
+getPackageIndexR = do
     osPredicate <-
         getOsVersionQuery <&> \case
             Nothing -> const True
@@ -124,27 +132,39 @@ getPackageListR = do
             query <- T.strip . fromMaybe (packageListQuery defaults) <$> lookupGetParam "query"
             runDB $
                 runConduit $
-                    searchServices category query
+                    serviceQuerySource category query
+                        -- group conduit pipeline by pkg id
                         .| collateVersions
-                        .| zipCategories
+                        -- filter out versions of apps that are incompatible with the OS predicate
-                        -- empty list since there are no requested packages in this case
+                        .| mapC (second (filter (osPredicate . versionRecordOsVersion)))
-                        .| filterLatestVersionFromSpec []
+                        -- prune empty version sets
-                        .| filterPkgOsCompatible osPredicate
+                        .| concatMapC (\(pkgId, vs) -> (pkgId,) <$> nonEmpty vs)
+                        -- grab the latest matching version if it exists
+                        .| concatMapC (\(a, b) -> (a,b,) <$> (selectLatestVersionFromSpec (const Any) 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
         Just packages' -> do
             -- for each item in list get best available from version range
-            let vMap = (packageReqId &&& packageReqVersion) <$> packages'
+            let packageRanges = fromMaybe None . (flip lookup $ (packageReqId &&& packageReqVersion) <$> packages')
             runDB
                 -- TODO could probably be better with sequenceConduits
                 . runConduit
-                $ getPkgData (packageReqId <$> packages')
+                $ getPkgDataSource (packageReqId <$> packages')
+                    -- group conduit pipeline by pkg id
                     .| collateVersions
-                    .| zipCategories
+                    -- filter out versions of apps that are incompatible with the OS predicate
-                    .| filterLatestVersionFromSpec vMap
+                    .| mapC (second (filter (osPredicate . versionRecordOsVersion)))
-                    .| filterPkgOsCompatible osPredicate
+                    -- 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)
                     .| 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
@@ -165,7 +185,8 @@ getPackageListR = do
                     Left _ ->
                         do
                             let e = InvalidParamsE "get:ids" ids
-                            $logWarn (show e) sendResponseStatus status400 e
+                            $logWarn (show e)
+                            sendResponseStatus status400 e
                     Right a -> pure a
         getCategoryQuery :: Handler (Maybe Text)
         getCategoryQuery =
@@ -175,7 +196,8 @@ getPackageListR = do
                     Nothing ->
                         do
                             let e = InvalidParamsE "get:category" c
-                            $logWarn (show e) sendResponseStatus status400 e
+                            $logWarn (show e)
+                            sendResponseStatus status400 e
                     Just t -> pure $ Just t
         getPageQuery :: Handler Int
         getPageQuery =
@@ -185,7 +207,8 @@ getPackageListR = do
                     Nothing ->
                         do
                             let e = InvalidParamsE "get:page" p
-                            $logWarn (show e) sendResponseStatus status400 e
+                            $logWarn (show e)
+                            sendResponseStatus status400 e
                     Just t -> pure $ case t of
                         0 -> 1 -- disallow page 0 so offset is not negative
                         _ -> t
@@ -197,7 +220,8 @@ getPackageListR = do
                     Nothing ->
                         do
                             let e = InvalidParamsE "get:per-page" pp
-                            $logWarn (show e) sendResponseStatus status400 e
+                            $logWarn (show e)
+                            sendResponseStatus status400 e
                     Just l -> pure l
         getOsVersionQuery :: Handler (Maybe VersionRange)
         getOsVersionQuery =
@@ -207,7 +231,8 @@ getPackageListR = do
                     Left _ ->
                         do
                             let e = InvalidParamsE "get:eos-version-compat" osv
-                            $logWarn (show e) sendResponseStatus status400 e
+                            $logWarn (show e)
+                            sendResponseStatus status400 e
                     Right v -> pure $ Just v
         getPackageDependencies ::
             (MonadIO m, MonadLogger m) =>
@@ -225,13 +250,13 @@ getPackageListR = do
         getPackageDependencies osPredicate PackageMetadata{packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = pkgVersions, packageMetadataPkgCategories = pkgCategories, packageMetadataPkgVersion = pkgVersion} =
             do
                 let pkgId = PkgRecordKey pkg
-                let pkgVersions' = versionRecordNumber . entityVal <$> pkgVersions
+                let pkgVersions' = versionRecordNumber <$> pkgVersions
-                let pkgCategories' = entityVal <$> pkgCategories
+                let pkgCategories' = 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)
+                pure (pkgId, pkgCategories', NE.toList pkgVersions', pkgVersion, res)
         constructPackageListApiRes ::
             (MonadResource m, MonadReader r m, Has AppSettings r, Has PkgRepo r) =>
             ( Key PkgRecord
@@ -255,8 +280,8 @@ getPackageListR = do
                     { 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
+                    , packageResInstructions = basicRender $ InstructionsR V0 pkgId
-                    , packageResLicense = basicRender $ LicenseR _ pkgId
+                    , packageResLicense = basicRender $ LicenseR V0 pkgId
                     , packageResVersions = pkgVersions
                     , packageResDependencies = HM.fromList deps
                     }

src/Handler/Package/V0/Info.hs

@@ -1,8 +1,13 @@
 module Handler.Package.V0.Info where
 
 import Data.Aeson (ToJSON (..))
-import Startlude (Generic, Show, Text, (.))
+import Database.Esqueleto.Experimental (Entity (..), asc, from, orderBy, select, table, (^.))
-import Yesod (ToContent (..), ToTypedContent (..))
+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
@@ -15,3 +20,14 @@ 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/Latest.hs

@@ -1,11 +1,19 @@
 module Handler.Package.V0.Latest where
 
-import Data.Aeson (ToJSON (..))
+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.Marketplace (fetchLatestApp)
+import Foundation (Handler)
+import Lib.Error (S9Error (..))
 import Lib.Types.AppIndex (PkgId)
 import Lib.Types.Emver (Version)
-import Startlude (Generic, Maybe, Show, (.))
+import Model (Key (..), VersionRecord (..))
-import Yesod (ToContent (..), ToTypedContent (..))
+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))
@@ -15,3 +23,26 @@ 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

@@ -2,11 +2,16 @@
 
 module Handler.Package.V0.License where
 
+import Conduit (awaitForever, (.|))
 import Data.String.Interpolate.IsString (i)
 import Foundation (Handler)
-import Handler.Util (getVersionSpecFromQuery)
+import Handler.Util (getVersionSpecFromQuery, orThrow, versionPriorityFromQueryIsMin)
+import Lib.Error (S9Error (..))
+import Lib.PkgRepository (getBestVersion, getLicense)
 import Lib.Types.AppIndex (PkgId)
-import Yesod (TypedContent)
+import Network.HTTP.Types (status400)
+import Startlude (show, ($))
+import Yesod (TypedContent, addHeader, respondSource, sendChunkBS, sendResponseStatus, typePlain)
 
 
 getLicenseR :: PkgId -> Handler TypedContent

src/Handler/Package/V0/Manifest.hs

@@ -1 +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.AppIndex (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

@@ -2,12 +2,16 @@
 
 module Handler.Package.V0.ReleaseNotes where
 
-import Data.Aeson (ToJSON (..), Value (..), object, (.=))
+import Data.Aeson (ToJSON (..))
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
+import Database.Marketplace (fetchAllAppVersions)
+import Foundation (Handler, RegistryCtx (..))
+import Lib.Types.AppIndex (PkgId)
 import Lib.Types.Emver (Version)
-import Startlude (Eq, Show, Text, (.))
+import Model (VersionRecord (..))
-import Yesod (ToContent (..), ToTypedContent (..))
+import Startlude (Down (..), Eq, Show, Text, fst, pure, sortOn, ($), (&&&), (.), (<$>))
+import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), getYesod)
 
 
 newtype ReleaseNotes = ReleaseNotes {unReleaseNotes :: HashMap Version Text}
@@ -18,3 +22,18 @@ 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

@@ -1 +1,56 @@
+{-# 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, fetchApp, 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.AppIndex (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
+    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/Package/V0/Version.hs

@@ -1 +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.AppIndex (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

@@ -1,24 +1,31 @@
 module Handler.Types.Api where
 
-import           GHC.Read                       ( Read(..) )
+import GHC.Read (Read (..))
-import           GHC.Show                       ( show )
+import GHC.Show (show)
-import           Startlude                      ( Eq
+import Startlude (
-                                                , Maybe(..)
+    Eq,
-                                                , Ord
+    Maybe (..),
-                                                , Read
+    Ord,
-                                                , Show
+    Show,
-                                                )
+ )
-import           Yesod                          ( PathPiece(..) )
+import Yesod (PathPiece (..))
+
 
 data ApiVersion
     = V0
-    | V1 deriving (Eq, Ord)
+    | V1
+    deriving (Eq, Ord)
+
 
 instance Show ApiVersion where
     show V0 = "v0"
     show V1 = "v1"
+
+
 instance Read ApiVersion where
-    readsPrec = _
+    readsPrec _ "v0" = [(V0, "")]
+    readsPrec _ "v1" = [(V1, "")]
+    readsPrec _ _ = []
 
 
 instance PathPiece ApiVersion where
@@ -26,4 +33,4 @@ instance PathPiece ApiVersion where
     toPathPiece V1 = "v1"
     fromPathPiece "v0" = Just V0
     fromPathPiece "v1" = Just V1
-    fromPathPiece _    = Nothing
+    fromPathPiece _ = Nothing

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

@@ -1,16 +1,20 @@
+{-# 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.AppIndex (PkgId)
 import Lib.Types.Emver (
-    Version (Version),
+    Version,
     VersionRange,
  )
 import Network.HTTP.Types (
@@ -19,29 +23,35 @@ import Network.HTTP.Types (
  )
 import Startlude (
     Bool (..),
+    Either (..),
     Foldable (foldMap),
     Maybe (..),
+    Monoid (..),
     Semigroup ((<>)),
     Text,
+    decodeUtf8,
     fromMaybe,
+    fst,
     isSpace,
     not,
     pure,
     readMaybe,
+    ($),
     (.),
     (<$>),
-    (>>=),, ($)
+    (>>=),
  )
 import UnliftIO (MonadUnliftIO)
 import Yesod (
     MonadHandler,
-    RenderRoute (Route),
+    RenderRoute (..),
     TypedContent (..),
     lookupGetParam,
     sendResponseStatus,
     toContent,
     typePlain,
  )
+import Yesod.Core (addHeader)
 
 
 orThrow :: MonadHandler m => m (Maybe a) -> m a -> m a
@@ -80,4 +90,14 @@ addPackageHeader pkg version = do
 
 
 basicRender :: RenderRoute a => Route a -> Text
-basicRender = TL.toStrict . TB.toLazyText . foldMap (mappend (TB.singleton '/') . TB.fromText) . fst . renderRoute
+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           Handler.Util                   ( orThrow )
-import           Lib.Error                      ( S9Error(NotFoundE) )
-import           Lib.PkgRepository              ( getBestVersion )
-import           Lib.Types.AppIndex             ( PkgId )
-import           Network.HTTP.Types.Status      ( status404 )
-import           Util.Shared                    ( getVersionSpecFromQuery
-                                                , 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/Conduit.hs

@@ -3,52 +3,27 @@
 
 module Lib.Conduit where
 
-import Conduit (ConduitT, awaitForever, yield)
 import Control.Monad.Logger (logInfo)
 import Control.Monad.Logger.CallStack (MonadLogger)
-import Data.List (lookup, null)
+import Data.List.NonEmpty qualified as NE
 import Data.String.Interpolate.IsString (i)
-import Database.Marketplace (PackageDependencyMetadata (..), PackageMetadata (..))
+import Database.Marketplace (PackageDependencyMetadata (..))
 import Database.Persist (Entity (..))
+import Lib.Ord (maximumOn)
 import Lib.Types.AppIndex (PkgId)
-import Lib.Types.Emver (Version, VersionRange (..), satisfies)
+import Lib.Types.Emver (Version, VersionRange (..), satisfies, (<||))
-import Model (Category, Key, PkgDependency (..), PkgRecord (PkgRecord), VersionRecord (..))
+import Model (Key (..), PkgDependency (..), PkgRecord (..), VersionRecord (..))
-import Startlude (Bool, Down (..), Maybe (..), Monad, Text, filter, fmap, fromMaybe, headMay, sortOn, unless, ($), (.))
+import Startlude (Bool, Down (..), Maybe (..), NonEmpty, Text, filter, headMay, pure, sortOn, ($), (.), (<$>))
 
 
-filterPkgOsCompatible :: Monad m => (Version -> Bool) -> ConduitT PackageMetadata PackageMetadata m ()
+selectLatestVersionFromSpec ::
-filterPkgOsCompatible p =
+    (PkgId -> VersionRange) ->
-    awaitForever $
+    NonEmpty VersionRecord ->
-        \PackageMetadata{packageMetadataPkgId = pkg, packageMetadataPkgVersionRecords = versions, packageMetadataPkgCategories = cats, packageMetadataPkgVersion = requestedVersion} ->
+    Maybe VersionRecord
-            do
+selectLatestVersionFromSpec pkgRanges vs =
-                let compatible = filter (p . versionRecordOsVersion . entityVal) versions
+    let pkgId = NE.head $ versionRecordPkgId <$> vs
-                unless (null compatible) $
+        spec = pkgRanges (unPkgRecordKey pkgId)
-                    yield
+     in headMay . sortOn (Down . versionRecordNumber) $ NE.filter ((`satisfies` spec) . versionRecordNumber) vs
-                        PackageMetadata
-                            { packageMetadataPkgId = pkg
-                            , packageMetadataPkgVersionRecords = compatible
-                            , packageMetadataPkgCategories = cats
-                            , packageMetadataPkgVersion = requestedVersion
-                            }
-
-
-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
-                    }
 
 
 filterDependencyOsCompatible :: (Version -> Bool) -> PackageDependencyMetadata -> PackageDependencyMetadata

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,46 +1,57 @@
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+
 module Lib.Types.AppIndex where
 
-import           Startlude
+import Startlude
 
 -- NOTE: leave eitherDecode for inline test evaluation below
-import           Control.Monad                  ( fail )
+import Control.Monad (fail)
-import           Data.Aeson                     ( (.:)
+import Data.Aeson (
-                                                , (.:?)
+    FromJSON (..),
-                                                , FromJSON(..)
+    FromJSONKey (..),
-                                                , FromJSONKey(..)
+    ToJSON (..),
-                                                , ToJSON(..)
+    ToJSONKey (..),
-                                                , ToJSONKey(..)
+    withObject,
-                                                , withObject
+    (.:),
-                                                )
+    (.:?),
-import qualified Data.ByteString.Lazy          as BS
+ )
-import           Data.Functor.Contravariant     ( contramap )
+import Data.ByteString.Lazy qualified as BS
-import qualified Data.HashMap.Strict           as HM
+import Data.Functor.Contravariant (contramap)
-import           Data.String.Interpolate.IsString
+import Data.HashMap.Strict qualified as HM
-                                                ( i )
+import Data.String.Interpolate.IsString (
-import qualified Data.Text                     as T
+    i,
-import           Database.Persist               ( PersistField(..)
+ )
-                                                , PersistValue(PersistText)
+import Data.Text qualified as T
-                                                , SqlType(..)
+import Database.Persist (
-                                                )
+    PersistField (..),
-import           Database.Persist.Sql           ( PersistFieldSql(sqlType) )
+    PersistValue (PersistText),
-import           GHC.Read                       ( Read(readsPrec) )
+    SqlType (..),
-import           Lib.Types.Emver                ( Version
+ )
-                                                , VersionRange
+import Database.Persist.Sql (PersistFieldSql (sqlType))
-                                                )
+import GHC.Read (Read (readsPrec))
-import           Orphans.Emver                  ( )
+import Lib.Types.Emver (
-import qualified Protolude.Base                as P
+    Version,
-                                                ( Show(..) )
+    VersionRange,
-import           Web.HttpApiData                ( FromHttpApiData
+ )
-                                                , ToHttpApiData
+import Orphans.Emver ()
-                                                )
+import Protolude.Base qualified as P (
-import           Yesod                          ( PathPiece(..) )
+    Show (..),
-newtype PkgId = PkgId { unPkgId :: Text }
+ )
+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
@@ -62,72 +73,100 @@ instance ToJSONKey PkgId where
 instance PersistField PkgId where
     toPersistValue = PersistText . show
     fromPersistValue (PersistText t) = Right . PkgId $ toS t
-    fromPersistValue other           = Left [i|Invalid AppId: #{other}|]
+    fromPersistValue other = Left [i|Invalid AppId: #{other}|]
 instance PersistFieldSql PkgId where
     sqlType _ = SqlString
 instance PathPiece PkgId where
     fromPathPiece = fmap PkgId . fromPathPiece
-    toPathPiece   = unPkgId
+    toPathPiece = unPkgId
 data VersionInfo = VersionInfo
-    { versionInfoVersion      :: !Version
+    { versionInfoVersion :: !Version
     , versionInfoReleaseNotes :: !Text
     , versionInfoDependencies :: !(HM.HashMap PkgId VersionRange)
-    , versionInfoOsVersion    :: !Version
+    , versionInfoOsVersion :: !Version
     , versionInfoInstallAlert :: !(Maybe Text)
     }
     deriving (Eq, Show)
 
+
 data PackageDependency = PackageDependency
-    { packageDependencyOptional    :: !(Maybe Text)
+    { packageDependencyOptional :: !(Maybe Text)
-    , packageDependencyVersion     :: !VersionRange
+    , packageDependencyVersion :: !VersionRange
     , packageDependencyDescription :: !(Maybe Text)
     }
-    deriving Show
+    deriving (Show)
 instance FromJSON PackageDependency where
     parseJSON = withObject "service dependency info" $ \o -> do
-        packageDependencyOptional    <- o .:? "optional"
+        packageDependencyOptional <- o .:? "optional"
-        packageDependencyVersion     <- o .: "version"
+        packageDependencyVersion <- o .: "version"
         packageDependencyDescription <- o .:? "description"
-        pure PackageDependency { .. }
+        pure PackageDependency{..}
 data ServiceAlert = INSTALL | UNINSTALL | RESTORE | START | STOP
     deriving (Show, Eq, Generic, Hashable, Read)
 data PackageManifest = PackageManifest
-    { packageManifestId               :: !PkgId
+    { packageManifestId :: !PkgId
-    , packageManifestTitle            :: !Text
+    , packageManifestTitle :: !Text
-    , packageManifestVersion          :: !Version
+    , packageManifestVersion :: !Version
-    , packageManifestDescriptionLong  :: !Text
+    , packageManifestDescriptionLong :: !Text
     , packageManifestDescriptionShort :: !Text
-    , packageManifestReleaseNotes     :: !Text
+    , packageManifestReleaseNotes :: !Text
-    , packageManifestIcon             :: !(Maybe Text)
+    , packageManifestIcon :: !(Maybe Text)
-    , packageManifestAlerts           :: !(HM.HashMap ServiceAlert (Maybe Text))
+    , packageManifestAlerts :: !(HM.HashMap ServiceAlert (Maybe Text))
-    , packageManifestDependencies     :: !(HM.HashMap PkgId PackageDependency)
+    , packageManifestDependencies :: !(HM.HashMap PkgId PackageDependency)
-    , packageManifestEosVersion       :: !Version
+    , packageManifestEosVersion :: !Version
     }
-    deriving Show
+    deriving (Show)
 instance FromJSON PackageManifest where
     parseJSON = withObject "service manifest" $ \o -> do
-        packageManifestId               <- o .: "id"
+        packageManifestId <- o .: "id"
-        packageManifestTitle            <- o .: "title"
+        packageManifestTitle <- o .: "title"
-        packageManifestVersion          <- o .: "version"
+        packageManifestVersion <- o .: "version"
-        packageManifestDescriptionLong  <- o .: "description" >>= (.: "long")
+        packageManifestDescriptionLong <- o .: "description" >>= (.: "long")
         packageManifestDescriptionShort <- o .: "description" >>= (.: "short")
-        packageManifestIcon             <- o .: "assets" >>= (.: "icon")
+        packageManifestIcon <- o .: "assets" >>= (.: "icon")
-        packageManifestReleaseNotes     <- o .: "release-notes"
+        packageManifestReleaseNotes <- o .: "release-notes"
-        alerts                          <- o .: "alerts"
+        alerts <- o .: "alerts"
-        a                               <- for (HM.toList alerts) $ \(key, value) -> do
+        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
+                Just t -> pure t
             alertDesc <- parseJSON value
             pure (alertType, alertDesc)
         let packageManifestAlerts = HM.fromList a
         packageManifestDependencies <- o .: "dependencies"
-        packageManifestEosVersion   <- o .: "eos-version"
+        packageManifestEosVersion <- o .: "eos-version"
-        pure PackageManifest { .. }
+        pure PackageManifest{..}
+
+
+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
+
 
 -- >>> eitherDecode testManifest :: Either String PackageManifest
 testManifest :: BS.ByteString
-testManifest = [i|{
+testManifest =
+    [i|{
   "id": "embassy-pages",
   "title": "Embassy Pages",
   "version": "0.1.3",