Implements uploads, index, and deindex

package.yaml

@@ -38,6 +38,8 @@ dependencies:
   - foreign-store
   - fsnotify
   - http-api-data
+  - http-client-tls
+  - http-conduit
   - http-types
   - interpolate
   - lens
@@ -52,11 +54,13 @@ dependencies:
   - persistent-migration
   - persistent-postgresql
   - persistent-template
+  - postgresql-simple
   - process
   - protolude
   - rainbow
   - shakespeare
   - template-haskell
+  - terminal-progress-bar
   - text
   - time
   - transformers

src/Application.hs

@@ -93,9 +93,7 @@ import           Handler.ErrorLogs
 import           Handler.Icons
 import           Handler.Marketplace
 import           Handler.Version
-import           Lib.PkgRepository              ( watchEosRepoRoot
+import           Lib.PkgRepository              ( watchEosRepoRoot )
-                                                , watchPkgRepoRoot
-                                                )
 import           Lib.Ssl
 import           Migration                      ( manualMigration )
 import           Model
@@ -136,13 +134,12 @@ makeFoundation appSettings = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appStopFsNotifyPkg appStopFsNotifyEos = RegistryCtx { .. }
+    let mkFoundation appConnPool appStopFsNotifyEos = RegistryCtx { .. }
 -- The RegistryCtx {..} syntax is an example of record wild cards. For more
 -- information, see:
 -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
-        tempFoundation = mkFoundation (panic "connPool forced in tempFoundation")
+        tempFoundation =
-                                      (panic "stopFsNotify forced in tempFoundation")
+            mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify forced in tempFoundation")
-                                      (panic "stopFsNotify forced in tempFoundation")
         logFunc = messageLoggerSource tempFoundation appLogger
 
     createDirectoryIfMissing True (errorLogRoot appSettings)
@@ -151,7 +148,6 @@ makeFoundation appSettings = do
     pool <- flip runLoggingT logFunc
         $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings)
 
-    stopPkgWatch <- runLoggingT (runReaderT (watchPkgRepoRoot pool) appSettings) logFunc
     stopEosWatch <- runLoggingT (runReaderT (watchEosRepoRoot pool) appSettings) logFunc
 
     -- Preform database migration using application logging settings
@@ -168,7 +164,7 @@ makeFoundation appSettings = do
                          )
 
     -- Return the foundation
-    return $ mkFoundation pool stopPkgWatch stopEosWatch
+    return $ mkFoundation pool stopEosWatch
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.
@@ -334,7 +330,7 @@ startWeb foundation = do
     app <- makeApplication foundation
     startWeb' app
     where
-        startWeb' app = (`onException` (appStopFsNotifyPkg foundation *> appStopFsNotifyEos foundation)) $ do
+        startWeb' app = (`onException` appStopFsNotifyEos foundation) $ do
             let AppSettings {..} = appSettings foundation
             runLog $ $logInfo [i|Launching Tor Web Server on port #{torPort}|]
             torAction <- async $ runSettings (warpSettings torPort foundation) app

src/Cli/Cli.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -8,62 +9,124 @@ module Cli.Cli
     ( cliMain
     ) where
 
+import           Conduit                        ( (.|)
+                                                , foldC
+                                                , runConduit
+                                                )
+import           Control.Monad.Logger           ( LogLevel(..)
+                                                , MonadLogger(monadLoggerLog)
+                                                , MonadLoggerIO(askLoggerIO)
+                                                , ToLogStr
+                                                , fromLogStr
+                                                , toLogStr
+                                                )
+import           Data.Aeson                     ( eitherDecodeStrict )
+import qualified Data.ByteString.Char8         as B8
+import qualified Data.ByteString.Lazy          as LB
 import           Data.Default
 import           Data.Functor.Contravariant     ( contramap )
 import           Data.HashMap.Internal.Strict   ( HashMap
                                                 , delete
                                                 , empty
                                                 , insert
+                                                , lookup
                                                 , traverseWithKey
                                                 )
-import           Data.String                    ( IsString(fromString) )
 import           Dhall                   hiding ( void )
 import           Dhall.Core                     ( pretty )
+import           Handler.Admin                  ( IndexPkgReq(IndexPkgReq) )
+import           Lib.External.AppMgr            ( sourceManifest )
+import           Lib.Types.AppIndex             ( PackageManifest
+                                                    ( PackageManifest
+                                                    , packageManifestId
+                                                    , packageManifestVersion
+                                                    )
+                                                , PkgId(..)
+                                                )
+import           Lib.Types.Emver                ( Version(..) )
+import           Network.HTTP.Client.Conduit    ( StreamFileStatus(StreamFileStatus, fileSize, readSoFar)
+                                                , applyBasicAuth
+                                                , httpLbs
+                                                , observedStreamFile
+                                                , parseRequest
+                                                )
+import           Network.HTTP.Client.TLS        ( newTlsManager )
+import           Network.HTTP.Simple            ( getResponseBody
+                                                , httpLBS
+                                                , setRequestBody
+                                                , setRequestBodyJSON
+                                                , setRequestHeaders
+                                                )
 import           Network.URI                    ( URI
                                                 , parseURI
                                                 )
 import           Options.Applicative     hiding ( auto
                                                 , empty
                                                 )
-import           Rainbow                        ( fore
+import           Rainbow                        ( Chunk
+                                                , Radiant
+                                                , blue
+                                                , chunk
+                                                , fore
+                                                , green
                                                 , magenta
                                                 , putChunk
                                                 , putChunkLn
+                                                , red
+                                                , white
                                                 , yellow
                                                 )
 import           Startlude                      ( ($)
                                                 , ($>)
                                                 , (&)
                                                 , (.)
-                                                , (<$>)
                                                 , (<&>)
-                                                , (>>=)
                                                 , Bool(..)
+                                                , ConvertText(toS)
+                                                , Either(..)
+                                                , Eq(..)
+                                                , ExitCode(..)
                                                 , FilePath
                                                 , IO
-                                                , IsString
+                                                , IsString(..)
-                                                , Maybe
+                                                , Maybe(..)
-                                                , Monad(return)
+                                                , Monad((>>=))
+                                                , ReaderT(runReaderT)
                                                 , Semigroup((<>))
                                                 , Show
                                                 , String
+                                                , const
+                                                , decodeUtf8
+                                                , exitWith
+                                                , filter
+                                                , for_
+                                                , fromIntegral
                                                 , fromMaybe
                                                 , panic
-                                                , print
-                                                , pure
                                                 , show
                                                 , unlessM
                                                 , void
+                                                , when
                                                 , writeFile
                                                 )
-import           System.Directory               ( createDirectory
+import           System.Directory               ( createDirectoryIfMissing
-                                                , createDirectoryIfMissing
                                                 , doesPathExist
+                                                , getCurrentDirectory
+                                                , getFileSize
                                                 , getHomeDirectory
+                                                , listDirectory
                                                 )
 import           System.FilePath                ( (</>)
-                                                , takeBaseName
                                                 , takeDirectory
+                                                , takeExtension
+                                                )
+import           System.ProgressBar             ( Progress(..)
+                                                , defStyle
+                                                , newProgressBar
+                                                , updateProgress
+                                                )
+import           Yesod                          ( logError
+                                                , logWarn
                                                 )
 
 data Upload = Upload
@@ -73,7 +136,7 @@ data Upload = Upload
     }
     deriving Show
 
-data PublishCfg = PublishCfg
+newtype PublishCfg = PublishCfg
     { publishCfgRepos :: HashMap String PublishCfgRepo
     }
     deriving Generic
@@ -101,17 +164,13 @@ instance ToDhall URI where
 instance IsString URI where
     fromString = fromMaybe (panic "Invalid URI for publish target") . parseURI
 
-data RegAdd = RegAdd
-    deriving Show
-data RegDel = RegDel
-    deriving Show
-
 data Command
     = CmdInit
     | CmdRegAdd String PublishCfgRepo
     | CmdRegDel String
     | CmdRegList
     | CmdUpload Upload
+    | CmdIndex String String Version Bool
     deriving Show
 
 cfgLocation :: IO FilePath
@@ -163,9 +222,33 @@ parseRepoDel = subparser $ command "rm" (info go $ progDesc "Remove a registry f
 parseRepoList :: Parser ()
 parseRepoList = subparser $ command "ls" (info (pure ()) $ progDesc "List registries in your config") <> metavar "ls"
 
+parseIndex :: Parser Command
+parseIndex =
+    subparser
+        $  command "index" (info (parseIndexHelper True) $ progDesc "Indexes an existing package version")
+        <> metavar "index"
+
+parseDeindex :: Parser Command
+parseDeindex =
+    subparser
+        $  command "deindex" (info (parseIndexHelper False) $ progDesc "Indexes an existing package version")
+        <> metavar "deindex"
+
+parseIndexHelper :: Bool -> Parser Command
+parseIndexHelper b =
+    CmdIndex
+        <$> strOption (short 't' <> long "target" <> metavar "REGISTRY_NAME")
+        <*> strArgument (metavar "PKG")
+        <*> strArgument (metavar "VERSION")
+        <*> pure b
+
 parseCommand :: Parser Command
-parseCommand = (parseInit $> CmdInit) <|> (CmdUpload <$> parsePublish) <|> subparser
+parseCommand =
-    (command "reg" (info reg $ progDesc "Manage configured registries"))
+    (parseInit $> CmdInit)
+        <|> (CmdUpload <$> parsePublish)
+        <|> subparser (command "reg" (info reg $ progDesc "Manage configured registries"))
+        <|> parseIndex
+        <|> parseDeindex
     where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList)
 
 opts :: ParserInfo Command
@@ -175,11 +258,12 @@ cliMain :: IO ()
 cliMain =
     execParser opts
         >>= (\case
-                CmdInit         -> init
+                CmdInit                         -> init
-                CmdRegAdd s pcr -> regAdd s pcr
+                CmdRegAdd s pcr                 -> regAdd s pcr
-                CmdRegDel s     -> regRm s
+                CmdRegDel s                     -> regRm s
-                CmdRegList      -> regLs
+                CmdRegList                      -> regLs
-                CmdUpload up    -> regUpload up
+                CmdUpload up                    -> upload up
+                CmdIndex name pkg v shouldIndex -> if shouldIndex then index name pkg v else deindex name pkg v
             )
 
 init :: IO ()
@@ -212,5 +296,97 @@ regLs = do
             putChunk $ fromString (k <> ": ") & fore yellow
             putChunkLn $ fromString (show $ publishCfgRepoLocation v) & fore magenta
 
-regUpload :: Upload -> IO ()
+upload :: Upload -> IO ()
-regUpload = panic "unimplemented"
+upload (Upload name mpkg shouldIndex) = do
+    PublishCfgRepo {..} <- findNameInCfg name
+    pkg                 <- case mpkg of
+        Nothing -> do
+            cwd   <- getCurrentDirectory
+            files <- listDirectory cwd
+            let pkgs = filter (\n -> takeExtension n == "s9pk") files
+            case pkgs of
+                [] -> do
+                    $logError "No package specified, and could not find one in this directory"
+                    exitWith $ ExitFailure 1
+                [p        ] -> pure (cwd </> p)
+                (_ : _ : _) -> do
+                    $logWarn "Ambiguous package upload request, found multiple candidates:"
+                    for_ pkgs $ \f -> $logWarn (fromString f)
+                    exitWith $ ExitFailure 1
+        Just s -> pure s
+    noBody <-
+        parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/upload")
+        <&> setRequestHeaders [("accept", "text/plain")]
+        <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
+    size <- getFileSize pkg
+    bar  <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ())
+    body <- observedStreamFile (updateProgress bar . const . sfs2prog) pkg
+    let withBody = setRequestBody body noBody
+    manager <- newTlsManager
+    res     <- getResponseBody <$> runReaderT (httpLbs withBody) manager
+    if LB.null res
+        then pure ()
+        else do
+            $logError (decodeUtf8 $ LB.toStrict res)
+            exitWith $ ExitFailure 1
+    putChunkLn $ fromString ("Successfully uploaded " <> pkg) & fore green
+    when shouldIndex $ do
+        home          <- getHomeDirectory
+        manifestBytes <- sourceManifest (home </> ".cargo/bin") pkg $ \c -> runConduit (c .| foldC)
+        PackageManifest { packageManifestId, packageManifestVersion } <- case eitherDecodeStrict manifestBytes of
+            Left s -> do
+                $logError $ "Could not parse the manifest of the package: " <> toS s
+                exitWith $ ExitFailure 1
+            Right a -> pure a
+        let pkgId = toS $ unPkgId packageManifestId
+        index name pkgId packageManifestVersion
+        putChunkLn $ fromString ("Successfully indexed " <> pkgId <> "@" <> show packageManifestVersion) & fore green
+
+    where
+        sfs2prog :: StreamFileStatus -> Progress ()
+        sfs2prog StreamFileStatus {..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) ()
+
+index :: String -> String -> Version -> IO ()
+index name pkg v = do
+    PublishCfgRepo {..} <- findNameInCfg name
+    noBody              <-
+        parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/index")
+        <&> setRequestHeaders [("accept", "text/plain")]
+        <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
+    let withBody = setRequestBodyJSON (IndexPkgReq (PkgId $ toS pkg) v) noBody
+    res <- getResponseBody <$> httpLBS withBody
+    if LB.null res then pure () else $logError (decodeUtf8 $ LB.toStrict res) *> exitWith (ExitFailure 1)
+
+
+deindex :: String -> String -> Version -> IO ()
+deindex name pkg v = do
+    PublishCfgRepo {..} <- findNameInCfg name
+    noBody              <-
+        parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/deindex")
+        <&> setRequestHeaders [("accept", "text/plain")]
+        <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass)
+    let withBody = setRequestBodyJSON (IndexPkgReq (PkgId $ toS pkg) v) noBody
+    res <- getResponseBody <$> httpLBS withBody
+    if LB.null res then pure () else $logError (decodeUtf8 $ LB.toStrict res) *> exitWith (ExitFailure 1)
+
+findNameInCfg :: String -> IO PublishCfgRepo
+findNameInCfg name = do
+    loc            <- cfgLocation
+    PublishCfg cfg <- inputFile auto loc
+    case lookup name cfg of
+        Nothing -> do
+            $logError "Registry name not found!"
+            exitWith $ ExitFailure 1
+        Just pcr -> pure pcr
+
+instance MonadLogger IO where
+    monadLoggerLog _ _ LevelDebug     = putChunkLn . colorLog white
+    monadLoggerLog _ _ LevelInfo      = putChunkLn . colorLog blue
+    monadLoggerLog _ _ LevelWarn      = putChunkLn . colorLog yellow
+    monadLoggerLog _ _ LevelError     = putChunkLn . colorLog red
+    monadLoggerLog _ _ (LevelOther _) = putChunkLn . colorLog magenta
+
+colorLog :: ToLogStr msg => Radiant -> msg -> Chunk
+colorLog c m = fore c $ chunk . decodeUtf8 . fromLogStr . toLogStr $ m
+instance MonadLoggerIO IO where
+    askLoggerIO = pure monadLoggerLog

src/Foundation.hs

@@ -85,7 +85,6 @@ data RegistryCtx = RegistryCtx
     , appWebServerThreadId :: MVar (ThreadId, ThreadId)
     , appShouldRestartWeb  :: MVar Bool
     , appConnPool          :: ConnectionPool
-    , appStopFsNotifyPkg   :: IO Bool
     , appStopFsNotifyEos   :: IO Bool
     }
 instance Has PkgRepo RegistryCtx where
@@ -196,6 +195,9 @@ instance Yesod RegistryCtx where
             pure $ if hasAuthId then Authorized else Unauthorized "This feature is for admins only"
         | otherwise = pure Authorized
 
+    maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64)
+    maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing
+    maximumContentLengthIO _ _                 = pure $ Just 2097152 -- the original default
 
 -- How to run database actions.
 instance YesodPersist RegistryCtx where

src/Handler/Admin.hs

@@ -11,12 +11,16 @@ import           Conduit                        ( (.|)
 import           Control.Monad.Reader.Has       ( ask )
 import           Control.Monad.Trans.Maybe      ( MaybeT(..) )
 import           Data.Aeson                     ( (.:)
+                                                , (.=)
                                                 , FromJSON(parseJSON)
+                                                , ToJSON
                                                 , decodeFileStrict
+                                                , object
                                                 , withObject
                                                 )
 import           Data.String.Interpolate.IsString
                                                 ( i )
+import           Database.Persist.Postgresql    ( runSqlPoolNoTransaction )
 import           Database.Queries               ( upsertPackageVersion )
 import           Foundation
 import           Lib.PkgRepository              ( PkgRepo(PkgRepo, pkgRepoFileRoot)
@@ -24,7 +28,7 @@ import           Lib.PkgRepository              ( PkgRepo(PkgRepo, pkgRepoFileRo
                                                 , getManifestLocation
                                                 )
 import           Lib.Types.AppIndex             ( PackageManifest(..)
-                                                , PkgId
+                                                , PkgId(unPkgId)
                                                 )
 import           Lib.Types.Emver                ( Version(..) )
 import           Model                          ( Key(PkgRecordKey, VersionRecordKey) )
@@ -35,7 +39,9 @@ import           Startlude                      ( ($)
                                                 , (.)
                                                 , (<$>)
                                                 , Applicative(pure)
+                                                , Bool(..)
                                                 , Eq
+                                                , Maybe(..)
                                                 , Show
                                                 , SomeException(..)
                                                 , asum
@@ -44,6 +50,7 @@ import           Startlude                      ( ($)
                                                 , liftIO
                                                 , replicate
                                                 , show
+                                                , toS
                                                 , when
                                                 )
 import           System.FilePath                ( (<.>)
@@ -52,11 +59,16 @@ import           System.FilePath                ( (<.>)
 import           UnliftIO                       ( try
                                                 , withSystemTempDirectory
                                                 )
-import           UnliftIO.Directory             ( renameDirectory )
+import           UnliftIO.Directory             ( createDirectoryIfMissing
+                                                , removePathForcibly
+                                                , renameDirectory
+                                                , renameFile
+                                                )
 import           Util.Shared                    ( orThrow
                                                 , sendResponseText
                                                 )
-import           Yesod                          ( delete
+import           Yesod                          ( ToJSON(..)
+                                                , delete
                                                 , getsYesod
                                                 , logError
                                                 , rawRequestBody
@@ -66,17 +78,22 @@ import           Yesod                          ( delete
 
 postPkgUploadR :: Handler ()
 postPkgUploadR = do
-    withSystemTempDirectory "newpkg" $ \path -> do
+    withSystemTempDirectory "newpkg" $ \dir -> do
-        runConduit $ rawRequestBody .| sinkFile (path </> "temp" <.> "s9pk")
+        let path = dir </> "temp" <.> "s9pk"
+        runConduit $ rawRequestBody .| sinkFile path
         pool         <- getsYesod appConnPool
         PkgRepo {..} <- ask
         res          <- retry $ extractPkg pool path
         when (isNothing res) $ do
             $logError "Failed to extract package"
             sendResponseText status500 "Failed to extract package"
-        PackageManifest {..} <- liftIO (decodeFileStrict (path </> "manifest.json"))
+        PackageManifest {..} <- liftIO (decodeFileStrict (dir </> "manifest.json"))
             `orThrow` sendResponseText status500 "Failed to parse manifest.json"
-        renameDirectory path (pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion)
+        renameFile path (dir </> (toS . unPkgId) packageManifestId <.> "s9pk")
+        let targetPath = pkgRepoFileRoot </> show packageManifestId </> show packageManifestVersion
+        removePathForcibly targetPath
+        createDirectoryIfMissing True targetPath
+        renameDirectory dir targetPath
     where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m)
 
 
@@ -90,6 +107,8 @@ instance FromJSON IndexPkgReq where
         indexPkgReqId      <- o .: "id"
         indexPkgReqVersion <- o .: "version"
         pure IndexPkgReq { .. }
+instance ToJSON IndexPkgReq where
+    toJSON IndexPkgReq {..} = object ["id" .= indexPkgReqId, "version" .= indexPkgReqVersion]
 
 postPkgIndexR :: Handler ()
 postPkgIndexR = do
@@ -98,7 +117,8 @@ postPkgIndexR = do
     man              <- liftIO (decodeFileStrict manifest) `orThrow` sendResponseText
         status404
         [i|Could not locate manifest for #{indexPkgReqId}@#{indexPkgReqVersion}|]
-    runDB $ upsertPackageVersion man
+    pool <- getsYesod appConnPool
+    runSqlPoolNoTransaction (upsertPackageVersion man) pool Nothing
 
 postPkgDeindexR :: Handler ()
 postPkgDeindexR = do

src/Lib/External/AppMgr.hs

@@ -36,9 +36,9 @@ import           GHC.IO.Exception               ( IOErrorType(NoSuchThing)
 import           Lib.Error
 import           System.FilePath                ( (</>) )
 import           UnliftIO                       ( MonadUnliftIO
+                                                , bracket
                                                 , catch
                                                 )
-import           UnliftIO                       ( bracket )
 
 readProcessWithExitCode' :: MonadIO m => String -> [String] -> ByteString -> m (ExitCode, ByteString, ByteString)
 readProcessWithExitCode' a b c = liftIO $ do

src/Lib/PkgRepository.hs

@@ -49,8 +49,15 @@ import           Database.Esqueleto.Experimental
                                                 , insertUnique
                                                 , runSqlPool
                                                 )
-import           Database.Persist               ( (=.) )
+import           Database.Persist               ( (=.)
-import           Database.Persist.Class         ( upsert )
+                                                , insertKey
+                                                , update
+                                                , upsert
+                                                )
+import           Database.Persist.Sql           ( SqlPersistT
+                                                , runSqlPoolNoTransaction
+                                                )
+import           Database.PostgreSQL.Simple     ( SqlError(sqlState) )
 import           Lib.Error                      ( S9Error(NotFoundE) )
 import qualified Lib.External.AppMgr           as AppMgr
 import           Lib.Types.AppIndex             ( PackageManifest(..)
@@ -118,6 +125,7 @@ import           System.FilePath                ( (<.>)
 import           UnliftIO                       ( MonadUnliftIO
                                                 , askRunInIO
                                                 , async
+                                                , catch
                                                 , mapConcurrently_
                                                 , newEmptyMVar
                                                 , takeMVar
@@ -184,15 +192,18 @@ loadPkgDependencies appConnPool manifest = do
     let pkgVersion = packageManifestVersion manifest
     let deps       = packageManifestDependencies manifest
     time <- liftIO getCurrentTime
+    _    <- runWith appConnPool $ insertKey (PkgRecordKey pkgId) (PkgRecord time Nothing) `catch` \(e :: SqlError) ->
+        if sqlState e == "23505" then update (PkgRecordKey pkgId) [PkgRecordUpdatedAt =. Just time] else throwIO e
     let deps' = first PkgRecordKey <$> HM.toList deps
     for_
         deps'
-        (\d -> runSqlPool
+        (\d -> flip runSqlPool appConnPool $ do
-            ( insertUnique
+            insertUnique
-            $ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d)
+                $ PkgDependency time (PkgRecordKey pkgId) pkgVersion (fst d) (packageDependencyVersion . snd $ d)
-            )
-            appConnPool
         )
+    where
+        runWith :: MonadUnliftIO m => ConnectionPool -> SqlPersistT m a -> m a
+        runWith pool action = runSqlPoolNoTransaction action pool Nothing
 
 -- extract all package assets into their own respective files
 extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> FilePath -> m ()
@@ -235,27 +246,6 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do
             mapConcurrently_ (removeFile . (pkgRoot </>)) toRemove
             throwIO e
 
-watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool)
-watchPkgRepoRoot pool = do
-    $logInfo "Starting FSNotify Watch Manager: PKG"
-    root    <- asks pkgRepoFileRoot
-    runInIO <- askRunInIO
-    box     <- newEmptyMVar @_ @()
-    _       <- forkIO $ liftIO $ withManager $ \watchManager -> do
-        stop <- watchTree watchManager root onlyAdded $ \evt -> do
-            let pkg = eventPath evt
-            -- TODO: validate that package path is an actual s9pk and is in a correctly conforming path.
-            void . forkIO $ runInIO $ do
-                extractPkg pool pkg
-        takeMVar box
-        stop
-    pure $ tryPutMVar box ()
-    where
-        onlyAdded :: ActionPredicate
-        onlyAdded (Added    path _ isDir) = not isDir && takeExtension path == ".s9pk"
-        onlyAdded (Modified path _ isDir) = not isDir && takeExtension path == ".s9pk"
-        onlyAdded _                       = False
-
 watchEosRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has EosRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool)
 watchEosRepoRoot pool = do
     $logInfo "Starting FSNotify Watch Manager: EOS"

src/Util/Shared.hs

@@ -148,7 +148,7 @@ filterDependencyBestVersion PackageDependencyMetadata { packageDependencyMetadat
                 pure Nothing
 
 sendResponseText :: MonadHandler m => Status -> Text -> m a
-sendResponseText = sendResponseStatus @_ @Text
+sendResponseText s = sendResponseStatus s . TypedContent typePlain . toContent
 
 maximumOn :: forall a b t . (Ord b, Foldable t) => (a -> b) -> t a -> Maybe a
 maximumOn f = foldr (\x y -> maxOn f x <$> y <|> Just x) Nothing

stack.yaml

@@ -45,6 +45,7 @@ extra-deps:
   - monad-logger-extras-0.1.1.1
   - persistent-migration-0.3.0
   - rainbow-0.34.2.2
+  - terminal-progress-bar-0.4.1
   - wai-request-spec-0.10.2.4
   - warp-3.3.19
   - yesod-auth-basic-0.1.0.3