autohash eos

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 =
+        tempFoundation = mkFoundation (panic "connPool forced in tempFoundation")
-            mkFoundation (panic "connPool forced in tempFoundation") (panic "stopFsNotify 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

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
+    extract = transitiveExtract @AppSettings
-        liftA2 PkgRepo ((</> "apps") . resourcesDir . appSettings) (staticBinDir . appSettings)
+    update  = transitiveUpdate @AppSettings
-    update f ctx =
-        let repo     = f $ extract ctx
-            settings = (appSettings ctx) { resourcesDir = pkgRepoFileRoot repo, staticBinDir = pkgRepoAppMgrBin repo }
-        in  ctx { appSettings = settings }
 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

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
+            pure $ PackageRes { packageResIcon         = encodeBase64 icon -- pass through raw JSON Value, we have checked its correct parsing above
-                        -- pass through raw JSON Value, we have checked its correct parsing above
                               , packageResManifest     = unsafeFromJust . decode $ manifest
                               , packageResCategories   = categoryName <$> pkgCategories
                               , packageResInstructions = basicRender $ InstructionsR pkgId

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

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