From 75663b65e47458e814707a828fecb8ef513f2c3d Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 1 Mar 2022 12:44:10 -0700 Subject: [PATCH] autohash eos --- src/Application.hs | 18 ++++++++------ src/Foundation.hs | 24 ++++++++++++------- src/Handler/Marketplace.hs | 9 ++++--- src/Lib/PkgRepository.hs | 48 +++++++++++++++++++++++++++++++++++++- src/Settings.hs | 14 +++++++++-- 5 files changed, 90 insertions(+), 23 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index cb44baa..368a414 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -90,7 +90,9 @@ import Handler.ErrorLogs import Handler.Icons import Handler.Marketplace import Handler.Version -import Lib.PkgRepository ( watchPkgRepoRoot ) +import Lib.PkgRepository ( watchEosRepoRoot + , watchPkgRepoRoot + ) import Lib.Ssl import Model import Network.HTTP.Types.Header ( hOrigin ) @@ -129,12 +131,13 @@ 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 appStopFsNotify = RegistryCtx { .. } + let mkFoundation appConnPool appStopFsNotifyPkg 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") (panic "stopFsNotify forced in tempFoundation") + 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) @@ -143,13 +146,14 @@ makeFoundation appSettings = do pool <- flip runLoggingT logFunc $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) - stop <- runLoggingT (runReaderT (watchPkgRepoRoot pool) appSettings) logFunc + stopPkgWatch <- runLoggingT (runReaderT (watchPkgRepoRoot pool) appSettings) logFunc + stopEosWatch <- runLoggingT (runReaderT (watchEosRepoRoot pool) appSettings) logFunc -- Preform database migration using application logging settings runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc -- Return the foundation - return $ mkFoundation pool stop + return $ mkFoundation pool stopPkgWatch stopEosWatch -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. @@ -315,7 +319,7 @@ startWeb foundation = do app <- makeApplication foundation startWeb' app where - startWeb' app = (`onException` (appStopFsNotify foundation)) $ do + startWeb' app = (`onException` (appStopFsNotifyPkg foundation *> appStopFsNotifyEos foundation)) $ do let AppSettings {..} = appSettings foundation runLog $ $logInfo $ [i|Launching Tor Web Server on port #{torPort}|] torAction <- async $ runSettings (warpSettings torPort foundation) app diff --git a/src/Foundation.hs b/src/Foundation.hs index 4d4db48..7d994b1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} @@ -5,8 +6,10 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE UndecidableInstances #-} module Foundation where @@ -42,7 +45,6 @@ import System.Console.ANSI.Codes ( Color(..) , ConsoleLayer(Foreground) , SGR(SetColor) ) -import System.FilePath ( () ) import Yesod.Persist.Core -- | The foundation datatype for your application. This can be a good place to @@ -57,15 +59,12 @@ data RegistryCtx = RegistryCtx , appWebServerThreadId :: MVar (ThreadId, ThreadId) , appShouldRestartWeb :: MVar Bool , appConnPool :: ConnectionPool - , appStopFsNotify :: IO Bool + , appStopFsNotifyPkg :: IO Bool + , appStopFsNotifyEos :: IO Bool } instance Has PkgRepo RegistryCtx where - extract = do - liftA2 PkgRepo (( "apps") . resourcesDir . appSettings) (staticBinDir . appSettings) - update f ctx = - let repo = f $ extract ctx - settings = (appSettings ctx) { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo } - in ctx { appSettings = settings } + extract = transitiveExtract @AppSettings + update = transitiveUpdate @AppSettings instance Has a r => Has a (HandlerData r r) where extract = extract . rheSite . handlerEnv update f r = @@ -75,6 +74,15 @@ instance Has a r => Has a (HandlerData r r) where instance Has AppSettings RegistryCtx where extract = appSettings update f ctx = ctx { appSettings = f (appSettings ctx) } +instance Has EosRepo RegistryCtx where + extract = transitiveExtract @AppSettings + update = transitiveUpdate @AppSettings + +transitiveExtract :: forall b a c . (Has a b, Has b c) => c -> a +transitiveExtract = extract @a . extract @b +transitiveUpdate :: forall b a c . (Has a b, Has b c) => (a -> a) -> (c -> c) +transitiveUpdate f = update (update @a @b f) + setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid diff --git a/src/Handler/Marketplace.hs b/src/Handler/Marketplace.hs index 1756775..5e06498 100644 --- a/src/Handler/Marketplace.hs +++ b/src/Handler/Marketplace.hs @@ -242,17 +242,17 @@ getPackageListR = do $ searchServices category query .| zipVersions .| zipCategories - -- empty list since there are no requested packages in this case + -- empty list since there are no requested packages in this case .| filterLatestVersionFromSpec [] .| filterPkgOsCompatible osPredicate - -- pages start at 1 for some reason. TODO: make pages start at 0 + -- pages start at 1 for some reason. TODO: make pages start at 0 .| (dropC (limit' * (page - 1)) *> takeC limit') .| sinkList Just packages' -> do -- for each item in list get best available from version range let vMap = (packageReqId &&& packageReqVersion) <$> packages' runDB - -- TODO could probably be better with sequenceConduits + -- TODO could probably be better with sequenceConduits . runConduit $ getPkgData (packageReqId <$> packages') .| zipVersions @@ -354,8 +354,7 @@ getPackageListR = do runConduit $ bs .| CL.foldMap LBS.fromStrict icon <- loadIcon pkgId pkgVersion deps <- constructDependenciesApiRes dependencies - pure $ PackageRes { packageResIcon = encodeBase64 icon - -- pass through raw JSON Value, we have checked its correct parsing above + pure $ PackageRes { packageResIcon = encodeBase64 icon -- pass through raw JSON Value, we have checked its correct parsing above , packageResManifest = unsafeFromJust . decode $ manifest , packageResCategories = categoryName <$> pkgCategories , packageResInstructions = basicRender $ InstructionsR pkgId diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index f366c4d..9af8874 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# LANGUAGE GADTs #-} module Lib.PkgRepository where @@ -27,8 +28,14 @@ import Control.Monad.Reader.Has ( Has , ask , asks ) +import Crypto.Hash ( SHA256 ) +import Crypto.Hash.Conduit ( hashFile ) import Data.Aeson ( eitherDecodeFileStrict' ) import qualified Data.Attoparsec.Text as Atto +import Data.Attoparsec.Text ( parseOnly ) +import Data.ByteArray.Encoding ( Base(Base16) + , convertToBase + ) import Data.ByteString ( readFile , writeFile ) @@ -42,6 +49,8 @@ import Database.Esqueleto.Experimental , insertUnique , runSqlPool ) +import Database.Persist ( (=.) ) +import Database.Persist.Class ( upsert ) import Lib.Error ( S9Error(NotFoundE) ) import qualified Lib.External.AppMgr as AppMgr import Lib.Types.AppIndex ( PackageManifest(..) @@ -74,9 +83,11 @@ import Startlude ( ($) , Ord(compare) , Show , SomeException(..) + , decodeUtf8 , filter , find , first + , flip , for_ , fst , headMay @@ -101,6 +112,7 @@ import System.FilePath ( (<.>) , takeBaseName , takeDirectory , takeExtension + , takeFileName ) import UnliftIO ( MonadUnliftIO , askRunInIO @@ -137,6 +149,10 @@ data PkgRepo = PkgRepo , pkgRepoAppMgrBin :: FilePath } +data EosRepo = EosRepo + { eosRepoFileRoot :: FilePath + } + getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version] getVersionsFor pkg = do root <- asks pkgRepoFileRoot @@ -222,7 +238,7 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => ConnectionPool -> m (IO Bool) watchPkgRepoRoot pool = do - $logInfo "Starting FSNotify Watch Manager" + $logInfo "Starting FSNotify Watch Manager: PKG" root <- asks pkgRepoFileRoot runInIO <- askRunInIO box <- newEmptyMVar @_ @() @@ -241,6 +257,36 @@ watchPkgRepoRoot pool = do 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" + root <- asks eosRepoFileRoot + runInIO <- askRunInIO + box <- newEmptyMVar @_ @() + _ <- forkIO $ liftIO $ withManager $ \watchManager -> do + stop <- watchTree watchManager root shouldIndex $ \evt -> do + let os = eventPath evt + void . forkIO $ runInIO $ do + indexOs pool os + takeMVar box + stop + pure $ tryPutMVar box () + where + shouldIndex :: ActionPredicate + shouldIndex (Added path _ isDir) = not isDir && takeExtension path == ".img" + shouldIndex (Modified path _ isDir) = not isDir && takeExtension path == ".img" + shouldIndex _ = False + indexOs :: (MonadUnliftIO m, MonadLoggerIO m) => ConnectionPool -> FilePath -> m () + indexOs pool path = do + hash <- hashFile @_ @SHA256 path + let hashText = decodeUtf8 $ convertToBase Base16 hash + let vText = takeFileName (takeDirectory path) + let eVersion = parseOnly parseVersion . T.pack $ vText + case eVersion of + Left e -> $logError [i|Invalid Version Number (#{vText}): #{e}|] + Right version -> + void $ flip runSqlPool pool $ upsert (EosHash version hashText) [EosHashHash =. hashText] + getManifest :: (MonadResource m, MonadReader r m, Has PkgRepo r) => PkgId -> Version diff --git a/src/Settings.hs b/src/Settings.hs index 3ff887c..8129e1b 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -21,11 +21,15 @@ import Data.Yaml ( decodeEither' ) import Data.Yaml.Config import Database.Persist.Postgresql ( PostgresConf ) import Network.Wai.Handler.Warp ( HostPreference ) -import System.FilePath ( () ) +import System.FilePath ( () + , takeDirectory + ) import Yesod.Default.Config2 ( configSettingsYml ) import Control.Monad.Reader.Has ( Has(extract, update) ) -import Lib.PkgRepository ( PkgRepo(..) ) +import Lib.PkgRepository ( EosRepo(EosRepo, eosRepoFileRoot) + , PkgRepo(..) + ) import Lib.Types.Emver import Orphans.Emver ( ) -- | Runtime settings to configure this application. These settings can be @@ -62,6 +66,12 @@ instance Has PkgRepo AppSettings where extract = liftA2 PkgRepo (( "apps") . resourcesDir) staticBinDir update f r = let repo = f $ extract r in r { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo } +instance Has EosRepo AppSettings where + extract = EosRepo . ( "eos") . resourcesDir + update f ctx = + let repo = f $ extract ctx + settings = ctx { resourcesDir = takeDirectory (eosRepoFileRoot repo) } + in settings instance FromJSON AppSettings where