diff --git a/package.yaml b/package.yaml index fdde926..111f690 100644 --- a/package.yaml +++ b/package.yaml @@ -31,6 +31,7 @@ dependencies: - fast-logger - filepath - foreign-store + - fsnotify - http-types - interpolate - lens diff --git a/src/Application.hs b/src/Application.hs index d79ce17..993fb37 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,51 +24,79 @@ module Application , getAppSettings -- * for GHCI , handler - ,db) where + , db + ) where -import Startlude hiding (Handler) +import Startlude hiding ( Handler ) -import Control.Monad.Logger (liftLoc, runLoggingT) +import Control.Monad.Logger ( liftLoc + , runLoggingT + ) import Data.Default -import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, pgPoolSize, runSqlPool, runMigration) -import Language.Haskell.TH.Syntax (qLocation) +import Database.Persist.Postgresql ( createPostgresqlPool + , pgConnStr + , pgPoolSize + , runMigration + , runSqlPool + ) +import Language.Haskell.TH.Syntax ( qLocation ) import Network.Wai -import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - getPort, setHost, setOnException, setPort, runSettings, setHTTP2Disabled) +import Network.Wai.Handler.Warp ( Settings + , defaultSettings + , defaultShouldDisplayException + , getPort + , runSettings + , setHTTP2Disabled + , setHost + , setOnException + , setPort + ) import Network.Wai.Handler.WarpTLS import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.Autohead -import Network.Wai.Middleware.Cors (CorsResourcePolicy (..), cors, simpleCorsResourcePolicy) +import Network.Wai.Middleware.Cors ( CorsResourcePolicy(..) + , cors + , simpleCorsResourcePolicy + ) import Network.Wai.Middleware.MethodOverride -import Network.Wai.Middleware.RequestLogger (Destination (Logger), OutputFormat (..), - destination, mkRequestLogger, outputFormat) -import System.IO (hSetBuffering, BufferMode (..)) -import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) +import Network.Wai.Middleware.RequestLogger + ( Destination(Logger) + , OutputFormat(..) + , destination + , mkRequestLogger + , outputFormat + ) +import System.IO ( BufferMode(..) + , hSetBuffering + ) +import System.Log.FastLogger ( defaultBufSize + , newStdoutLoggerSet + , toLogStr + ) import Yesod.Core -import Yesod.Core.Types hiding (Logger) +import Yesod.Core.Types hiding ( Logger ) import Yesod.Default.Config2 --- Import all relevant handler modules here. --- Don't forget to add new modules to your cabal file! +import Control.Arrow ( (***) ) +import Control.Lens +import Data.List ( lookup ) +import Database.Persist.Sql ( SqlBackend ) import Foundation import Handler.Apps import Handler.ErrorLogs import Handler.Icons -import Handler.Version import Handler.Marketplace +import Handler.Version +import Lib.PkgRepository ( watchPkgRepoRoot ) import Lib.Ssl +import Model +import Network.HTTP.Types.Header ( hOrigin ) +import Network.Wai.Middleware.RequestLogger.JSON import Settings +import System.Directory ( createDirectoryIfMissing ) import System.Posix.Process import System.Time.Extra -import Model -import Control.Lens -import Control.Arrow ((***)) -import Network.HTTP.Types.Header ( hOrigin ) -import Data.List (lookup) -import Network.Wai.Middleware.RequestLogger.JSON -import System.Directory (createDirectoryIfMissing) -import Database.Persist.Sql (SqlBackend) -import Yesod +import Yesod -- 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 @@ -83,35 +111,36 @@ 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 = 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" + let mkFoundation appConnPool appStopFsNotify = 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") logFunc = messageLoggerSource tempFoundation appLogger + stop <- runLoggingT (runReaderT watchPkgRepoRoot appSettings) logFunc createDirectoryIfMissing True (errorLogRoot appSettings) -- Create the database connection pool - pool <- flip runLoggingT logFunc $ createPostgresqlPool - (pgConnStr $ appDatabaseConf appSettings) - (pgPoolSize . appDatabaseConf $ appSettings) + pool <- flip runLoggingT logFunc + $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) -- Preform database migration using application logging settings runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc -- Return the foundation - return $ mkFoundation pool + return $ mkFoundation pool stop -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. @@ -189,14 +218,12 @@ dynamicCorsResourcePolicy req = Just . policy . lookup hOrigin $ requestHeaders } makeLogWare :: RegistryCtx -> IO Middleware -makeLogWare foundation = - mkRequestLogger def - { outputFormat = - if appDetailedRequestLogging $ appSettings foundation - then Detailed True - else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders - , destination = Logger $ loggerSet $ appLogger foundation - } +makeLogWare foundation = mkRequestLogger def + { outputFormat = if appDetailedRequestLogging $ appSettings foundation + then Detailed True + else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders + , destination = Logger $ loggerSet $ appLogger foundation + } makeAuthWare :: RegistryCtx -> Middleware makeAuthWare _ app req res = next @@ -229,10 +256,10 @@ appMain = do -- Get the settings from all relevant sources settings <- loadYamlSettingsArgs -- fall back to compile-time values, set to [] to require values at runtime - [configSettingsYmlValue] + [configSettingsYmlValue] -- allow environment variables to override - useEnv + useEnv -- Generate the foundation from the settings makeFoundation settings >>= startApp @@ -262,15 +289,14 @@ startWeb foundation = do app <- makeApplication foundation startWeb' app where - startWeb' app = do - let AppSettings{..} = appSettings foundation + startWeb' app = (`onException` (appStopFsNotify foundation)) $ do + let AppSettings {..} = appSettings foundation putStrLn @Text $ "Launching Tor Web Server on port " <> show torPort torAction <- async $ runSettings (warpSettings torPort foundation) app putStrLn @Text $ "Launching Web Server on port " <> show appPort action <- if sslAuto - then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) - (warpSettings appPort foundation) app - else async $ runSettings (warpSettings appPort foundation) app + then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app + else async $ runSettings (warpSettings appPort foundation) app let actions = (action, torAction) setWebProcessThreadId (join (***) asyncThreadId actions) foundation @@ -303,21 +329,21 @@ shutdownAll threadIds = do -- Careful, you should always spawn this within forkIO so as to avoid accidentally killing the running process shutdownWeb :: RegistryCtx -> IO () -shutdownWeb RegistryCtx{..} = do - threadIds <- takeMVar appWebServerThreadId +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 :: IO (Int, RegistryCtx, Application) getApplicationRepl = do - settings <- getAppSettings + settings <- getAppSettings foundation <- getAppSettings >>= makeFoundation - wsettings <- getDevSettings $ warpSettings (appPort settings) foundation - app1 <- makeApplication foundation - return (getPort wsettings, foundation, app1) + wsettings <- getDevSettings $ warpSettings (appPort settings) foundation + app1 <- makeApplication foundation + return (getPort wsettings, foundation, app1) shutdownApp :: RegistryCtx -> IO () shutdownApp _ = return () @@ -325,10 +351,10 @@ 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 - wsettings <- getDevSettings $ warpSettings port foundation + app <- makeApplication foundation + wsettings <- getDevSettings $ warpSettings port foundation return (wsettings, app) -- | main function for use by yesod devel @@ -347,4 +373,4 @@ handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h -- | Run DB queries db :: ReaderT SqlBackend (HandlerFor RegistryCtx) a -> IO a -db = handler . runDB \ No newline at end of file +db = handler . runDB diff --git a/src/Foundation.hs b/src/Foundation.hs index 7e7ebad..11a8f7e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -15,8 +15,11 @@ import Yesod.Core import Yesod.Core.Types ( Logger ) import qualified Yesod.Core.Unsafe as Unsafe +import Control.Monad.Reader.Has ( Has(extract, update) ) +import Lib.PkgRepository import Lib.Types.AppIndex import Settings +import System.FilePath ( () ) import Yesod.Persist.Core -- | The foundation datatype for your application. This can be a good place to @@ -31,7 +34,17 @@ data RegistryCtx = RegistryCtx , appWebServerThreadId :: MVar (ThreadId, ThreadId) , appShouldRestartWeb :: MVar Bool , appConnPool :: ConnectionPool + , appStopFsNotify :: 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 } + + setWebProcessThreadId :: (ThreadId, ThreadId) -> RegistryCtx -> IO () setWebProcessThreadId tid a = putMVar (appWebServerThreadId a) $ tid diff --git a/src/Lib/External/AppMgr.hs b/src/Lib/External/AppMgr.hs index b650b27..2479a82 100644 --- a/src/Lib/External/AppMgr.hs +++ b/src/Lib/External/AppMgr.hs @@ -18,7 +18,6 @@ import System.Process.Typed hiding ( createPipe ) import Conduit ( (.|) , ConduitT - , MonadThrow , runConduit ) import qualified Data.Conduit.List as CL diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs new file mode 100644 index 0000000..2b19cdf --- /dev/null +++ b/src/Lib/PkgRepository.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +module Lib.PkgRepository where + +import Conduit ( (.|) + , runConduit + , runResourceT + , sinkFileCautious + ) +import Control.Monad.Logger ( MonadLogger + , MonadLoggerIO + , logError + , logInfo + , logWarn + ) +import Control.Monad.Reader.Has ( Has + , ask + , asks + ) +import Data.Aeson ( eitherDecodeFileStrict' ) +import qualified Data.Attoparsec.Text as Atto +import Data.String.Interpolate.IsString + ( i ) +import qualified Data.Text as T +import qualified Lib.External.AppMgr as AppMgr +import Lib.Registry ( Extension(Extension) ) +import Lib.Types.AppIndex ( PkgId(PkgId) + , ServiceManifest(serviceManifestIcon) + ) +import Lib.Types.Emver ( Version + , parseVersion + ) +import Startlude ( ($) + , (&&) + , (.) + , (<$>) + , Bool(..) + , Either(Left, Right) + , Eq((==)) + , Exception + , FilePath + , IO + , MonadIO(liftIO) + , MonadReader + , Show + , String + , filter + , for_ + , fromMaybe + , not + , partitionEithers + , pure + , show + , throwIO + ) +import System.FSNotify ( Event(Added) + , eventPath + , watchTree + , withManager + ) +import System.FilePath ( (<.>) + , () + , takeBaseName + , takeDirectory + , takeExtension + , takeFileName + ) +import UnliftIO ( MonadUnliftIO + , askRunInIO + , async + , mapConcurrently + , newEmptyMVar + , onException + , takeMVar + , wait + ) +import UnliftIO ( tryPutMVar ) +import UnliftIO.Concurrent ( forkIO ) +import UnliftIO.Directory ( listDirectory + , removeFile + , renameFile + ) + +data ManifestParseException = ManifestParseException PkgId Version String + deriving Show +instance Exception ManifestParseException + +data PkgRepo = PkgRepo + { pkgRepoFileRoot :: FilePath + , pkgRepoAppMgrBin :: FilePath + } + +getVersionsFor :: (MonadIO m, MonadReader r m, Has PkgRepo r, MonadLogger m) => PkgId -> m [Version] +getVersionsFor pkg = do + root <- asks pkgRepoFileRoot + subdirs <- listDirectory $ root show pkg + let (failures, successes) = partitionEithers $ (Atto.parseOnly parseVersion . T.pack) <$> subdirs + for_ failures $ \f -> $logWarn [i|Emver Parse Failure for #{pkg}: #{f}|] + pure successes + +-- extract all package assets into their own respective files +extractPkg :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => PkgId -> Version -> m () +extractPkg pkg v = (`onException` cleanup) $ do + $logInfo [i|Extracting package: #{pkg}@#{v}|] + PkgRepo { pkgRepoFileRoot = root, pkgRepoAppMgrBin = appmgr } <- ask + let s9pk = Extension @"s9pk" $ show pkg + let pkgRoot = root show pkg show v + manifestTask <- async $ liftIO . runResourceT $ AppMgr.sourceManifest appmgr root s9pk $ sinkIt + (pkgRoot "manifest.json") + instructionsTask <- async $ liftIO . runResourceT $ AppMgr.sourceInstructions appmgr root s9pk $ sinkIt + (pkgRoot "instructions.md") + licenseTask <- async $ liftIO . runResourceT $ AppMgr.sourceLicense appmgr root s9pk $ sinkIt + (pkgRoot "license.md") + iconTask <- async $ liftIO . runResourceT $ AppMgr.sourceIcon appmgr root s9pk $ sinkIt (pkgRoot "icon.tmp") + wait manifestTask + eManifest <- liftIO (eitherDecodeFileStrict' (pkgRoot "manifest.json")) + case eManifest of + Left e -> do + $logError [i|Invalid Package Manifest: #{pkg}@#{v}|] + liftIO . throwIO $ ManifestParseException pkg v e + Right manifest -> do + wait iconTask + let iconDest = "icon" <.> T.unpack (fromMaybe "png" (serviceManifestIcon manifest)) + liftIO $ renameFile (pkgRoot "icon.tmp") (pkgRoot iconDest) + wait instructionsTask + wait licenseTask + where + sinkIt fp source = runConduit $ source .| sinkFileCautious fp + cleanup = do + root <- asks pkgRepoFileRoot + let pkgRoot = root show pkg show v + fs <- listDirectory pkgRoot + let toRemove = filter (not . (== ".s9pk") . takeExtension) fs + mapConcurrently (removeFile . (pkgRoot )) toRemove + +watchPkgRepoRoot :: (MonadUnliftIO m, MonadReader r m, Has PkgRepo r, MonadLoggerIO m) => m (IO Bool) +watchPkgRepoRoot = do + root <- asks pkgRepoFileRoot + runInIO <- askRunInIO + box <- newEmptyMVar @_ @() + _ <- forkIO $ liftIO $ withManager $ \watchManager -> do + stop <- watchTree watchManager root onlyAdded $ \evt -> + let pkg = PkgId . T.pack $ takeBaseName (eventPath evt) + version = Atto.parseOnly parseVersion . T.pack . takeFileName . takeDirectory $ (eventPath evt) + in case version of + Left _ -> runInIO $ do + $logError [i|Invalid Version in package path: #{eventPath evt}|] + Right v -> runInIO (extractPkg pkg v) + takeMVar box + stop + pure $ tryPutMVar box () + where + onlyAdded = \case + Added path _ isDir -> not isDir && takeExtension path == ".s9pk" + _ -> False diff --git a/src/Settings.hs b/src/Settings.hs index f6b9ed8..41a6b24 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | Settings are centralized, as much as possible, into this file. This -- includes database connection settings, static file locations, etc. -- In addition, you can configure a number of different aspects of Yesod @@ -23,6 +24,8 @@ import Network.Wai.Handler.Warp ( HostPreference ) import System.FilePath ( () ) import Yesod.Default.Config2 ( configSettingsYml ) +import Control.Monad.Reader.Has ( Has(extract, update) ) +import Lib.PkgRepository ( PkgRepo(PkgRepo, pkgRepoAppMgrBin, pkgRepoFileRoot) ) import Lib.Types.Emver import Orphans.Emver ( ) -- | Runtime settings to configure this application. These settings can be @@ -54,6 +57,11 @@ data AppSettings = AppSettings , staticBinDir :: FilePath , errorLogRoot :: FilePath } +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 FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do