fsnotify extraction attempt

package.yaml

@@ -31,6 +31,7 @@ dependencies:
   - fast-logger
   - filepath
   - foreign-store
+  - fsnotify
   - http-types
   - interpolate
   - lens

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           Database.Persist.Postgresql    ( createPostgresqlPool
-import           Language.Haskell.TH.Syntax            (qLocation)
+                                                , pgConnStr
+                                                , pgPoolSize
+                                                , runMigration
+                                                , runSqlPool
+                                                )
+import           Language.Haskell.TH.Syntax     ( qLocation )
 import           Network.Wai
-import           Network.Wai.Handler.Warp              (Settings, defaultSettings, defaultShouldDisplayException,
+import           Network.Wai.Handler.Warp       ( Settings
-                                                        getPort, setHost, setOnException, setPort, runSettings, setHTTP2Disabled)
+                                                , 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 (..),
+import           Network.Wai.Middleware.RequestLogger
-                                                        destination, mkRequestLogger, outputFormat)
+                                                ( Destination(Logger)
-import           System.IO                             (hSetBuffering, BufferMode (..))
+                                                , OutputFormat(..)
-import           System.Log.FastLogger                 (defaultBufSize, newStdoutLoggerSet, toLogStr)
+                                                , 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.
+import           Control.Arrow                  ( (***) )
--- Don't forget to add new modules to your cabal file!
+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           Yesod
-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
 
 -- 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 {..}
+    let mkFoundation appConnPool appStopFsNotify = 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"
+        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
+    pool <- flip runLoggingT logFunc
-        (pgConnStr $ appDatabaseConf appSettings)
+        $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . 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 =
+makeLogWare foundation = mkRequestLogger def
-    mkRequestLogger def
+    { outputFormat = if appDetailedRequestLogging $ appSettings foundation
-        { outputFormat =
+                         then Detailed True
-            if appDetailedRequestLogging $ appSettings foundation
+                         else CustomOutputFormatWithDetailsAndHeaders formatAsJSONWithHeaders
-                then Detailed True
+    , destination  = Logger $ loggerSet $ appLogger foundation
-                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
+        startWeb' app = (`onException` (appStopFsNotify foundation)) $ do
-            let AppSettings{..} = appSettings foundation
+            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)
+                then async $ runTLS (tlsSettings sslCertLocation sslKeyLocation) (warpSettings appPort foundation) app
-                            (warpSettings appPort foundation) app
+                else async $ runSettings (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
+shutdownWeb RegistryCtx {..} = do
-    threadIds <-  takeMVar appWebServerThreadId
+    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
+    wsettings  <- getDevSettings $ warpSettings (appPort settings) foundation
-    app1 <- makeApplication foundation
+    app1       <- makeApplication foundation
-    return (getPort wsettings, foundation,  app1)
+    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
+    app        <- makeApplication foundation
-    wsettings <- getDevSettings $ warpSettings port foundation
+    wsettings  <- getDevSettings $ warpSettings port foundation
     return (wsettings, app)
 
 -- | main function for use by yesod devel

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

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

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

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