Start9/registry
2
0
Fork 0
mirror of https://github.com/Start9Labs/registry.git synced 2026-03-26 02:11:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

autohash eos

Browse Source
This commit is contained in:
Keagan McClelland
2022-03-01 12:44:10 -07:00
parent 4cab448846
commit 25b97dca86
5 changed files with 90 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
src/Application.hs
View File

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

24
src/Foundation.hs
View File

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

9
src/Handler/Marketplace.hs
View File

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

48
src/Lib/PkgRepository.hs
View File

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

14
src/Settings.hs
View File

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