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>

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

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

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)

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
 
 

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

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
+            h <- runDB $ retrieveHash version
-            addHeader "x-eos-hash" h
+            maybe (pure ()) (addHeader "x-eos-hash") h
             respond typeOctet $ ContentFile imgPath Nothing
     where
-        retrieveHash :: Version -> FilePath -> YesodDB RegistryCtx Text
+        retrieveHash :: Version -> YesodDB RegistryCtx (Maybe Text)
-        retrieveHash v fp = do
+        retrieveHash v = do
             mHash <- getBy (UniqueVersion v)
             case mHash of
-                Just h -> pure . eosHashHash . entityVal $ h
+                Just h -> pure . Just . eosHashHash . entityVal $ h
-                Nothing -> do
+                Nothing -> pure Nothing
-                    h <- hashFile @_ @SHA256 fp
-                    let t = decodeUtf8 $ convertToBase Base16 h
-                    void $ insertUnique (EosHash v t) -- lazily populate
-                    pure t

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)
 
 

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

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),
+    EntityField (PkgRecordUpdatedAt),
-    EosHash (EosHash),
     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