From cd0a24af34db184e32d453d1be24a1a829cab522 Mon Sep 17 00:00:00 2001 From: Aiden McClelland Date: Wed, 7 Sep 2022 15:49:40 -0600 Subject: [PATCH] hash on upload --- config/routes | 1 + src/Application.hs | 11 ++---- src/Cli/Cli.hs | 52 +++++++++++++++++++++++++- src/Foundation.hs | 1 - src/Handler/Admin.hs | 31 ++++++++++++++-- src/Handler/Eos/V0/EosImg.hs | 24 +++++------- src/Handler/Package/V0/Latest.hs | 4 +- src/Handler/Util.hs | 11 ++++++ src/Lib/PkgRepository.hs | 64 +------------------------------- 9 files changed, 107 insertions(+), 92 deletions(-) diff --git a/config/routes b/config/routes index e114134..e76519a 100644 --- a/config/routes +++ b/config/routes @@ -16,6 +16,7 @@ -- ADMIN API V0 /admin/v0/upload PkgUploadR POST !admin +/admin/v0/eos-upload EosUploadR POST !admin /admin/v0/index PkgIndexR POST !admin /admin/v0/deindex PkgDeindexR GET POST !admin /admin/v0/category/#Text CategoryR POST DELETE !admin diff --git a/src/Application.hs b/src/Application.hs index bd31bdc..c8c3936 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -187,7 +187,6 @@ import Handler.Admin ( ) import Handler.Eos (getEosR, getEosVersionR) import Handler.Package -import Lib.PkgRepository (watchEosRepoRoot) import Lib.Ssl ( doesSslNeedRenew, renewSslCerts, @@ -240,12 +239,12 @@ 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 appStopFsNotifyEos = RegistryCtx{..} + 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") (panic "stopFsNotify forced in tempFoundation") + mkFoundation (panic "connPool forced in tempFoundation") logFunc = messageLoggerSource tempFoundation appLogger createDirectoryIfMissing True (errorLogRoot appSettings) @@ -255,8 +254,6 @@ makeFoundation appSettings = do flip runLoggingT logFunc $ createPostgresqlPool (pgConnStr $ appDatabaseConf appSettings) (pgPoolSize . appDatabaseConf $ appSettings) - stopEosWatch <- runLoggingT (runReaderT (watchEosRepoRoot pool) appSettings) logFunc - runSqlPool (Database.Persist.Migration.Postgres.runMigration Database.Persist.Migration.defaultSettings manualMigration) pool @@ -264,7 +261,7 @@ makeFoundation appSettings = do runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc -- Return the foundation - return $ mkFoundation pool stopEosWatch + return $ mkFoundation pool -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and @@ -449,7 +446,7 @@ startWeb foundation = do app <- makeApplication foundation startWeb' app where - startWeb' app = (`onException` appStopFsNotifyEos foundation) $ do + startWeb' app = 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/Cli/Cli.hs b/src/Cli/Cli.hs index ccf33e6..2cb7a02 100644 --- a/src/Cli/Cli.hs +++ b/src/Cli/Cli.hs @@ -90,7 +90,7 @@ import Network.HTTP.Simple ( parseRequest, setRequestBody, setRequestBodyJSON, - setRequestHeaders, + setRequestHeaders, setRequestQueryString ) import Network.HTTP.Types (status200) import Network.URI ( @@ -205,6 +205,7 @@ import Yesod ( logError, logWarn, ) +import Crypto.Hash.Conduit (hashFile) data Upload = Upload @@ -214,6 +215,13 @@ data Upload = Upload } deriving (Show) +data EosUpload = EosUpload + { eosRepoName :: !String + , eosPath :: !FilePath + , eosVersion :: !Version + } + deriving (Show) + newtype PublishCfg = PublishCfg { publishCfgRepos :: HashMap String PublishCfgRepo @@ -260,6 +268,7 @@ data Command | CmdCatDel !String !String | CmdPkgCatAdd !String !PkgId !String | CmdPkgCatDel !String !PkgId !String + | CmdEosUpload !EosUpload deriving (Show) @@ -373,6 +382,7 @@ parseCommand = <|> (CmdListUnindexed <$> parseListUnindexed) <|> parseCat <|> parsePkgCat + <|> (CmdEosUpload <$> parseEosPublish) where reg = parseRepoAdd <|> (CmdRegDel <$> parseRepoDel) <|> (parseRepoList $> CmdRegList) @@ -419,6 +429,20 @@ parsePkgCat = subparser $ command "categorize" (info cat $ progDesc "Add or remo <*> strArgument (metavar "PACKAGE_ID") <*> strArgument (metavar "CATEGORY") +parseEosPublish :: Parser EosUpload +parseEosPublish = + subparser $ + command "upload" (info go $ progDesc "Publishes a .s9pk to a remote registry") + <> metavar + "upload" + where + go = + liftA3 + EosUpload + (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall")) + (strOption (short 'p' <> long "package" <> metavar "S9PK" <> help "File path of the image to publish")) + (strOption (short 'v' <> long "version" <> help "Version of the image")) + opts :: ParserInfo Command opts = info (parseCommand <**> helper) (fullDesc <> progDesc "Publish tool for Embassy Packages") @@ -438,6 +462,7 @@ cliMain = CmdCatDel target cat -> catDel target cat CmdPkgCatAdd target pkg cat -> pkgCatAdd target pkg cat CmdPkgCatDel target pkg cat -> pkgCatDel target pkg cat + CmdEosUpload up -> eosUpload up init :: Maybe Shell -> IO () @@ -547,6 +572,31 @@ upload (Upload name mpkg shouldIndex) = do sfs2prog :: StreamFileStatus -> Progress () sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () +eosUpload :: EosUpload -> IO () +eosUpload (EosUpload name img version) = do + PublishCfgRepo{..} <- findNameInCfg name + noBody <- + parseRequest ("POST " <> show publishCfgRepoLocation <> "/admin/v0/eos-upload") + <&> setRequestHeaders [("accept", "text/plain")] + <&> applyBasicAuth (B8.pack publishCfgRepoUser) (B8.pack publishCfgRepoPass) + size <- getFileSize img + hash <- hashFile @_ @SHA256 img + bar <- newProgressBar defStyle 30 (Progress 0 (fromIntegral size) ()) + body <- observedStreamFile (updateProgress bar . const . sfs2prog) img + let withBody = setRequestBody body noBody + let withQParams = setRequestQueryString [("version", Just $ show version), ("hash", Just $ convertToBase Base16 hash)] withBody + manager <- newTlsManager + res <- runReaderT (httpLbs withQParams) manager + if getResponseStatus res == status200 + then -- no output is successful + pure () + else do + $logError (decodeUtf8 . LB.toStrict $ getResponseBody res) + exitWith $ ExitFailure 1 + putChunkLn $ fromString ("Successfully uploaded " <> img) & fore green + where + sfs2prog :: StreamFileStatus -> Progress () + sfs2prog StreamFileStatus{..} = Progress (fromIntegral readSoFar) (fromIntegral fileSize) () index :: String -> String -> Version -> IO () index name pkg v = performHttp name "POST" [i|/admin/v0/index|] (IndexPkgReq (PkgId $ toS pkg) v) diff --git a/src/Foundation.hs b/src/Foundation.hs index b84c739..f71be79 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -162,7 +162,6 @@ data RegistryCtx = RegistryCtx , appWebServerThreadId :: MVar (ThreadId, ThreadId) , appShouldRestartWeb :: MVar Bool , appConnPool :: ConnectionPool - , appStopFsNotifyEos :: IO Bool } diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 7d60d15..434e63b 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -43,7 +43,7 @@ import Database.Persist ( PersistUniqueWrite (deleteBy, insertUnique, upsert), entityVal, insert_, - selectList, + selectList, (=.) ) import Database.Persist.Postgresql (runSqlPoolNoTransaction) import Database.Queries (upsertPackageVersion) @@ -53,7 +53,7 @@ import Foundation ( ) import Handler.Util ( orThrow, - sendResponseText, + sendResponseText, getVersionFromQuery, getHashFromQuery ) import Lib.PkgRepository ( PkgRepo (PkgRepo, pkgRepoFileRoot), @@ -74,12 +74,13 @@ import Model ( Unique (UniqueName, UniquePkgCategory), Upload (..), VersionRecord (versionRecordNumber, versionRecordPkgId), - unPkgRecordKey, + unPkgRecordKey, EosHash (EosHash), EntityField (EosHashHash) ) import Network.HTTP.Types ( status403, status404, status500, + status400 ) import Settings import Startlude ( @@ -138,7 +139,7 @@ import Yesod ( logError, rawRequestBody, requireCheckJsonBody, - runDB, + runDB, sendResponseStatus ) import Yesod.Auth (YesodAuth (maybeAuthId)) import Yesod.Core.Types (JSONResponse (JSONResponse)) @@ -177,6 +178,28 @@ postPkgUploadR = do where retry m = runMaybeT . asum $ replicate 3 (MaybeT $ hush <$> try @_ @SomeException m) +postEosUploadR :: Handler () +postEosUploadR = do + root <- getsYesod $ ( "eos") . resourcesDir . appSettings + maybeVersion <- getVersionFromQuery + version <- case maybeVersion of + Nothing -> sendResponseStatus status400 ("Missing Version" :: Text) + Just v -> pure v + maybeHash <- getHashFromQuery + hash <- case maybeHash of + Nothing -> sendResponseStatus status400 ("Missing Hash" :: Text) + Just h -> pure h + resourcesTemp <- getsYesod $ ( "temp") . resourcesDir . appSettings + createDirectoryIfMissing True resourcesTemp + withTempDirectory resourcesTemp "neweos" $ \dir -> do + let path = dir "eos" <.> "img" + runConduit $ rawRequestBody .| sinkFile path + _ <- runDB $ upsert (EosHash version hash) [EosHashHash =. hash] + let targetPath = root show version + removePathForcibly targetPath + createDirectoryIfMissing True targetPath + renameDirectory dir targetPath + data IndexPkgReq = IndexPkgReq { indexPkgReqId :: !PkgId diff --git a/src/Handler/Eos/V0/EosImg.hs b/src/Handler/Eos/V0/EosImg.hs index dc6fa79..402a87c 100644 --- a/src/Handler/Eos/V0/EosImg.hs +++ b/src/Handler/Eos/V0/EosImg.hs @@ -3,13 +3,10 @@ module Handler.Eos.V0.EosImg where -import Crypto.Hash (SHA256) -import Crypto.Hash.Conduit (hashFile) import Data.Attoparsec.Text qualified as Atto -import Data.ByteArray.Encoding (Base (..), convertToBase) import Data.String.Interpolate.IsString (i) import Data.Text qualified as T -import Database.Persist (Entity (..), insertUnique) +import Database.Persist (Entity (..)) import Database.Persist.Class (getBy) import Foundation (Handler, RegistryCtx (..)) import Handler.Util (getVersionSpecFromQuery) @@ -18,11 +15,12 @@ import Lib.Types.Emver (Version (..), parseVersion, satisfies) import Model (EosHash (..), Unique (..)) import Network.HTTP.Types (status404) import Settings (AppSettings (..)) -import Startlude (Down (..), FilePath, Maybe (..), Text, decodeUtf8, filter, for_, headMay, partitionEithers, pure, show, sortOn, void, ($), (.), (<$>)) +import Startlude (Down (..), Maybe (..), Text, filter, for_, headMay, partitionEithers, pure, show, sortOn, ($), (.), (<$>)) import System.FilePath (()) import UnliftIO.Directory (listDirectory) import Yesod (Content (..), TypedContent, YesodDB, YesodPersist (runDB), addHeader, getsYesod, respond, sendResponseStatus, typeOctet) import Yesod.Core (logWarn) +import Data.Maybe (maybe) getEosR :: Handler TypedContent @@ -37,17 +35,13 @@ getEosR = do Nothing -> sendResponseStatus status404 (NotFoundE [i|EOS version satisfying #{spec}|]) Just version -> do let imgPath = root show version "eos.img" - h <- runDB $ retrieveHash version imgPath - addHeader "x-eos-hash" h + h <- runDB $ retrieveHash version + maybe (pure ()) (addHeader "x-eos-hash") h respond typeOctet $ ContentFile imgPath Nothing where - retrieveHash :: Version -> FilePath -> YesodDB RegistryCtx Text - retrieveHash v fp = do + retrieveHash :: Version -> YesodDB RegistryCtx (Maybe Text) + retrieveHash v = do mHash <- getBy (UniqueVersion v) case mHash of - Just h -> pure . eosHashHash . entityVal $ h - Nothing -> do - h <- hashFile @_ @SHA256 fp - let t = decodeUtf8 $ convertToBase Base16 h - void $ insertUnique (EosHash v t) -- lazily populate - pure t + Just h -> pure . Just . eosHashHash . entityVal $ h + Nothing -> pure Nothing diff --git a/src/Handler/Package/V0/Latest.hs b/src/Handler/Package/V0/Latest.hs index 895ef6d..9469ba9 100644 --- a/src/Handler/Package/V0/Latest.hs +++ b/src/Handler/Package/V0/Latest.hs @@ -5,7 +5,7 @@ import Data.Aeson (ToJSON (..), eitherDecode) import Data.ByteString.Lazy qualified as LBS import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HM -import Data.List (lookup, sortOn) +import Data.List (lookup) import Data.List.NonEmpty.Extra qualified as NE import Data.Tuple.Extra (second) import Database.Queries (collateVersions, getPkgDataSource) @@ -16,7 +16,7 @@ import Lib.Types.Core (PkgId) import Lib.Types.Emver (Version, satisfies) import Model (VersionRecord (..)) import Network.HTTP.Types (status400) -import Startlude (Bool (True), Down (Down), Either (..), Generic, Maybe (..), NonEmpty, Show, const, encodeUtf8, filter, flip, headMay, nonEmpty, pure, ($), (.), (<$>), (<&>)) +import Startlude (Bool (True), Down (Down), Either (..), Generic, Maybe (..), NonEmpty, Show, const, encodeUtf8, filter, flip, nonEmpty, pure, ($), (.), (<$>), (<&>)) import Yesod (ToContent (..), ToTypedContent (..), YesodPersist (runDB), YesodRequest (reqGetParams), getRequest, sendResponseStatus) diff --git a/src/Handler/Util.hs b/src/Handler/Util.hs index 0ab78ba..75af8d5 100644 --- a/src/Handler/Util.hs +++ b/src/Handler/Util.hs @@ -97,6 +97,17 @@ getVersionSpecFromQuery = do Nothing -> sendResponseStatus status400 ("Invalid App Version Specification" :: Text) Just t -> pure t +getVersionFromQuery :: MonadHandler m => m (Maybe Version) +getVersionFromQuery = do + versionString <- lookupGetParam "version" + case versionString of + Nothing -> pure Nothing + Just v -> case readMaybe v of + Nothing -> sendResponseStatus status400 ("Invalid Version" :: Text) + Just t -> pure t + +getHashFromQuery :: MonadHandler m => m (Maybe Text) +getHashFromQuery = lookupGetParam "hash" versionPriorityFromQueryIsMin :: MonadHandler m => m Bool versionPriorityFromQueryIsMin = do diff --git a/src/Lib/PkgRepository.hs b/src/Lib/PkgRepository.hs index 1e0d407..ba1cdf5 100644 --- a/src/Lib/PkgRepository.hs +++ b/src/Lib/PkgRepository.hs @@ -31,15 +31,8 @@ import Control.Monad.Reader.Has ( ask, asks, ) -import Crypto.Hash (SHA256) -import Crypto.Hash.Conduit (hashFile) import Data.Aeson (eitherDecodeFileStrict') -import Data.Attoparsec.Text (parseOnly) import Data.Attoparsec.Text qualified as Atto -import Data.ByteArray.Encoding ( - Base (Base16), - convertToBase, - ) import Data.ByteString ( readFile, writeFile, @@ -58,7 +51,6 @@ import Database.Esqueleto.Experimental ( import Database.Persist ( insertKey, update, - upsert, (=.), ) import Database.Persist.Sql ( @@ -80,8 +72,7 @@ import Lib.Types.Manifest ( PackageManifest (..), ) import Model ( - EntityField (EosHashHash, PkgRecordUpdatedAt), - EosHash (EosHash), + EntityField (PkgRecordUpdatedAt), Key (PkgRecordKey), PkgDependency (PkgDependency), PkgRecord (PkgRecord), @@ -95,7 +86,6 @@ import Startlude ( Eq ((==)), Exception, FilePath, - IO, Integer, Maybe (..), MonadIO (liftIO), @@ -103,7 +93,6 @@ import Startlude ( Ord (compare), Show, SomeException (..), - decodeUtf8, filter, find, first, @@ -111,7 +100,6 @@ import Startlude ( for_, fst, headMay, - not, on, partitionEithers, pure, @@ -120,40 +108,26 @@ import Startlude ( sortBy, throwIO, toS, - void, ($), - (&&), (.), (/=), (<$>), ) -import System.FSNotify ( - ActionPredicate, - Event (..), - eventPath, - watchTree, - withManager, - ) + import System.FilePath ( takeBaseName, takeDirectory, takeExtension, - takeFileName, (<.>), (), ) import UnliftIO ( MonadUnliftIO, - askRunInIO, async, catch, mapConcurrently_, - newEmptyMVar, - takeMVar, - tryPutMVar, wait, ) -import UnliftIO.Concurrent (forkIO) import UnliftIO.Directory ( doesDirectoryExist, doesPathExist, @@ -299,40 +273,6 @@ extractPkg pool fp = handle @_ @SomeException cleanup $ do throwIO e -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] - - getManifestLocation :: (MonadReader r m, Has PkgRepo r) => PkgId -> Version -> m FilePath getManifestLocation pkg version = do root <- asks pkgRepoFileRoot