diff --git a/CHANGELOG.md b/CHANGELOG.md index ea8ef196..2f6fec29 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,23 @@ ## [Unreleased] +### Changed +- Database exports download as raw bytes instead of base64-encoded JSON, + matching how uploads already work — a third less data on the wire and far + less memory on both ends for big files. Any export approximation warnings + now travel in the `X-Volca-Export-Warnings` response header. + +### Fixed +- A database holding activities with several products can now be exported to + ILCD. Each product becomes its own ILCD process, instead of the whole export + being refused. This unblocks exporting databases read from SimaPro CSV, where + two unrelated processes can share a name and so look like one multi-product + activity. +- Exporting a large database to a zipped format (ILCD, EcoSpold 2) no longer + stalls. The time spent packing the archive grew with the square of the number + of files, so a full Agribalyse ILCD export — some fifty thousand files — + exhausted memory and never returned. + ## [0.9.0] - 2026-07-06 A characterization-accuracy release. EF 3.1 scores on Agribalyse and ecoinvent diff --git a/app/Main.hs b/app/Main.hs index 4e438468..c8bc0084 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -31,7 +31,7 @@ import CLI.Types import Config (ClassificationPreset, Config (..), DatabaseConfig (..), HostingConfig (..), ServerConfig (..), loadConfig) import Control.Concurrent.STM (readTVarIO) import Database.Manager (DatabaseManager (..), initDatabaseManager) -import Network.HTTP.Client (defaultManagerSettings, newManager) +import Network.HTTP.Client (Manager, defaultManagerSettings, managerResponseTimeout, newManager, responseTimeoutNone) import Progress -- For server mode @@ -110,11 +110,18 @@ runCLIWithConfig cliConfig cmd cfgFile = do dbManager <- initDatabaseManager config (noCache (globalOptions cliConfig)) (Just cfgFile) executeCommand cliConfig cmd dbManager +{- | HTTP manager for client-mode commands, with the 30 s default response +timeout lifted: the server legitimately computes for minutes before the first +byte of a large database export or batch scoring arrives. +-} +newClientManager :: IO Manager +newClientManager = newManager defaultManagerSettings{managerResponseTimeout = responseTimeoutNone} + -- | Run CLI commands via HTTP against a running server (lightweight, no DB loading) runCLIViaAPI :: CLIConfig -> Command -> FilePath -> IO () runCLIViaAPI cliConfig cmd cfgFile = do config <- loadConfigOrDie cfgFile - mgr <- newManager defaultManagerSettings + mgr <- newClientManager rc <- resolveRemoteConfig (globalOptions cliConfig) (Just config) executeRemoteCommand mgr rc (globalOptions cliConfig) cmd @@ -122,14 +129,14 @@ runCLIViaAPI cliConfig cmd cfgFile = do runReplMode :: CLIConfig -> FilePath -> IO () runReplMode cliConfig cfgFile = do config <- loadConfigOrDie cfgFile - mgr <- newManager defaultManagerSettings + mgr <- newClientManager rc <- resolveRemoteConfig (globalOptions cliConfig) (Just config) runRepl mgr rc (globalOptions cliConfig) cfgFile -- | Run stop without config — resolveRemoteConfig falls back to env vars / defaults runStopWithoutConfig :: CLIConfig -> IO () runStopWithoutConfig cliConfig = do - mgr <- newManager defaultManagerSettings + mgr <- newClientManager rc <- resolveRemoteConfig (globalOptions cliConfig) Nothing executeRemoteCommand mgr rc (globalOptions cliConfig) Stop diff --git a/pyvolca/README.md b/pyvolca/README.md index dad2a849..b6c3136d 100644 --- a/pyvolca/README.md +++ b/pyvolca/README.md @@ -437,9 +437,10 @@ validated client-side; an unknown value raises VoLCAError before any request. Single-file formats carry their bytes directly; EcoSpold 2 / ILCD multi-file trees come back zipped. -The engine returns the payload base64-encoded in the ``data`` field; -this method base64-decodes it and returns the raw bytes. Raises -VoLCAError on ``success=false`` or a missing ``data`` field. +The engine streams the payload as raw bytes. Best-effort approximation +warnings arrive in the ``X-Volca-Export-Warnings`` response header +(percent-encoded, newline-joined) and are surfaced through +:mod:`warnings`. Raises VoLCAError on an HTTP error. ##### `Client.export_to_file(fmt: str, out_path: str, db_name: str | None = None) -> None` diff --git a/pyvolca/src/volca/client.py b/pyvolca/src/volca/client.py index b45eed14..a4d7b4c9 100644 --- a/pyvolca/src/volca/client.py +++ b/pyvolca/src/volca/client.py @@ -39,7 +39,8 @@ from __future__ import annotations -import base64 +import urllib.parse +import warnings from enum import Enum from pathlib import Path from typing import Any @@ -771,9 +772,10 @@ def export_database(self, fmt: str, db_name: str | None = None) -> bytes: request. Single-file formats carry their bytes directly; EcoSpold 2 / ILCD multi-file trees come back zipped. - The engine returns the payload base64-encoded in the ``data`` field; - this method base64-decodes it and returns the raw bytes. Raises - VoLCAError on ``success=false`` or a missing ``data`` field. + The engine streams the payload as raw bytes. Best-effort approximation + warnings arrive in the ``X-Volca-Export-Warnings`` response header + (percent-encoded, newline-joined) and are surfaced through + :mod:`warnings`. Raises VoLCAError on an HTTP error. """ fmt_norm = fmt.strip().lower() if fmt_norm not in _EXPORT_FORMATS: @@ -782,21 +784,20 @@ def export_database(self, fmt: str, db_name: str | None = None) -> bytes: f"(expected {'|'.join(sorted(_EXPORT_FORMATS))})" ) target = self._db(db_name) - payload = self._require_success( - self._json( - self._session.post( - f"{self.base_url}/api/v1/db/{target}/export", - json={"format": fmt_norm}, - ) - ), - "export_database", + resp = self._session.post( + f"{self.base_url}/api/v1/db/{target}/export", + json={"format": fmt_norm}, ) - data = payload.get("data") - if data is None: + if resp.status_code >= 400: raise VoLCAError( - "export_database succeeded but the response carried no data field." + f"export_database failed (HTTP {resp.status_code}): " + f"{resp.text[:500]}" ) - return base64.b64decode(data) + header = resp.headers.get("X-Volca-Export-Warnings", "") + for line in urllib.parse.unquote(header).split("\n"): + if line: + warnings.warn(line, stacklevel=2) + return resp.content def export_to_file( self, fmt: str, out_path: str, db_name: str | None = None diff --git a/pyvolca/tests/conftest.py b/pyvolca/tests/conftest.py index 705bee7c..1eab174b 100644 --- a/pyvolca/tests/conftest.py +++ b/pyvolca/tests/conftest.py @@ -145,6 +145,7 @@ def _make_response(json_body: Any, status: int = 200) -> MagicMock: r.content = json.dumps(json_body).encode() r.text = json.dumps(json_body) r.json.return_value = json_body + r.headers = {} r.history = [] r.raise_for_status = MagicMock() return r diff --git a/pyvolca/tests/test_db_write.py b/pyvolca/tests/test_db_write.py index 4065b1e4..f184ccf4 100644 --- a/pyvolca/tests/test_db_write.py +++ b/pyvolca/tests/test_db_write.py @@ -4,13 +4,13 @@ carry no operationId — they bypass the OpenAPI dispatcher and build their URLs directly. They also do not exist in any released engine binary, so these tests never touch a live engine: they mock ``Client._session`` and assert on -the wire shape (URL, JSON body, base64 decoding, format validation, error +the wire shape (URL, JSON body, raw-bytes handling, format validation, error surfacing). """ from __future__ import annotations -import base64 +import urllib.parse import pytest @@ -190,12 +190,22 @@ def test_remove_dependency_url(self, mocked_client): # --------------------------------------------------------------------------- +def _raw(session, body: bytes, warnings_header: str | None = None) -> None: + """Wire the mocked session's POST to return raw export bytes.""" + from tests.conftest import _make_response + + r = _make_response({}) + r.content = body + if warnings_header is not None: + r.headers = {"X-Volca-Export-Warnings": warnings_header} + session.post.return_value = r + + class TestExport: - def test_base64_decode_returns_raw_bytes(self, mocked_client): + def test_returns_raw_bytes(self, mocked_client): client, session = mocked_client raw = b"PK\x03\x04 zipped db bytes" - _ok(session, {"success": True, "message": "ok", - "data": base64.b64encode(raw).decode()}) + _raw(session, raw) out = client.export_database("ecospold2") assert out == raw url = session.post.call_args[0][0] @@ -204,8 +214,7 @@ def test_base64_decode_returns_raw_bytes(self, mocked_client): def test_format_normalized_before_send(self, mocked_client): client, session = mocked_client - _ok(session, {"success": True, "message": "ok", - "data": base64.b64encode(b"x").decode()}) + _raw(session, b"x") client.export_database(" SimaPro ") assert session.post.call_args[1]["json"] == {"format": "simapro"} @@ -215,23 +224,31 @@ def test_unknown_format_raises_before_request(self, mocked_client): client.export_database("parquet") session.post.assert_not_called() - def test_in_band_failure_raises(self, mocked_client): + def test_http_error_raises(self, mocked_client): client, session = mocked_client - _ok(session, {"success": False, "message": "not loaded", "data": None}) + from tests.conftest import _make_response + + session.post.return_value = _make_response( + {"error": "Database not loaded: testdb"}, status=404 + ) with pytest.raises(VoLCAError, match="not loaded"): client.export_database("simapro") - def test_missing_data_raises(self, mocked_client): + def test_warnings_header_surfaced(self, mocked_client): client, session = mocked_client - _ok(session, {"success": True, "message": "ok", "data": None}) - with pytest.raises(VoLCAError, match="no data field"): - client.export_database("simapro") + header = urllib.parse.quote("orphan waste in Café crème\nsecond warning") + _raw(session, b"x", warnings_header=header) + with pytest.warns(UserWarning) as caught: + client.export_database("brightway") + assert [str(w.message) for w in caught] == [ + "orphan waste in Café crème", + "second warning", + ] - def test_to_file_writes_decoded_bytes(self, mocked_client, tmp_path): + def test_to_file_writes_bytes(self, mocked_client, tmp_path): client, session = mocked_client raw = b"hello bytes" - _ok(session, {"success": True, "message": "ok", - "data": base64.b64encode(raw).decode()}) + _raw(session, raw) out = tmp_path / "export.csv" client.export_to_file("simapro", str(out)) assert out.read_bytes() == raw diff --git a/src/API/DatabaseHandlers.hs b/src/API/DatabaseHandlers.hs index 2342575c..772a7b29 100644 --- a/src/API/DatabaseHandlers.hs +++ b/src/API/DatabaseHandlers.hs @@ -55,7 +55,6 @@ import Control.Monad (mfilter, void) import Control.Monad.Catch (finally) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BSL import Data.List (isPrefixOf) import qualified Data.Map as M @@ -64,6 +63,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import Data.Word (Word64) +import Network.HTTP.Types.URI (urlEncode) import Servant (Header, Headers, ServerError, SourceIO, addHeader, err400, err404, err500, errBody, throwError) import qualified Servant.Types.SourceT as S import qualified System.Directory @@ -85,7 +85,6 @@ import API.Types ( DeleteSelectionRequest (..), DeleteSelectionResponse (..), ExportRequest (..), - ExportResponse (..), LoadDatabaseResponse (..), RefDataListResponse (..), RefDataStatusAPI (..), @@ -276,21 +275,26 @@ deleteActivitiesHandler dbName req = do ("Deleted " <> T.pack (show deleted) <> " activities from " <> dbName) deleted -{- | Export a loaded database, returning the serialized bytes base64-encoded. -EcoSpold 2 / ILCD multi-file trees are zipped; single-file formats carry their -bytes directly. Mirrors the upload endpoint's base64 convention. Failures surface -as HTTP errors — 400 for an unknown format or data the target format cannot -represent, 404 for a database that is not loaded — never a 200 with a failure flag. +{- | Export a loaded database as a raw octet-stream body — the same shape the +upload endpoint reads, and the only response cheap enough for a multi-hundred-MB +archive (a base64 JSON envelope costs +33% and four full copies before the +first byte leaves). EcoSpold 2 / ILCD multi-file trees are zipped; single-file +formats carry their bytes directly. Best-effort approximation warnings ride the +@X-Volca-Export-Warnings@ header, percent-encoded because activity names are +arbitrary Unicode and joined with newlines. Failures surface as HTTP errors — +400 for an unknown format or data the target format cannot represent, 404 for a +database that is not loaded — never a 200 with a failure flag. -} -exportDatabaseHandler :: Text -> ExportRequest -> AppM ExportResponse +exportDatabaseHandler :: Text -> ExportRequest -> AppM (Headers '[Header "X-Volca-Export-Warnings" Text] BinaryContent) exportDatabaseHandler dbName req = do dbManager <- asks aeDbManager fmt <- either (httpErr err400) pure (parseExportFormat (exrFormat req)) mLoaded <- liftIO (getDatabase dbManager dbName) ld <- maybe (httpErr err404 ("Database not loaded: " <> dbName)) pure mLoaded (bytes, warnings) <- either (httpErr err400) pure (serializeDatabase fmt (ldDatabase ld)) - pure (ExportResponse (T.decodeUtf8 (B64.encode (BSL.toStrict bytes))) warnings) + pure (addHeader (encodeWarnings warnings) (BinaryContent bytes)) where + encodeWarnings = T.decodeUtf8 . urlEncode False . T.encodeUtf8 . T.intercalate "\n" httpErr :: ServerError -> Text -> AppM a httpErr status msg = throwError status{errBody = BSL.fromStrict (T.encodeUtf8 msg)} diff --git a/src/API/Routes.hs b/src/API/Routes.hs index baed51ff..2cbb464d 100644 --- a/src/API/Routes.hs +++ b/src/API/Routes.hs @@ -10,7 +10,7 @@ module API.Routes where import API.DatabaseHandlers (simpleAction) import qualified API.DatabaseHandlers as DBHandlers import qualified API.OpenApi -import API.Types (ActivateResponse (..), ActivityContribution (..), ActivityInfo (..), ActivitySummary (..), Aggregation (..), BatchImpactsEntry (..), BatchImpactsRequest (..), BatchImpactsResponse (..), BinaryContent (..), CharacterizationEntry (..), CharacterizationResult (..), ClassificationEntryInfo (..), ClassificationPresetInfo (..), ClassificationSystem (..), ConsumersResponse (..), ContributingActivitiesResult (..), ContributingFlowsResult (..), CutoffWasteFlow (..), DatabaseListResponse (..), DeleteSelectionRequest (..), DeleteSelectionResponse (..), ExchangeDetail (..), ExportRequest (..), ExportResponse (..), FlowCFEntry (..), FlowCFMapping (..), FlowContributionEntry (..), FlowDetail (..), FlowSearchResult (..), FlowSummary (..), GraphExport (..), InventoryExport (..), LCIABatchResult (..), LCIAResult (..), LoadDatabaseResponse (..), MappingStatus (..), MethodCollectionListResponse (..), MethodCollectionStatusAPI (..), MethodDetail (..), MethodFactorAPI (..), MethodSummary (..), PerturbedEntry (..), RefDataListResponse (..), RelinkRequest (..), RelinkResponse (..), ScoringIndicator (..), SearchResults (..), SensitivityRequest (..), SensitivityResponse (..), SubstitutionRequest (..), SupplyChainResponse (..), SynonymGroupsResponse (..), TreeExport (..), UnmappedFlowAPI (..), UploadChunk (..), UploadResponse (..), apiFlowOfKind) +import API.Types (ActivateResponse (..), ActivityContribution (..), ActivityInfo (..), ActivitySummary (..), Aggregation (..), BatchImpactsEntry (..), BatchImpactsRequest (..), BatchImpactsResponse (..), BinaryContent (..), CharacterizationEntry (..), CharacterizationResult (..), ClassificationEntryInfo (..), ClassificationPresetInfo (..), ClassificationSystem (..), ConsumersResponse (..), ContributingActivitiesResult (..), ContributingFlowsResult (..), CutoffWasteFlow (..), DatabaseListResponse (..), DeleteSelectionRequest (..), DeleteSelectionResponse (..), ExchangeDetail (..), ExportRequest (..), FlowCFEntry (..), FlowCFMapping (..), FlowContributionEntry (..), FlowDetail (..), FlowSearchResult (..), FlowSummary (..), GraphExport (..), InventoryExport (..), LCIABatchResult (..), LCIAResult (..), LoadDatabaseResponse (..), MappingStatus (..), MethodCollectionListResponse (..), MethodCollectionStatusAPI (..), MethodDetail (..), MethodFactorAPI (..), MethodSummary (..), PerturbedEntry (..), RefDataListResponse (..), RelinkRequest (..), RelinkResponse (..), ScoringIndicator (..), SearchResults (..), SensitivityRequest (..), SensitivityResponse (..), SubstitutionRequest (..), SupplyChainResponse (..), SynonymGroupsResponse (..), TreeExport (..), UnmappedFlowAPI (..), UploadChunk (..), UploadResponse (..), apiFlowOfKind) import App.Env (AppEnv (..), AppM, runApp) import qualified Config import Control.Concurrent.Async (mapConcurrently) @@ -124,8 +124,9 @@ type LCAAPI = :<|> "db" :> Capture "dbName" Text :> Delete '[JSON] ActivateResponse -- Delete the whole filtered set of activities (selection in JSON body) :<|> "db" :> Capture "dbName" Text :> "delete" :> ReqBody '[JSON] DeleteSelectionRequest :> Post '[JSON] DeleteSelectionResponse - -- Export a loaded database to a serialized (base64) file in the requested format - :<|> "db" :> Capture "dbName" Text :> "export" :> ReqBody '[JSON] ExportRequest :> Post '[JSON] ExportResponse + -- Export a loaded database as raw bytes in the requested format; + -- approximation warnings travel percent-encoded in a response header + :<|> "db" :> Capture "dbName" Text :> "export" :> ReqBody '[JSON] ExportRequest :> Post '[OctetStream] (Headers '[Header "X-Volca-Export-Warnings" Text] BinaryContent) -- Upload endpoint (streamed octet-stream body; metadata in query params) :<|> "db" :> "upload" :> QueryParam "name" Text :> QueryParam "description" Text :> StreamBody NoFraming OctetStream (SourceIO UploadChunk) :> Post '[JSON] UploadResponse -- Database setup endpoints (for cross-DB linking configuration) diff --git a/src/API/Types.hs b/src/API/Types.hs index b4cd683f..fbe798e0 100644 --- a/src/API/Types.hs +++ b/src/API/Types.hs @@ -797,19 +797,6 @@ newtype ExportRequest = ExportRequest deriving (Generic) deriving (ToJSON, FromJSON, ToSchema) via (Stripped ExportRequest) -{- | Response for a successful database export: the serialized database, -base64-encoded (single-file formats carry their bytes directly; EcoSpold 2 / -ILCD are zipped), mirroring the upload endpoint's base64 convention. Failures are -HTTP errors (400 bad format / unexportable data, 404 not loaded), never a -success flag in a 200 body — so the type cannot represent "success with no data". --} -data ExportResponse = ExportResponse - { exrespData :: Text -- Base64-encoded serialized database - , exrespWarnings :: [Text] -- Best-effort approximations; empty on a faithful export - } - deriving (Generic) - deriving (ToJSON, FromJSON, ToSchema) via (Stripped ExportResponse) - -- | Response for database upload data UploadResponse = UploadResponse { uprSuccess :: Bool diff --git a/src/BrightwayExcel/Parser.hs b/src/BrightwayExcel/Parser.hs index b80fd606..d7ed2d8a 100644 --- a/src/BrightwayExcel/Parser.hs +++ b/src/BrightwayExcel/Parser.hs @@ -335,6 +335,7 @@ rawToActivity cfg ra = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } {- | Build the reference-product (or coproduct) exchange from a @production@ row, diff --git a/src/BrightwayExcel/Writer.hs b/src/BrightwayExcel/Writer.hs index 2b41e4aa..45fe0655 100644 --- a/src/BrightwayExcel/Writer.hs +++ b/src/BrightwayExcel/Writer.hs @@ -64,7 +64,6 @@ module BrightwayExcel.Writer ( renderCategories, ) where -import Codec.Archive.Zip (addEntryToArchive, emptyArchive, fromArchive, toEntry) import qualified Data.ByteString.Lazy as BL import Data.Char (chr, ord) import Data.List (sortOn) @@ -78,6 +77,7 @@ import Amount (readAmount) import BrightwayExcel.Parser (isResourceCompartment) import EcoSpold.Common (showFFloatTrim) import Types +import Zip (zipFiles) -- --------------------------------------------------------------------------- -- Configuration @@ -126,16 +126,13 @@ renderWorkbook :: WriterConfig -> SimpleDatabase -> Either Text BL.ByteString renderWorkbook cfg db = do checkBrightwayExportable db pure $ - fromArchive $ - foldr - addEntryToArchive - emptyArchive - [ toEntry "xl/workbook.xml" 0 (enc workbookXml) - , toEntry "xl/_rels/workbook.xml.rels" 0 (enc relsXml) - , toEntry "xl/worksheets/sheet1.xml" 0 (enc (sheetXml (sheetRows cfg db))) - ] + zipFiles + [ ("xl/workbook.xml", enc workbookXml) + , ("xl/_rels/workbook.xml.rels", enc relsXml) + , ("xl/worksheets/sheet1.xml", enc (sheetXml (sheetRows cfg db))) + ] where - enc = BL.fromStrict . TE.encodeUtf8 + enc = TE.encodeUtf8 {- | Guard a Brightway Excel export against exchanges the writer cannot encode. 'exchangeRow' resolves each exchange's flow name and unit name from the database diff --git a/src/CLI/Client.hs b/src/CLI/Client.hs index 8d175d5f..b153eca0 100644 --- a/src/CLI/Client.hs +++ b/src/CLI/Client.hs @@ -17,7 +17,6 @@ import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (Parser, parseMaybe, withArray, withObject) import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BSL @@ -35,14 +34,18 @@ import Network.HTTP.Client ( Manager, Request (method, requestBody, requestHeaders), RequestBody (..), + Response, httpLbs, parseRequest, responseBody, + responseHeaders, responseStatus, setQueryString, ) +import Network.HTTP.Types.Header (HeaderName) import Network.HTTP.Types.Status (statusCode) -import Progress (reportError) +import Network.HTTP.Types.URI (urlDecode) +import Progress (ProgressLevel (Warning), reportError, reportProgress) import System.Environment (lookupEnv) import System.Exit (exitFailure) import System.IO (IOMode (ReadMode), hFileSize, withBinaryFile) @@ -285,28 +288,35 @@ relinkMappingBody depDb csv = , "mappingCsv" .= csv ] -{- | Remote export: POST the target format, base64-decode the bytes the server -returns (serialization happens server-side), and write them to @--out@. Mirrors -the local export's output summary. Failures (bad format, db not loaded, invalid -base64) surface loudly rather than writing a partial/empty file. +{- | Remote export: POST the target format and write the raw bytes the server +returns (serialization happens server-side) to @--out@. Approximation warnings +arrive percent-encoded in the @X-Volca-Export-Warnings@ header and are +reported, not fatal. Failures (bad format, db not loaded) surface loudly +rather than writing a partial/empty file. -} executeRemoteExport :: Manager -> RemoteConfig -> OutputFormat -> Maybe Text -> DbExportArgs -> IO () executeRemoteExport mgr rc fmt jp args = do - resp <- apiPost mgr rc ("/api/v1/db/" ++ T.unpack (deaDb args) ++ "/export") (object ["format" .= deaFormat args]) + resp <- apiPostRaw mgr rc ("/api/v1/db/" ++ T.unpack (deaDb args) ++ "/export") (object ["format" .= deaFormat args]) case resp of -- A failed export (bad format, db not loaded, unexportable data) arrives -- as a non-2xx HTTP status, surfaced here as 'Left'. Left err -> reportError err >> exitFailure - Right val -> case parseMaybe parseExportData val of - Nothing -> reportError "export: malformed server response" >> exitFailure - Just b64 -> case B64.decode (T.encodeUtf8 b64) of - Left derr -> reportError ("export: invalid base64 from server: " ++ derr) >> exitFailure - Right bytes -> do - C8.writeFile (deaOut args) bytes - output fmt jp (Right (object ["database" .= deaDb args, "format" .= deaFormat args, "out" .= deaOut args])) - where - parseExportData :: Value -> Parser Text - parseExportData = withObject "ExportResponse" $ \o -> o .: "data" + Right r -> do + mapM_ (reportProgress Warning . T.unpack) (exportWarnings r) + BL.writeFile (deaOut args) (responseBody r) + output fmt jp (Right (object ["database" .= deaDb args, "format" .= deaFormat args, "out" .= deaOut args])) + +{- | Decode the @X-Volca-Export-Warnings@ response header: percent-decode, then +split on the newlines the server joined with. Absent or empty header = no +warnings. +-} +exportWarnings :: Response BL.ByteString -> [Text] +exportWarnings r = + [ w + | Just raw <- [lookup "X-Volca-Export-Warnings" (responseHeaders r)] + , w <- T.splitOn "\n" (T.decodeUtf8 (urlDecode False raw)) + , not (T.null w) + ] -- | Build query string from optional parameters buildQuery :: [(String, Maybe String)] -> String @@ -349,7 +359,7 @@ apiUploadFile mgr rc path args = do req0 { Network.HTTP.Client.method = "POST" , requestHeaders = - authHeaders ++ [("Content-Type", "application/octet-stream")] ++ requestHeaders req0 + authHeaders rc ++ [("Content-Type", "application/octet-stream")] ++ requestHeaders req0 , requestBody = body } httpLbs req1 mgr @@ -361,10 +371,6 @@ apiUploadFile mgr rc path args = do in if status >= 200 && status < 300 then return $ Right $ fromMaybe (object []) (decode respBody) else return $ Left $ formatApiError status respBody - where - authHeaders = case rcAuth rc of - Just pwd -> [("Authorization", "Bearer " <> C8.pack pwd)] - Nothing -> [] -- | Build a constant-memory streaming request body from a file on disk. fileRequestBody :: FilePath -> IO RequestBody @@ -482,6 +488,11 @@ formatTable (headers, rows) = where maxColWidth = 60 +authHeaders :: RemoteConfig -> [(HeaderName, BS.ByteString)] +authHeaders rc = case rcAuth rc of + Just pwd -> [("Authorization", "Bearer " <> C8.pack pwd)] + Nothing -> [] + -- | HTTP GET, POST, DELETE helpers apiGet :: Manager -> RemoteConfig -> String -> IO (Either String Value) apiGet mgr rc path = apiRequest mgr rc "GET" path Nothing @@ -492,6 +503,29 @@ apiPost mgr rc path body = apiRequest mgr rc "POST" path (Just body) apiDelete :: Manager -> RemoteConfig -> String -> IO (Either String Value) apiDelete mgr rc path = apiRequest mgr rc "DELETE" path Nothing +{- | POST a JSON body and return the raw response (bytes + headers), for +octet-stream endpoints like database export. Shares the error formatting of +'apiRequest' but skips its JSON decoding. +-} +apiPostRaw :: Manager -> RemoteConfig -> String -> Value -> IO (Either String (Response BL.ByteString)) +apiPostRaw mgr rc path body = do + result <- try $ do + req0 <- parseRequest (rcBaseUrl rc ++ path) + httpLbs + req0 + { Network.HTTP.Client.method = "POST" + , requestHeaders = authHeaders rc ++ [("Content-Type", "application/json")] ++ requestHeaders req0 + , requestBody = RequestBodyLBS (encode body) + } + mgr + pure $ case result of + Left e -> Left (formatHttpError (rcBaseUrl rc) e) + Right resp -> + let status = statusCode (responseStatus resp) + in if status >= 200 && status < 300 + then Right resp + else Left (formatApiError status (responseBody resp)) + -- | Core HTTP request helper with error handling apiRequest :: Manager -> RemoteConfig -> String -> String -> Maybe Value -> IO (Either String Value) apiRequest mgr rc reqMethod path mBody = do @@ -501,7 +535,7 @@ apiRequest mgr rc reqMethod path mBody = do let req1 = req0 { Network.HTTP.Client.method = C8.pack reqMethod - , requestHeaders = authHeaders ++ contentHeaders ++ requestHeaders req0 + , requestHeaders = authHeaders rc ++ contentHeaders ++ requestHeaders req0 } req2 = case mBody of Just body -> req1{requestBody = RequestBodyLBS (encode body)} @@ -516,9 +550,6 @@ apiRequest mgr rc reqMethod path mBody = do then return $ Right $ fromMaybe (object []) (decode body) else return $ Left $ formatApiError status body where - authHeaders = case rcAuth rc of - Just pwd -> [("Authorization", "Bearer " <> C8.pack pwd)] - Nothing -> [] contentHeaders = case mBody of Just _ -> [("Content-Type", "application/json")] Nothing -> [] diff --git a/src/CLI/Command.hs b/src/CLI/Command.hs index 095aaf29..0846e55a 100644 --- a/src/CLI/Command.hs +++ b/src/CLI/Command.hs @@ -564,7 +564,8 @@ executeDbExport fmt manager args = result <- exportDatabase dbFmt (ldDatabase ld) (deaOut args) case result of Left err -> reportError (T.unpack err) >> exitFailure - Right () -> do + Right warnings -> do + mapM_ (reportProgress Warning . T.unpack) warnings reportProgress Info $ "Exported " ++ T.unpack (deaDb args) ++ " -> " ++ deaOut args outputResult fmt $ object diff --git a/src/Database/Export.hs b/src/Database/Export.hs index e47b0f41..42d8e11a 100644 --- a/src/Database/Export.hs +++ b/src/Database/Export.hs @@ -18,7 +18,6 @@ module Database.Export ( parseExportFormat, ) where -import qualified Codec.Archive.Zip as Zip import Control.Exception (SomeException, try) import qualified Data.ByteString.Lazy as BL import Data.Text (Text) @@ -32,17 +31,19 @@ import qualified EcoSpold.Writer2 as ES2 import qualified ILCD.Writer as ILCD import qualified SimaPro.Writer as SP import Types (Database, toSimpleDatabase) +import Zip (zipFiles) {- | Serialize a database to a single byte stream in the requested format, paired with any best-effort approximation warnings. Pure: the multi-file formats are zipped in-memory. Fails loudly for formats without a writer. The warning list is empty for a faithful export and non-empty when a writer had -to approximate. Currently only the Brightway writer approximates: it has no waste -type, so it rewrites /orphan/ waste exchanges as technosphere flows -(inventory-neutral, but the waste tag is lost on re-import) and reports the -affected activities. Returning bytes and warnings together shares the one -'toSimpleDatabase' conversion and keeps them from drifting apart. +to approximate. Two writers approximate today: Brightway has no waste type, so +it rewrites /orphan/ waste exchanges as technosphere flows (inventory-neutral, +but the waste tag is lost on re-import); ILCD keys one process per dataset UUID, +so a multi-output activity's products export as separate, unlinked datasets +('ILCD.Writer.splitWarnings'). Returning bytes and warnings together shares the +one 'toSimpleDatabase' conversion and keeps them from drifting apart. -} serializeDatabase :: DatabaseFormat -> Database -> Either Text (BL.ByteString, [Text]) serializeDatabase fmt db = case fmt of @@ -51,7 +52,7 @@ serializeDatabase fmt db = case fmt of SimaProCSV -> noWarn (BL.fromStrict <$> SP.serializeSimaProCSV SP.defaultWriterConfig sdb) EcoSpold1 -> noWarn (BL.fromStrict . TE.encodeUtf8 <$> ES1.writeDatabase ES1.canonicalWriterOptions db) EcoSpold2 -> noWarn (zipText <$> ES2.writeEcoSpold2 ES2.noVolatileMeta sdb) - ILCDProcess -> noWarn (ILCD.writeILCDArchive ILCD.defaultWriteOptions sdb) + ILCDProcess -> (,ILCD.splitWarnings sdb) <$> ILCD.writeILCDArchive ILCD.defaultWriteOptions sdb BrightwayExcel -> (,BE.wasteManifest sdb) <$> BE.renderWorkbook BE.defaultWriterConfig sdb OpenLcaJsonLd -> Left "openLCA JSON-LD export is not supported" @@ -74,20 +75,18 @@ parseExportFormat raw = case T.toLower (T.strip raw) of "brightway" -> Right BrightwayExcel other -> Left ("unknown export format: " <> other <> " (expected simapro|ecospold1|ecospold2|ilcd|brightway)") --- | Serialize a database and write it to @path@. -exportDatabase :: DatabaseFormat -> Database -> FilePath -> IO (Either Text ()) +{- | Serialize a database and write it to @path@, returning the approximation +warnings so the caller can report them — a local export approximates exactly as +much as a remote one. +-} +exportDatabase :: DatabaseFormat -> Database -> FilePath -> IO (Either Text [Text]) exportDatabase fmt db path = case serializeDatabase fmt db of Left err -> pure (Left err) - Right (bytes, _warnings) -> either (Left . renderErr) Right <$> try (BL.writeFile path bytes) + Right (bytes, warnings) -> either (Left . renderErr) (const (Right warnings)) <$> try (BL.writeFile path bytes) where renderErr :: SomeException -> Text renderErr e = "export failed: " <> T.pack (show e) --- | Pack @(path, text)@ entries into a deterministic zip (epoch-0 mtimes). +-- | Pack @(path, text)@ entries into a deterministic zip. zipText :: [(FilePath, Text)] -> BL.ByteString -zipText = Zip.fromArchive . foldl addOne Zip.emptyArchive - where - addOne arc (p, t) = - Zip.addEntryToArchive - (Zip.toEntry p 0 (BL.fromStrict (TE.encodeUtf8 t))) - arc +zipText = zipFiles . map (fmap TE.encodeUtf8) diff --git a/src/Database/MatrixBuild.hs b/src/Database/MatrixBuild.hs index cd4ed309..4e56cae3 100644 --- a/src/Database/MatrixBuild.hs +++ b/src/Database/MatrixBuild.hs @@ -20,7 +20,6 @@ module Database.MatrixBuild ( import Control.Applicative ((<|>)) import Data.Foldable (fold) import Data.Int (Int32) -import Data.List (sort) import qualified Data.Map as M import qualified Data.Set as S import Data.Text (Text) @@ -31,16 +30,17 @@ import qualified Data.Vector.Unboxed as VU import Types import UnitConversion (UnitConfig, convertUnit, normalizeUnit) -{- | Per-process lookup tables built once from the sorted activity-key list. +{- | Per-process lookup tables built once from the ascending activity-key list. -All fields share a single 'zip' [0..] sortedKeys' traversal, so row order -and ProcessId ↔ (UUID, UUID) consistency hold by construction. +All fields share a single 'zip' [0..] (M.toAscList activityMap)' traversal, so +row order and ProcessId ↔ (UUID, UUID) consistency hold by construction, and the +activity of each row is the one its key maps to. -} data InterningTables = InterningTables { itProcessIdTable :: !(V.Vector (UUID, UUID)) , itProcessIdLookup :: !(M.Map (UUID, UUID) ProcessId) , itActivityUUIDIndex :: !(M.Map UUID ProcessId) - , itActivityProductsIndex :: !(M.Map UUID [ProcessId]) + , itActivityProductsIndex :: !(M.Map (UUID, Maybe NativeProcessId) [ProcessId]) , itActivities :: !(V.Vector Activity) , itActivityCount :: !Int32 } @@ -48,16 +48,18 @@ data InterningTables = InterningTables buildInterningTables :: M.Map (UUID, UUID) Activity -> InterningTables buildInterningTables activityMap = InterningTables - { itProcessIdTable = V.fromList sortedKeys - , itProcessIdLookup = M.fromList [(k, pid) | (pid, k) <- indexedKeys] - , itActivityUUIDIndex = M.fromList [(actUUID, pid) | (pid, (actUUID, _)) <- indexedKeys] - , itActivityProductsIndex = M.fromListWith (++) [(actUUID, [pid]) | (pid, (actUUID, _)) <- indexedKeys] - , itActivities = V.fromList [activityMap M.! k | k <- sortedKeys] - , itActivityCount = fromIntegral (length sortedKeys) + { itProcessIdTable = V.fromList [k | (_, k, _) <- indexed] + , itProcessIdLookup = M.fromList [(k, pid) | (pid, k, _) <- indexed] + , itActivityUUIDIndex = M.fromList [(actUUID, pid) | (pid, (actUUID, _), _) <- indexed] + , itActivityProductsIndex = + M.fromListWith (++) [(activityGroupKey actUUID act, [pid]) | (pid, (actUUID, _), act) <- indexed] + , itActivities = V.fromList [act | (_, _, act) <- indexed] + , itActivityCount = fromIntegral (length indexed) } where - sortedKeys = sort (M.keys activityMap) - indexedKeys = zip [0 ..] sortedKeys + -- 'M.toAscList' is already sorted on the key, so this is the same row order + -- as before, with the activity carried alongside instead of looked up again. + indexed = [(pid, k, act) | (pid, (k, act)) <- zip [0 ..] (M.toAscList activityMap)] {- | Reference-product output unit for each activity (empty when the activity has no produced reference exchange — same fallback as the previous inline diff --git a/src/EcoSpold/Parser1.hs b/src/EcoSpold/Parser1.hs index c6bbe15e..5e58b0a4 100644 --- a/src/EcoSpold/Parser1.hs +++ b/src/EcoSpold/Parser1.hs @@ -460,7 +460,7 @@ buildResult st = filter (not . T.null . snd) [("Category", psActivityCategory st), ("SubCategory", psActivitySubCategory st)] - activity = Activity name description M.empty classifications location refUnit (reverse $ psExchanges st) M.empty M.empty Nothing Nothing Nothing + activity = Activity name description M.empty classifications location refUnit (reverse $ psExchanges st) M.empty M.empty Nothing Nothing Nothing Nothing pack act = ( act , reverse (psTechFlows st) diff --git a/src/EcoSpold/Parser2.hs b/src/EcoSpold/Parser2.hs index 57d24f85..d7023af2 100644 --- a/src/EcoSpold/Parser2.hs +++ b/src/EcoSpold/Parser2.hs @@ -669,7 +669,7 @@ parseWithXeno xmlContent processId = do refUnit = fromMaybe "UNKNOWN_UNIT" (psRefUnit st) nativeType = ecoSpoldNativeType (psActivityType st) (psSpecialActivityType st) -- Apply cutoff strategy to exchanges - activity = Activity name description M.empty (psClassifications st) location refUnit (reverse $ psExchanges st) M.empty M.empty Nothing Nothing nativeType + activity = Activity name description M.empty (psClassifications st) location refUnit (reverse $ psExchanges st) M.empty M.empty Nothing Nothing nativeType Nothing techs = reverse (psTechFlows st) bios = reverse (psBioFlows st) wastes = reverse (psWasteFlows st) diff --git a/src/ILCD/Parser.hs b/src/ILCD/Parser.hs index b9410731..ea213187 100644 --- a/src/ILCD/Parser.hs +++ b/src/ILCD/Parser.hs @@ -570,6 +570,7 @@ buildActivity flowInfoMap techFlowDB bioFlowDB wasteFlowDB unitDB p = if T.null (iprProcessType p) then Nothing else Just (ILCDProcessType{iptLabel = iprProcessType p}) + , activityNativeId = Nothing } where -- Look up the reference exchange's flow unit. Reference exchange is typically diff --git a/src/ILCD/Writer.hs b/src/ILCD/Writer.hs index ac6320f6..49e67196 100644 --- a/src/ILCD/Writer.hs +++ b/src/ILCD/Writer.hs @@ -8,7 +8,7 @@ The output is a canonical, deterministic ILCD directory tree (and, optionally, a zip of it) with four subdirectories: @ - processes/ one XML per activity (keyed by activity UUID) + processes/ one XML per (activity, product) pair (see 'ilcdProcessUUID') flows/ one XML per tech/bio/waste flow flowproperties/ one XML per unit group (1:1 with units) unitgroups/ one XML per unit @@ -50,28 +50,33 @@ module ILCD.Writer ( escapeXml, escapeXmlAttr, formatDouble, + ilcdProcessUUID, + sharedActivityUUIDs, + splitWarnings, processXML, flowXML, flowPropertyXML, unitGroupXML, ) where -import Codec.Archive.Zip (addEntryToArchive, emptyArchive, fromArchive, toEntry) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Either (lefts) import Data.List (sortOn) import qualified Data.Map.Strict as M +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.UUID as UUID +import qualified Data.UUID.V5 as UUID5 import System.Directory (createDirectoryIfMissing) import System.FilePath (joinPath, splitDirectories, ()) import Amount (readAmount) import EcoSpold.Common (showFFloatTrim) import Types +import Zip (zipFiles) -------------------------------------------------------------------------------- -- Options @@ -93,6 +98,62 @@ data WriteOptions = WriteOptions defaultWriteOptions :: WriteOptions defaultWriteOptions = WriteOptions{woTimestamp = Nothing, woGenerator = Nothing} +-------------------------------------------------------------------------------- +-- Process dataset identity +-------------------------------------------------------------------------------- + +-- | Namespace for the UUIDs this writer has to mint itself. +ilcdExportNamespace :: UUID +ilcdExportNamespace = + UUID5.generateNamed UUID5.namespaceURL (BS.unpack (TE.encodeUtf8 "ilcd-export")) + +-- | The activity UUIDs carried by more than one @(activity, product)@ entry. +sharedActivityUUIDs :: SimpleDatabase -> S.Set UUID +sharedActivityUUIDs db = + M.keysSet . M.filter (> (1 :: Int)) . M.fromListWith (+) $ + [(actUUID, 1) | (actUUID, _) <- M.keys (sdbActivities db)] + +{- | The @common:UUID@ — and the filename — of one exported process dataset. + +ILCD keys a process by a single dataset UUID, one process per file. An activity +UUID shared by several @(activity, product)@ entries therefore cannot name them +all: a multi-output activity, or a name collision in the source format, would +write every product to the same file. Such an entry gets a UUID derived from its +pair instead; an unshared activity UUID passes through unchanged. + +That condition is what makes the mapping a fixed point of @parse . write@: the +parser reads @common:UUID@ back as the activity UUID, and every re-imported +process is single-output, so a second export reproduces the first byte for byte. +Deriving unconditionally would not — @UUID5(UUID5(a,p),p) /= UUID5(a,p)@. +-} +ilcdProcessUUID :: S.Set UUID -> (UUID, UUID) -> UUID +ilcdProcessUUID sharedActUUIDs (actUUID, prodUUID) + | actUUID `S.member` sharedActUUIDs = + UUID5.generateNamed ilcdExportNamespace $ + BS.unpack (TE.encodeUtf8 ("process:" <> uuidText actUUID <> "_" <> uuidText prodUUID)) + | otherwise = actUUID + +{- | One warning per activity whose products 'ilcdProcessUUID' spreads over +several process datasets. Every product is kept, but ILCD has no way to say +the datasets came from one activity, so a re-import yields independent +single-output activities — the grouping is the one thing the export loses, +and the caller deserves to hear about it rather than discover it on re-import. +Empty when every activity UUID is unique. +-} +splitWarnings :: SimpleDatabase -> [Text] +splitWarnings db = + [ "multi-output activity \"" + <> activityName act + <> "\" (UUID " + <> uuidText actUUID + <> "): its " + <> T.pack (show (length acts)) + <> " products export as separate ILCD process datasets; their grouping is lost on re-import" + | (actUUID, acts@(act : _ : _)) <- M.toAscList byActivity + ] + where + byActivity = M.fromListWith (++) [(actUUID, [act]) | ((actUUID, _), act) <- M.toAscList (sdbActivities db)] + -------------------------------------------------------------------------------- -- Top-level: directory / archive -------------------------------------------------------------------------------- @@ -109,9 +170,12 @@ the native separator before touching disk. ilcdFiles :: WriteOptions -> SimpleDatabase -> [(FilePath, BS.ByteString)] ilcdFiles opts db = sortOn fst (processes ++ flows ++ flowProps ++ unitGroups) where + shared = sharedActivityUUIDs db + processes = - [ ("processes/" <> uuidStr actUUID <> ".xml", render (processXML opts actUUID act)) - | ((actUUID, _prodUUID), act) <- M.toAscList (sdbActivities db) + [ ("processes/" <> uuidStr dsUUID <> ".xml", render (processXML opts dsUUID act)) + | (pair, act) <- M.toAscList (sdbActivities db) + , let dsUUID = ilcdProcessUUID shared pair ] flows = @@ -132,13 +196,11 @@ ilcdFiles opts db = sortOn fst (processes ++ flows ++ flowProps ++ unitGroups) -- Render the list of lines to canonical UTF-8 bytes. render = TE.encodeUtf8 . renderLines -{- | Guard an ILCD export against data the parser cannot read back losslessly: +{- | Guard an ILCD export against data the parser cannot read back losslessly. -* /Multi-output activities./ ILCD identifies a process by a single dataset UUID - with one process per file, keyed here on the activity UUID alone. A - multi-output activity — several @(actUUID, prodUUID)@ entries sharing one - @actUUID@ — would therefore write two processes to the same filename and the - same @common:UUID@, and re-import could only keep one. +A multi-output activity is /not/ one of those: ILCD keys a process by a single +dataset UUID, but 'ilcdProcessUUID' hands each @(activity, product)@ entry a +distinct one, so each product becomes its own process dataset. * /Non-canonical biosphere media./ 'compartmentBlock' emits @"Emissions to "@ for any non-resource medium, but the parser's @extractMedium@ only @@ -157,14 +219,13 @@ ilcdFiles opts db = sortOn fst (processes ++ flows ++ flowProps ++ unitGroups) (@NaN@\/@Infinity@) that would otherwise shift LCIA scores on re-import. Rather than silently corrupting any of these, report the first offending flow, -activity or exchange so the caller can fail loudly. Databases whose activity -UUIDs are all unique, whose biosphere media are all canonical, whose -classification levels are all non-empty and whose amounts all re-parse pass -unchanged. +activity or exchange so the caller can fail loudly. Databases whose biosphere +media are all canonical, whose classification levels are all non-empty and whose +amounts all re-parse pass unchanged. -} checkILCDExportable :: SimpleDatabase -> Either Text () checkILCDExportable db = - case lefts [checkMedia, checkMultiOutput, checkClassifications, checkAmounts] of + case lefts [checkMedia, checkClassifications, checkAmounts] of [] -> Right () violations -> Left (T.intercalate "\n\n" violations) where @@ -188,20 +249,6 @@ checkILCDExportable db = Nothing -> False Just c -> canonicalMedium (compartmentName c) `notElem` canonicalMedia - checkMultiOutput = - case M.toList collisions of - [] -> Right () - ((actUUID, n) : _) -> - Left $ - "ILCD export cannot represent multi-output activity \"" - <> nameOf actUUID - <> "\" (UUID " - <> uuidText actUUID - <> "): " - <> T.pack (show n) - <> " reference products share one activity UUID, which ILCD keys a process by." - counts = M.fromListWith (+) [(actUUID, 1 :: Int) | (actUUID, _prodUUID) <- M.keys (sdbActivities db)] - collisions = M.filter (> 1) counts nameOf actUUID = case [activityName act | ((a, _), act) <- M.toList (sdbActivities db), a == actUUID] of (nm : _) -> nm @@ -270,21 +317,13 @@ writeILCDDatabase opts dir db = -- separator so the on-disk write is correct on Windows too. nativePath = joinPath . splitDirectories -{- | Build a deterministic zip 'Archive' of the ILCD package and return its -serialized bytes. Entry modification times are pinned to epoch 0 so the -archive bytes are reproducible. Runs 'checkILCDExportable' first and returns its -'Left' on a database the format cannot represent faithfully, so an unguarded -caller cannot silently emit a corrupt archive. +{- | Build a deterministic zip archive of the ILCD package and return its +serialized bytes. Runs 'checkILCDExportable' first and returns its 'Left' on a +database the format cannot represent faithfully, so an unguarded caller cannot +silently emit a corrupt archive. -} writeILCDArchive :: WriteOptions -> SimpleDatabase -> Either Text BL.ByteString -writeILCDArchive opts db = do - checkILCDExportable db - pure (fromArchive (buildArchive (ilcdFiles opts db))) - where - buildArchive = foldl addOne emptyArchive - -- Fixed epoch (0) keeps archive bytes stable across runs. - addOne arc (path, bytes) = - addEntryToArchive (toEntry path 0 (BL.fromStrict bytes)) arc +writeILCDArchive opts db = checkILCDExportable db >> pure (zipFiles (ilcdFiles opts db)) -------------------------------------------------------------------------------- -- Flow enumeration (tech ∪ bio ∪ waste), tagged with their unit id @@ -301,18 +340,19 @@ allFlows db = -- Process XML -------------------------------------------------------------------------------- -{- | Render one ILCD process dataset for an activity. The reference exchange -gets @dataSetInternalID@ matching @referenceToReferenceFlow@; remaining -exchanges follow in their list order, so the parser reads them back in the -same order it would re-serialize. +{- | Render one ILCD process dataset for an activity, under the dataset UUID +'ilcdProcessUUID' assigned it — not necessarily the activity's own UUID, which +several products may share. The reference exchange gets @dataSetInternalID@ +matching @referenceToReferenceFlow@; remaining exchanges follow in their list +order, so the parser reads them back in the same order it would re-serialize. -} processXML :: WriteOptions -> UUID -> Activity -> [Text] -processXML opts actUUID act = +processXML opts dsUUID act = [ "" , "" , " " , " " - , elem' "common:UUID" (uuidText actUUID) + , elem' "common:UUID" (uuidText dsUUID) , " " , attrElem "baseName" [("xml:lang", "en")] (activityName act) , " " diff --git a/src/Service.hs b/src/Service.hs index 07bbafc1..6050ce11 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -1013,7 +1013,7 @@ Note: This function requires the ProcessId to get the activity UUID convertActivityForAPI :: UnitConfig -> Database -> ProcessId -> Activity -> ActivityForAPI convertActivityForAPI unitCfg db processId activity = let allProducts = case processIdToUUIDs db processId of - Just (activityUUID, _) -> getAllProductsForActivity db activityUUID + Just (activityUUID, _) -> getAllProductsForActivity db (activityGroupKey activityUUID activity) Nothing -> [] (refProdName, refProdAmount, refProdUnit) = getReferenceProductInfo (dbTechFlows db) (dbUnits db) activity linkMap = buildCrossDBLinkMap db processId @@ -1209,10 +1209,13 @@ unknownActivitySummary db pid = , prsNativeType = Nothing } --- | Get all products (ProcessIds) for an activity UUID using the products index. -getAllProductsForActivity :: Database -> UUID -> [ActivitySummary] -getAllProductsForActivity db activityUUID = - case M.lookup activityUUID (dbActivityProductsIndex db) of +{- | The coproducts of one source dataset block, as 'ActivitySummary'. Keyed on +'activityGroupKey', not on the activity UUID alone: SimaPro reuses one process +name across unrelated blocks, which the UUID hashes to a single value. +-} +getAllProductsForActivity :: Database -> (UUID, Maybe NativeProcessId) -> [ActivitySummary] +getAllProductsForActivity db groupKey = + case M.lookup groupKey (dbActivityProductsIndex db) of Nothing -> [] Just processIds -> [ maybe (unknownActivitySummary db pid) (mkActivitySummary db pid) (findActivityByProcessId db pid) diff --git a/src/SimaPro/Parser.hs b/src/SimaPro/Parser.hs index 54278669..74b145d0 100644 --- a/src/SimaPro/Parser.hs +++ b/src/SimaPro/Parser.hs @@ -883,6 +883,12 @@ processBlockToActivity unitCfg GlobalParams{..} ProcessBlock{..} = descriptionLines = maybeToList (nonEmptyText pbComment) nativeType = SimaProProcessType <$> nonEmptyText pbType + -- Block identity. The coproducts below share it, so they group together even + -- though the activity UUID (a hash of name and location) is not unique: a + -- SimaPro "Process name" is truncated to 80 characters and reused verbatim + -- across unrelated blocks. + nativeId = NativeProcessId <$> nonEmptyText pbIdentifier + makeActivity :: ProductRow -> (Activity, [TechnosphereFlow], [BiosphereFlow], [WasteFlow], [Unit]) makeActivity prod = let (productExchange, productFlow, productUnit) = productToExchange unitCfg env True prod @@ -921,6 +927,7 @@ processBlockToActivity unitCfg GlobalParams{..} ProcessBlock{..} = , activityAllocationPercent = Just allocPercent , activityAllocationFormula = allocFormula , activityNativeType = nativeType + , activityNativeId = nativeId } allUnits = map diff --git a/src/Types.hs b/src/Types.hs index f756b9a7..45d088de 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -453,6 +453,19 @@ data NativeActivityType } deriving (Show, Eq, Generic, NFData, Store) +{- | The identifier a source format gives the dataset block an activity was read +from (SimaPro's @Process identifier@ header). Two blocks that happen to share a +name and a location are still two activities, and 'activityUUID' — a hash of +name and location — cannot tell them apart; this can. 'Nothing' when the source +format has no such field, which restores grouping by 'activityUUID' alone. + +Not a 'ProcessId': that one is a matrix row index, minted by 'buildInterningTables'. +This is the source's own string, opaque to us and stable only within one release +of a database. +-} +newtype NativeProcessId = NativeProcessId Text + deriving (Show, Eq, Ord, Generic, NFData, Store) + {- | Base LCA activity Note: ProcessId is the index in dbActivities vector, UUIDs stored in dbProcessIdTable -} @@ -469,9 +482,19 @@ data Activity = Activity , activityAllocationPercent :: !(Maybe Double) -- SimaPro multi-product allocation fraction (%, 0..100); Nothing for non-allocated bases , activityAllocationFormula :: !(Maybe Text) -- Raw SimaPro allocation formula (e.g. "Qp*DMp/(Qp*DMp+Qw*DMw)*100"); Nothing if purely numeric , activityNativeType :: !(Maybe NativeActivityType) -- Source-format-native activity type (ecospold @activityType, SimaPro Type, ILCD processType); Nothing when source format lacks the field + , activityNativeId :: !(Maybe NativeProcessId) -- Source dataset block this activity was read from; groups the coproducts of one block. Nothing when the source format lacks the field } deriving (Generic, NFData, Store) +{- | The coproducts of one source dataset block share this key. A SimaPro CSV +reuses one @Process name@ across unrelated blocks (it is truncated to 80 +characters, and duplicated outright), so the activity UUID alone over-groups +them; 'activityNativeId' splits them back apart. Formats without a block +identifier fall back to grouping by activity UUID, as before. +-} +activityGroupKey :: UUID -> Activity -> (UUID, Maybe NativeProcessId) +activityGroupKey actUUID act = (actUUID, activityNativeId act) + -- | LCA computation tree (recursive representation) data ActivityTree = Leaf !Activity @@ -716,7 +739,7 @@ data Database = Database dbProcessIdTable :: !(V.Vector (UUID, UUID)) -- ProcessId (Int32) → (activityUUID, productUUID) , dbProcessIdLookup :: !(M.Map (UUID, UUID) ProcessId) -- reverse lookup , dbActivityUUIDIndex :: !(M.Map UUID ProcessId) -- Activity UUID → ProcessId (for O(1) lookups) - , dbActivityProductsIndex :: !(M.Map UUID [ProcessId]) -- Activity UUID → all ProcessIds (for multi-product activities) + , dbActivityProductsIndex :: !(M.Map (UUID, Maybe NativeProcessId) [ProcessId]) -- 'activityGroupKey' → the ProcessIds of one source block (its coproducts) , dbProductIndex :: !ProductIndex -- Product flow → ProcessId lookups (for SimaPro links & product search) , dbActivities :: !ActivityDB -- Vector of activities indexed by ProcessId , dbTechFlows :: !TechFlowDB -- Technosphere flows by UUID diff --git a/src/Zip.hs b/src/Zip.hs new file mode 100644 index 00000000..732f90a8 --- /dev/null +++ b/src/Zip.hs @@ -0,0 +1,27 @@ +{- | Deterministic in-memory zip packaging. + +Entry modification times are pinned to epoch 0 so the archive bytes are +reproducible across runs. Paths must be unique: every caller derives them from a +UUID, and a duplicate would already be a writer bug. + +Building 'zEntries' directly rather than folding 'addEntryToArchive' is what +keeps this linear. That function deletes any entry sharing the new path before +consing, so it filters the whole entry list on each insert: a fold over @n@ +entries costs O(n²) 'FilePath' comparisons and stacks @n@ lazy filters before +anything is forced. On a 53 508-file ILCD package that is enough to exhaust +memory and blow the HTTP timeout. +-} +module Zip (zipFiles) where + +import Codec.Archive.Zip (Archive (..), emptyArchive, fromArchive, toEntry) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL + +{- | Pack @(path, bytes)@ entries into a zip archive, in the order given. + +Linear in the number of entries. Paths use forward slashes on every OS, as the +zip format mandates; callers are responsible for that and for uniqueness. +-} +zipFiles :: [(FilePath, BS.ByteString)] -> BL.ByteString +zipFiles files = + fromArchive emptyArchive{zEntries = [toEntry path 0 (BL.fromStrict bytes) | (path, bytes) <- files]} diff --git a/test/BM25Spec.hs b/test/BM25Spec.hs index 6eaefa97..d176c096 100644 --- a/test/BM25Spec.hs +++ b/test/BM25Spec.hs @@ -36,6 +36,7 @@ mkActivity name loc xs = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } mkRefOutput :: UUID -> Exchange diff --git a/test/BrightwayExcelWriterSpec.hs b/test/BrightwayExcelWriterSpec.hs index c932494c..b7fdc0f4 100644 --- a/test/BrightwayExcelWriterSpec.hs +++ b/test/BrightwayExcelWriterSpec.hs @@ -267,6 +267,7 @@ elec = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } prodExch :: Exchange diff --git a/test/CopySpec.hs b/test/CopySpec.hs index fe275be0..740f6351 100644 --- a/test/CopySpec.hs +++ b/test/CopySpec.hs @@ -281,6 +281,7 @@ supplierDB offset products = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } in (((actUUID, prodUUID), act), (flowUUID, flow)) | (i, name) <- zip [0 ..] products diff --git a/test/CrossDBActivityLinkSpec.hs b/test/CrossDBActivityLinkSpec.hs index 45c0e080..5c23c4d6 100644 --- a/test/CrossDBActivityLinkSpec.hs +++ b/test/CrossDBActivityLinkSpec.hs @@ -75,6 +75,7 @@ mkActivity name loc exs = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } refEx :: UUID.UUID -> Exchange diff --git a/test/CrossDBRegionalLCIAFixture.hs b/test/CrossDBRegionalLCIAFixture.hs index 81ccadf7..69dd06c7 100644 --- a/test/CrossDBRegionalLCIAFixture.hs +++ b/test/CrossDBRegionalLCIAFixture.hs @@ -110,6 +110,7 @@ mkActivity _ loc = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } emptyIndexes :: Indexes diff --git a/test/CrossLinkingSpec.hs b/test/CrossLinkingSpec.hs index bea6c9ea..aaa6f6b0 100644 --- a/test/CrossLinkingSpec.hs +++ b/test/CrossLinkingSpec.hs @@ -451,6 +451,7 @@ mkActivityAt loc = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } mkRefExchangeAt :: Text -> Exchange diff --git a/test/DeleteSelectionSpec.hs b/test/DeleteSelectionSpec.hs index 33763860..9e772282 100644 --- a/test/DeleteSelectionSpec.hs +++ b/test/DeleteSelectionSpec.hs @@ -384,6 +384,7 @@ mkActivity name loc classif exs = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } units :: M.Map UUID Unit diff --git a/test/EcoSpold1Spec.hs b/test/EcoSpold1Spec.hs index 25316084..e94b53e4 100644 --- a/test/EcoSpold1Spec.hs +++ b/test/EcoSpold1Spec.hs @@ -31,6 +31,7 @@ emptyActivity = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } -- | A production output exchange (isInput=False, isReference=False by default) diff --git a/test/EcoSpold1WriterSpec.hs b/test/EcoSpold1WriterSpec.hs index 82632d07..26d202b4 100644 --- a/test/EcoSpold1WriterSpec.hs +++ b/test/EcoSpold1WriterSpec.hs @@ -138,7 +138,7 @@ soloDb name prodU extra techs bios wastes = } where ref = TechnosphereExchange prodU 1.0 kgUnit ReferenceProduct UUID.nil Nothing "" Nothing Nothing - act = Activity name [] M.empty M.empty "GLO" "kg" (ref : extra) M.empty M.empty Nothing Nothing Nothing + act = Activity name [] M.empty M.empty "GLO" "kg" (ref : extra) M.empty M.empty Nothing Nothing Nothing Nothing -- | Empty database: no activities, no flows. emptyDb :: SimpleDatabase @@ -166,7 +166,7 @@ linkedDb link = where supU = supplierLink conU = read "33333333-0000-4000-8000-000000000001" - mkAct nm prodU exs = Activity nm [] M.empty M.empty "GLO" "kg" (refOf prodU : exs) M.empty M.empty Nothing Nothing Nothing + mkAct nm prodU exs = Activity nm [] M.empty M.empty "GLO" "kg" (refOf prodU : exs) M.empty M.empty Nothing Nothing Nothing Nothing refOf prodU = TechnosphereExchange prodU 1.0 kgUnit ReferenceProduct UUID.nil Nothing "" Nothing Nothing supplier = mkAct "aaa supplier" supU [] -- The consumer's input consumes the supplier's product and links to it. @@ -562,6 +562,7 @@ spec = do Nothing Nothing Nothing + Nothing sdb = SimpleDatabase { sdbActivities = M.singleton (prodU, prodU) act diff --git a/test/EcoSpold2WriterSpec.hs b/test/EcoSpold2WriterSpec.hs index 4ae7599e..f834ba69 100644 --- a/test/EcoSpold2WriterSpec.hs +++ b/test/EcoSpold2WriterSpec.hs @@ -119,6 +119,7 @@ fixtureSimple = Nothing Nothing (Just (EcoSpoldActivityType 1 "Ordinary transforming activity" Nothing Nothing)) + Nothing activityB = Activity "production of B" @@ -135,6 +136,7 @@ fixtureSimple = Nothing Nothing (Just (EcoSpoldActivityType 2 "Market activity" (Just 1) (Just "Hard link"))) + Nothing -- | The fixture as a 'SimpleDatabase' (matches the previous IO-shaped helper). loadFixtureSimple :: IO SimpleDatabase @@ -172,6 +174,7 @@ fixtureDupBio = Nothing Nothing (Just (EcoSpoldActivityType 1 "Ordinary transforming activity" Nothing Nothing)) + Nothing {- | A single-activity database wrapping one adversarial exchange. The exchange is the only difference between the rejection fixtures, so the export @@ -203,6 +206,7 @@ fixtureWithExchange ex = Nothing Nothing (Just (EcoSpoldActivityType 1 "Ordinary transforming activity" Nothing Nothing)) + Nothing {- | A single-activity database whose biosphere flow carries synonyms, so the writer's @\@ emission and the parser's read-back are exercised end to @@ -238,6 +242,7 @@ fixtureWithBioSynonyms = Nothing Nothing Nothing + Nothing {- | A single activity exercising the subtlest inversion paths: a coproduct (outputGroup 2) and waste exchanges in both directions (waIsInput controls @@ -284,6 +289,7 @@ fixtureWasteCoproduct = Nothing Nothing (Just (EcoSpoldActivityType 1 "Ordinary transforming activity" Nothing Nothing)) + Nothing -- | Build a full 'Database' (with matrices) from a 'SimpleDatabase'. buildDb :: SimpleDatabase -> IO Database diff --git a/test/ExportHandlerSpec.hs b/test/ExportHandlerSpec.hs index 372ac42c..8d10151c 100644 --- a/test/ExportHandlerSpec.hs +++ b/test/ExportHandlerSpec.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {- | Tests for the HTTP export handler's error mapping. A failed export must surface as the right HTTP status (400 bad format / unexportable data, 404 not -loaded), never as a 200 body carrying a success flag — the @ExportResponse@ type -can no longer represent the latter. +loaded), never as a 200 body carrying a success flag — the response type (raw +bytes) cannot represent the latter. The cheapest fixture that still drives the @Servant.runHandler@ boundary is an empty 'Database.Manager.DatabaseManager' (no databases loaded), exactly as @@ -12,19 +13,19 @@ empty 'Database.Manager.DatabaseManager' (no databases loaded), exactly as module ExportHandlerSpec (spec) where import API.DatabaseHandlers (exportDatabaseHandler) -import API.Types (ExportRequest (..), ExportResponse) +import API.Types (BinaryContent, ExportRequest (..)) import App.Env (AppEnv (..), runApp) import Config (defaultConfig) import Data.Text (Text) import Database.Manager (initDatabaseManager) -import Servant (ServerError, errHTTPCode, runHandler) +import Servant (Header, Headers, ServerError, errHTTPCode, runHandler) import Test.Hspec -{- | Run the export handler against an empty database manager. 'ExportResponse' +{- | Run the export handler against an empty database manager. The success type has no Eq/Show, but the tests only inspect the 'Left', and the @Right _@ pattern never forces it. -} -runExport :: Text -> Text -> IO (Either ServerError ExportResponse) +runExport :: Text -> Text -> IO (Either ServerError (Headers '[Header "X-Volca-Export-Warnings" Text] BinaryContent)) runExport dbName fmt = do dbm <- initDatabaseManager defaultConfig True Nothing let env = diff --git a/test/ExportSpec.hs b/test/ExportSpec.hs index d58272d2..266b119e 100644 --- a/test/ExportSpec.hs +++ b/test/ExportSpec.hs @@ -80,3 +80,4 @@ buildFixture comp = do Nothing Nothing Nothing + Nothing diff --git a/test/FuzzySpec.hs b/test/FuzzySpec.hs index 5896f40a..e86ded48 100644 --- a/test/FuzzySpec.hs +++ b/test/FuzzySpec.hs @@ -27,6 +27,7 @@ mkActivity name xs = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } -- Index-builder helper: create a BM25 index over a list of activity names. diff --git a/test/ILCDParserSpec.hs b/test/ILCDParserSpec.hs index 404a8535..641687f8 100644 --- a/test/ILCDParserSpec.hs +++ b/test/ILCDParserSpec.hs @@ -51,6 +51,7 @@ activityWithRefExchange fid = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } -- An activity with a single unresolved input exchange for the given flow UUID @@ -81,6 +82,7 @@ activityWithInputExchange fid = , activityParams = M.empty , activityParamExprs = M.empty , activityNativeType = Nothing + , activityNativeId = Nothing } spec :: Spec diff --git a/test/ILCDWriterSpec.hs b/test/ILCDWriterSpec.hs index 48c8e44e..71945eac 100644 --- a/test/ILCDWriterSpec.hs +++ b/test/ILCDWriterSpec.hs @@ -43,6 +43,9 @@ import ILCD.Writer ( escapeXmlAttr, formatDouble, ilcdFiles, + ilcdProcessUUID, + sharedActivityUUIDs, + splitWarnings, writeILCDArchive, writeILCDDatabase, ) @@ -266,18 +269,64 @@ spec = describe "ILCD.Writer round-trip" $ do it "emits one process file per activity" $ do db <- loadFixture - let procFiles = [p | (p, _) <- ilcdFiles defaultWriteOptions db, "processes/" `isPrefixOfFp` p] - length procFiles `shouldBe` M.size (sdbActivities db) + length (processPaths (ilcdFiles defaultWriteOptions db)) `shouldBe` M.size (sdbActivities db) - describe "checkILCDExportable (multi-output guard)" $ do + describe "checkILCDExportable" $ do it "accepts a single-output database" $ do db <- loadFixture checkILCDExportable db `shouldBe` Right () - it "rejects a multi-output activity rather than silently dropping a product" $ - -- Two reference products share one activity UUID, so both would write - -- to the same processes/.xml. The guard must fail loudly. - checkILCDExportable multiOutputDb `shouldSatisfy` isLeft + it "accepts a multi-output activity, now that each product is its own process" $ + checkILCDExportable multiOutputDb `shouldBe` Right () + + describe "ilcdProcessUUID (process dataset identity)" $ do + it "leaves an unshared activity UUID alone" $ do + db <- loadFixture + sharedActivityUUIDs db `shouldBe` S.empty + ilcdProcessUUID S.empty (moActU, moProdA) `shouldBe` moActU + + it "sees the shared activity UUID of a multi-output database" $ + sharedActivityUUIDs multiOutputDb `shouldBe` S.singleton moActU + + it "derives a distinct, deterministic UUID per product of a shared activity" $ do + let shared = sharedActivityUUIDs multiOutputDb + dsA = ilcdProcessUUID shared (moActU, moProdA) + dsB = ilcdProcessUUID shared (moActU, moProdB) + dsA `shouldNotBe` moActU + dsB `shouldNotBe` moActU + dsA `shouldNotBe` dsB + ilcdProcessUUID shared (moActU, moProdA) `shouldBe` dsA + + describe "splitWarnings (multi-output approximation is reported)" $ do + it "is empty when every activity UUID is unique" $ do + db <- loadFixture + splitWarnings db `shouldBe` [] + + it "names each split activity and its product count" $ + case splitWarnings multiOutputDb of + [w] -> do + w `shouldSatisfy` T.isInfixOf (UUID.toText moActU) + w `shouldSatisfy` T.isInfixOf "2 products" + ws -> expectationFailure ("expected exactly one warning, got " ++ show ws) + + describe "multi-output export" $ do + it "writes one process file per product, not one per activity UUID" $ do + let procFiles = processPaths (ilcdFiles defaultWriteOptions multiOutputDb) + length procFiles `shouldBe` 2 + S.size (S.fromList procFiles) `shouldBe` 2 + + it "round-trips both products, structurally" $ do + db' <- roundTrip multiOutputDb + M.size (sdbActivities db') `shouldBe` 2 + activityShapes db' `shouldBe` activityShapes multiOutputDb + + it "is idempotent: the derived dataset UUID is a fixed point" $ do + -- The re-imported activities are keyed by their derived UUIDs, which + -- no longer collide, so the second export mints nothing new. + let f0 = ilcdFiles defaultWriteOptions multiOutputDb + db' <- roundTrip multiOutputDb + sharedActivityUUIDs db' `shouldBe` S.empty + ilcdFiles defaultWriteOptions db' `shouldBe` f0 it "produces a parseable ILCD tree with the same activity count" $ do db <- loadFixture @@ -426,40 +475,47 @@ spec = describe "ILCD.Writer round-trip" $ do isPrefixOfFp :: String -> FilePath -> Bool isPrefixOfFp = isPrefixOf +-- | The @processes/@ entries of an 'ilcdFiles' listing, one per exported process. +processPaths :: [(FilePath, a)] -> [FilePath] +processPaths files = [p | (p, _) <- files, "processes/" `isPrefixOfFp` p] + -- --------------------------------------------------------------------------- -- Multi-output fixture (two products sharing one activity UUID) -- --------------------------------------------------------------------------- -{- | A degenerate database where one activity UUID exposes two reference -products — the shape an ES2/SimaPro multi-output activity takes internally. -ILCD cannot represent it (one process per UUID), so 'checkILCDExportable' -rejects it. +-- | UUIDs of 'multiOutputDb', named so the dataset-UUID tests can address them. +moActU, moProdA, moProdB, moUnitU :: UUID +moActU = read "aaaaaaaa-0000-4000-8000-000000000001" +moProdA = read "aaaaaaaa-0000-4000-8000-0000000000a1" +moProdB = read "aaaaaaaa-0000-4000-8000-0000000000b2" +moUnitU = read "11111111-0000-4000-8000-000000000001" + +{- | A database where one activity UUID exposes two reference products — the +shape an ES2/SimaPro multi-output activity takes internally, and the shape a +truncated SimaPro process name gives two unrelated blocks. Each product exports +as its own ILCD process dataset, under the UUID 'ilcdProcessUUID' derives for +its @(activity, product)@ pair. -} multiOutputDb :: SimpleDatabase multiOutputDb = SimpleDatabase { sdbActivities = M.fromList - [ ((actU, prodA), prodAct "co-product A" prodA) - , ((actU, prodB), prodAct "co-product B" prodB) + [ ((moActU, moProdA), prodAct "co-product A" moProdA) + , ((moActU, moProdB), prodAct "co-product B" moProdB) ] , sdbTechFlows = M.fromList - [ (prodA, techFlow prodA "product A") - , (prodB, techFlow prodB "product B") + [ (moProdA, techFlow moProdA "product A") + , (moProdB, techFlow moProdB "product B") ] , sdbBioFlows = M.empty , sdbWasteFlows = M.empty - , sdbUnits = M.singleton unitU (Unit unitU "kg" "kg" "") + , sdbUnits = M.singleton moUnitU (Unit moUnitU "kg" "kg" "") } where - actU, prodA, prodB, unitU :: UUID - actU = read "aaaaaaaa-0000-4000-8000-000000000001" - prodA = read "aaaaaaaa-0000-4000-8000-0000000000a1" - prodB = read "aaaaaaaa-0000-4000-8000-0000000000b2" - unitU = read "11111111-0000-4000-8000-000000000001" techFlow :: UUID -> Text -> TechnosphereFlow - techFlow fid nm = TechnosphereFlow fid nm unitU M.empty Nothing Nothing + techFlow fid nm = TechnosphereFlow fid nm moUnitU M.empty Nothing Nothing prodAct :: Text -> UUID -> Activity prodAct nm prod = Activity @@ -469,12 +525,13 @@ multiOutputDb = M.empty "GLO" "kg" - [TechnosphereExchange prod 1.0 unitU ReferenceProduct UUID.nil Nothing "" Nothing Nothing] + [TechnosphereExchange prod 1.0 moUnitU ReferenceProduct UUID.nil Nothing "" Nothing Nothing] M.empty M.empty Nothing Nothing Nothing + Nothing -- --------------------------------------------------------------------------- -- Feature fixtures (single-output, exercising the recent ILCD writer fixes) @@ -544,6 +601,7 @@ oneActivityDb bios exs = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } refProductEx :: Exchange diff --git a/test/LoaderSpec.hs b/test/LoaderSpec.hs index 093e2980..1f9bf4db 100644 --- a/test/LoaderSpec.hs +++ b/test/LoaderSpec.hs @@ -52,6 +52,7 @@ minimalActivity name loc exs = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } refExchange :: UUID.UUID -> Exchange diff --git a/test/MatrixConstructionSpec.hs b/test/MatrixConstructionSpec.hs index a1fd5f7c..650894d5 100644 --- a/test/MatrixConstructionSpec.hs +++ b/test/MatrixConstructionSpec.hs @@ -170,6 +170,7 @@ spec = do , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } activityMap = M.singleton (actUUID, prodUUID) activity techFlowDB = M.singleton prodUUID (TechnosphereFlow prodUUID "energy product" jUnitId M.empty Nothing Nothing) @@ -241,6 +242,7 @@ spec = do , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } activityMap = M.singleton (actUUID, prodUUID) activity techFlowDB = M.singleton prodUUID (TechnosphereFlow prodUUID "energy product" jUnitId M.empty Nothing Nothing) @@ -307,6 +309,7 @@ spec = do , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } pRef = TechnosphereExchange @@ -346,6 +349,7 @@ spec = do , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } activityMap = M.fromList [((tA, wW), treatment), ((pA, yY), producer)] techFlowDB = diff --git a/test/MinimalCoverIntegrationSpec.hs b/test/MinimalCoverIntegrationSpec.hs index 8b35f425..7b7b1f3b 100644 --- a/test/MinimalCoverIntegrationSpec.hs +++ b/test/MinimalCoverIntegrationSpec.hs @@ -146,6 +146,7 @@ supplierDB offset = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } in SimpleDatabase { sdbActivities = M.singleton (actUUID, prodUUID) act @@ -222,6 +223,7 @@ consumerDB offset n = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } in ((actUUID, prodUUID), act) activities = M.fromList [mkConsumer i | i <- [1 .. n]] diff --git a/test/RegionalLCIASpec.hs b/test/RegionalLCIASpec.hs index 00256fa4..8cd4b2b8 100644 --- a/test/RegionalLCIASpec.hs +++ b/test/RegionalLCIASpec.hs @@ -91,6 +91,7 @@ mkActivity loc = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } -- Triples: (bioRow=0, col=i, value=v) for each activity. diff --git a/test/RelinkMappingSpec.hs b/test/RelinkMappingSpec.hs index 4c86726f..538b09db 100644 --- a/test/RelinkMappingSpec.hs +++ b/test/RelinkMappingSpec.hs @@ -84,6 +84,7 @@ targetDB = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } flow = TechnosphereFlow diff --git a/test/SetupInfoSpec.hs b/test/SetupInfoSpec.hs index 785193a9..963b2c42 100644 --- a/test/SetupInfoSpec.hs +++ b/test/SetupInfoSpec.hs @@ -54,6 +54,7 @@ minimalActivity name exs = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } refExchange :: UUID.UUID -> Exchange diff --git a/test/SimaProParserSpec.hs b/test/SimaProParserSpec.hs index 774a130d..3160f615 100644 --- a/test/SimaProParserSpec.hs +++ b/test/SimaProParserSpec.hs @@ -7,6 +7,8 @@ import qualified Data.ByteString as BS import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Text (Text) +import Database.Loader (getReferenceProductUUID) +import Database.MatrixBuild (InterningTables (..), buildInterningTables) import Expr (evaluate, normalizeExpr) import SimaPro.Parser ( BioExchangeRow (..), @@ -33,6 +35,7 @@ import Types ( BiosphereFlow, Exchange (..), NativeActivityType (..), + NativeProcessId (..), Pedigree (..), TechRole (..), TechnosphereFlow, @@ -1130,6 +1133,43 @@ spec = do S.fromList (map activityName activities) `shouldBe` S.singleton "Tuna, main product {FR} U" + it "groups the coproducts of one block, and only those" $ do + -- Agribalyse 4.0 truncates "Process name" to 80 characters, so three + -- unrelated lorry blocks carry one name and hash to one activityUUID. + -- The products index must still keep them apart, because the block + -- identifier does. + let truncated = "market for transport, freight, lorry with refrigeration machine, 7.5-16 ton, die" + activities <- + parseIdentifiedBlocksCSV + [ ("TraiEVEA000064241304182", truncated, ["Lorry, EURO5, R134a, freezing {GLO} U;tkm;1;100;not defined;transport;"]) + , ("TraiEVEA000064241304183", truncated, ["Lorry, EURO6, R134a, cooling {GLO} U;tkm;1;100;not defined;transport;"]) + ] + S.fromList (map activityNativeId activities) + `shouldBe` S.fromList + [ Just (NativeProcessId "TraiEVEA000064241304182") + , Just (NativeProcessId "TraiEVEA000064241304183") + ] + -- The collision this fix deliberately keeps: one UUID, two blocks. + S.size (S.fromList (map generateActivityUUID activities)) `shouldBe` 1 + map length (productGroups activities) `shouldBe` [1, 1] + + it "groups a block's coproducts together under its own identifier" $ do + -- The yellowfin tuna block: two coproducts, one "Process identifier", + -- one group — the grouping #171 established, now carried by the + -- identifier rather than by the shared name. + activities <- + parseIdentifiedBlocksCSV + [ + ( "AGRIBALU000009084602653" + , "" + , + [ "Tuna, main product {FR} U;kg;1;91;not defined;material;" + , "Tuna by-products {FR} U;kg;1;9;not defined;material;" + ] + ) + ] + map length (productGroups activities) `shouldBe` [2] + it "does not blank the whole block when the reference product name is empty" $ do -- Malformed export: name-less block whose first Products row has an -- empty name cell. The blank must stay confined to that row; other @@ -1190,6 +1230,50 @@ parseSectionCSV :: [BS.ByteString] -> IO ([Activity], M.Map UUID TechnosphereFlo parseSectionCSV sectionLines = parseNamedCSV "Test process" sectionLines +{- | Parse several process blocks, each with its own @Process identifier@, +@Process name@ and @Products@ rows. Activities come back in file order. +-} +parseIdentifiedBlocksCSV :: [(BS.ByteString, BS.ByteString, [BS.ByteString])] -> IO [Activity] +parseIdentifiedBlocksCSV blocks = + withSystemTempFile "identified-blocks-test.csv" $ \path handle -> do + let header = + [ "{SimaPro 9.6.0.1}" + , "{CSV separator: semicolon}" + , "{Decimal separator: .}" + , "" + ] + block (identifier, procName, productsRows) = + [ "Process" + , "" + , "Process identifier" + , identifier + , "" + , "Category type" + , "material" + , "" + , "Process name" + , procName + , "" + , "Type" + , "Unit process" + , "" + , "Products" + ] + ++ productsRows + ++ ["", "End", ""] + BS.hPut handle (BS.intercalate "\r\n" (header ++ concatMap block blocks)) + hClose handle + (activities, _, _, _, _) <- parseSimaProCSV defaultUnitConfig path + pure activities + +{- | The coproduct groups the products index builds, as their sizes, ordered by +group key. One entry per source block. +-} +productGroups :: [Activity] -> [[Int]] +productGroups activities = + map (map fromIntegral) . M.elems . itActivityProductsIndex . buildInterningTables $ + M.fromList [((generateActivityUUID a, getReferenceProductUUID a), a) | a <- activities] + -- | Build a minimal process CSV with a custom Process name and Products rows. parseProductsCSV :: BS.ByteString -> [BS.ByteString] -> IO ([Activity], M.Map UUID TechnosphereFlow, M.Map UUID BiosphereFlow, M.Map UUID WasteFlow, M.Map UUID Unit) parseProductsCSV procName productsRows = diff --git a/test/SimaProWriterSpec.hs b/test/SimaProWriterSpec.hs index dae7c6eb..3f1a359b 100644 --- a/test/SimaProWriterSpec.hs +++ b/test/SimaProWriterSpec.hs @@ -595,6 +595,7 @@ emissionDb comp = Nothing Nothing Nothing + Nothing -- --------------------------------------------------------------------------- -- Allocation round-trip fixture @@ -640,6 +641,7 @@ allocationDb = (Just 50) Nothing Nothing + Nothing {- | A 0%-allocated activity: its shared material input is stored at 0 (the parser scaled every shared amount by allocFraction = 0 on import). A correct writer emits @@ -680,6 +682,7 @@ zeroAllocationDb = (Just 0) Nothing Nothing + Nothing -- --------------------------------------------------------------------------- -- Round-trip guard fixtures (comment-as-pedigree, metadata-key collision) @@ -723,6 +726,7 @@ commentDb ped cmt = Nothing Nothing Nothing + Nothing {- | One activity with the given name and a single reference product. Exercises the metadata-key collision guard: a name equal to a SimaPro key is rejected. @@ -755,6 +759,7 @@ namedDb name = Nothing Nothing Nothing + Nothing -- --------------------------------------------------------------------------- -- Field-shape guard fixtures (shared by the field-shape guard specs) @@ -808,4 +813,4 @@ guardDb alloc ntype exs = } where act = - Activity "guard maker" [] M.empty M.empty "GLO" "kg" exs M.empty M.empty alloc Nothing ntype + Activity "guard maker" [] M.empty M.empty "GLO" "kg" exs M.empty M.empty alloc Nothing ntype Nothing diff --git a/test/StrictPinSpec.hs b/test/StrictPinSpec.hs index 28a15988..0341fa5e 100644 --- a/test/StrictPinSpec.hs +++ b/test/StrictPinSpec.hs @@ -246,6 +246,7 @@ supplierDB offset products = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } in (((actUUID, prodUUID), act), (flowUUID, flow)) | (i, name) <- zip [0 ..] products @@ -306,6 +307,7 @@ consumerDB offset products = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } in (((actUUID, prodUUID), act), [(inFlowUUID, inFlow), (outFlowUUID, outFlow)]) | (i, name) <- zip [0 ..] products diff --git a/test/WasteTreatmentSignSpec.hs b/test/WasteTreatmentSignSpec.hs index a5348e9c..6bdb7292 100644 --- a/test/WasteTreatmentSignSpec.hs +++ b/test/WasteTreatmentSignSpec.hs @@ -68,6 +68,7 @@ emptyActivity = , activityAllocationPercent = Nothing , activityAllocationFormula = Nothing , activityNativeType = Nothing + , activityNativeId = Nothing } techEx :: UUID -> Double -> TechRole -> UUID -> Exchange diff --git a/test/ZipSpec.hs b/test/ZipSpec.hs new file mode 100644 index 00000000..b4ff1448 --- /dev/null +++ b/test/ZipSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | Contract for "Zip": pack every entry, and do it in linear time. + +The size guard is the point of the module. @zip-archive@'s 'addEntryToArchive' +rescans the whole entry list on each insert, so the fold it invites costs +O(n²) — on a real ILCD package (53 508 files) that turned an export into a +ten-minute timeout. Wall-clock is the only signal that separates the two +regimes, hence the 'timeout': 30 000 entries pack in well under a second when +linear, and take tens of seconds (or exhaust the stack) when not. The margin is +wide enough that a loaded machine cannot flip the verdict. + +The companion test is that the fast path did not get fast by dropping entries. +-} +module ZipSpec (spec) where + +import Codec.Archive.Zip (filesInArchive, findEntryByPath, fromEntry, toArchive) +import Control.Exception (evaluate) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.List (sort) +import Data.Maybe (isJust) +import System.Timeout (timeout) +import Test.Hspec + +import Zip (zipFiles) + +-- | 30 000 small entries, the shape an ILCD package has (many tiny XML files). +manyFiles :: [(FilePath, BS.ByteString)] +manyFiles = + [ ("processes/" ++ show i ++ ".xml", BS.replicate 64 65) + | i <- [1 .. 30_000 :: Int] + ] + +spec :: Spec +spec = describe "Zip.zipFiles" $ do + it "packs 30 000 entries without going quadratic" $ do + packed <- timeout 5_000_000 (evaluate (BL.length (zipFiles manyFiles))) + packed `shouldSatisfy` isJust + + it "keeps every entry it was given" $ do + let archive = toArchive (zipFiles manyFiles) + sort (filesInArchive archive) `shouldBe` sort (map fst manyFiles) + + it "round-trips the entry bytes" $ do + let archive = toArchive (zipFiles [("a/one.xml", "hello"), ("b/two.xml", "world")]) + contents p = fromEntry <$> findEntryByPath p archive + contents "a/one.xml" `shouldBe` Just "hello" + contents "b/two.xml" `shouldBe` Just "world" diff --git a/volca.cabal b/volca.cabal index 970c8379..5f24f390 100644 --- a/volca.cabal +++ b/volca.cabal @@ -92,6 +92,7 @@ library , BrightwayExcel.Parser , BrightwayExcel.Writer , Expr + , Zip , ILCD.Parser , ILCD.Writer , Database.Export @@ -297,6 +298,7 @@ test-suite lca-tests , DeleteSelectionSpec , ExportSpec , ExportHandlerSpec + , ZipSpec , PropertiesSpec , NativeActivityTypeSpec , WasteCrossDBSpec