hash on upload (#123)

* hash on upload * Update src/Cli/Cli.hs * fix import and clean up error response * remove content length limit * remove import * lift version * slow af but works Co-authored-by: Lucy C <12953208+elvece@users.noreply.github.com>
2026-03-26 02:11:53 +00:00 · 2022-09-08 10:29:01 -06:00
parent d8f667e41a
commit 3aef9dbf09
9 changed files with 113 additions and 93 deletions
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -55,7 +55,6 @@ import Startlude (
    killThread,
    newEmptyMVar,
    newMVar,
-    onException,
    panic,
    print,
    putMVar,
@@ -180,6 +179,7 @@ import Handler.Admin (
    deletePkgCategorizeR,
    getPkgDeindexR,
    postCategoryR,
+    postEosUploadR,
    postPkgCategorizeR,
    postPkgDeindexR,
    postPkgIndexR,
@@ -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
--- 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 "eos-upload" (info go $ progDesc "Publishes a .img to a remote registry")
+            <> metavar
+                "eos-upload"
+    where
+        go =
+            liftA3
+                EosUpload
+                (strOption (short 't' <> long "target" <> metavar "NAME" <> help "Name of registry in publish.dhall"))
+                (strOption (short 'i' <> long "image" <> metavar "EOS_IMG" <> 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)
--- 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
    }


@@ -288,6 +287,7 @@ instance Yesod RegistryCtx where

    maximumContentLengthIO :: RegistryCtx -> Maybe (Route RegistryCtx) -> IO (Maybe Word64)
    maximumContentLengthIO _ (Just PkgUploadR) = pure Nothing
+    maximumContentLengthIO _ (Just EosUploadR) = pure Nothing
    maximumContentLengthIO _ _ = pure $ Just 2097152 -- the original default


--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -10,7 +10,6 @@ import Conduit (
    sinkFile,
    (.|),
 )
-import Control.Exception (ErrorCall (ErrorCall))
 import Control.Monad.Reader.Has (ask)
 import Control.Monad.Trans.Maybe (MaybeT (..))
 import Data.Aeson (
@@ -44,6 +43,7 @@ import Database.Persist (
    entityVal,
    insert_,
    selectList,
+    (=.),
 )
 import Database.Persist.Postgresql (runSqlPoolNoTransaction)
 import Database.Queries (upsertPackageVersion)
@@ -52,6 +52,8 @@ import Foundation (
    RegistryCtx (..),
 )
 import Handler.Util (
+    getHashFromQuery,
+    getVersionFromQuery,
    orThrow,
    sendResponseText,
 )
@@ -69,6 +71,8 @@ import Lib.Types.Emver (Version (..))
 import Lib.Types.Manifest (PackageManifest (..))
 import Model (
    Category (..),
+    EntityField (EosHashHash),
+    EosHash (EosHash),
    Key (AdminKey, PkgRecordKey, VersionRecordKey),
    PkgCategory (PkgCategory),
    Unique (UniqueName, UniquePkgCategory),
@@ -77,6 +81,7 @@ import Model (
    unPkgRecordKey,
 )
 import Network.HTTP.Types (
+    status400,
    status403,
    status404,
    status500,
@@ -103,7 +108,6 @@ import Startlude (
    not,
    replicate,
    show,
-    throwIO,
    toS,
    traverse,
    void,
@@ -139,6 +143,7 @@ import Yesod (
    rawRequestBody,
    requireCheckJsonBody,
    runDB,
+    sendResponseStatus,
 )
 import Yesod.Auth (YesodAuth (maybeAuthId))
 import Yesod.Core.Types (JSONResponse (JSONResponse))
@@ -167,10 +172,9 @@ postPkgUploadR = do
        renameDirectory dir targetPath
        maybeAuthId >>= \case
            Nothing -> do
-                -- TODO: Send this to Matrix
                $logError
                    "The Impossible has happened, an unauthenticated user has managed to upload a pacakge to this registry"
-                throwIO $ ErrorCall "Unauthenticated user has uploaded package to registry!!!"
+                pure ()
            Just name -> do
                now <- liftIO getCurrentTime
                runDB $ insert_ (Upload (AdminKey name) (PkgRecordKey packageManifestId) packageManifestVersion now)
@@ -178,6 +182,29 @@ postPkgUploadR = do
        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
    , indexPkgReqVersion :: !Version
--- 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
--- 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)


--- 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 (Just t)
+
+getHashFromQuery :: MonadHandler m => m (Maybe Text)
+getHashFromQuery = lookupGetParam "hash"

 versionPriorityFromQueryIsMin :: MonadHandler m => m Bool
 versionPriorityFromQueryIsMin = do
--- 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