damlc validate-dar (#4654)

changelog_begin changelog_end
digital-asset · Feb 27, 2020 · b8124a9 · b8124a9
1 parent 3a7dca3
commit b8124a9
Show file tree

Hide file tree

Showing 8 changed files with 304 additions and 57 deletions.
diff --git a/BUILD b/BUILD
@@ -269,6 +269,7 @@ da_haskell_repl(
         "//compiler/damlc/daml-ide-core:ide-testing",
         "//compiler/damlc/stable-packages:generate-stable-package",
         "//compiler/damlc/tests:daml-doctest",
+        "//compiler/damlc/tests:damlc-test",
         "//compiler/damlc/tests:generate-simple-dalf",
         "//compiler/damlc/tests:integration-dev",
         "//compiler/damlc/tests:packaging",

diff --git a/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker.hs b/compiler/daml-lf-tools/src/DA/Daml/LF/TypeChecker.hs
@@ -3,11 +3,15 @@
 
 module DA.Daml.LF.TypeChecker
   ( Error (..)
+  , checkPackage
   , checkModule
   , nameCheckPackage
   , errorLocation
   ) where
 
+import           Control.Monad (forM_)
+import qualified Data.NameMap as NM
+
 import           DA.Daml.LF.Ast
 import qualified DA.Daml.LF.TypeChecker.Check      as Check
 import           DA.Daml.LF.TypeChecker.Env
@@ -23,14 +27,28 @@ checkModule ::
   -> Module
   -> Either Error ()
 checkModule world0 version m = do
-    runGamma (extendWorldSelf m world0) version $ do
+  checkModuleInWorld (extendWorldSelf m world0) version m
+
+checkPackage ::
+     World
+  -> Version
+  -> Either Error ()
+checkPackage world version = do
+  let package = getWorldSelf world
+  let modules = NM.toList (packageModules package)
+  forM_ modules $ \m -> do
+    checkModuleInWorld world version m
+
+checkModuleInWorld :: World -> Version -> Module -> Either Error ()
+checkModuleInWorld world version m = do
+    runGamma world version $ do
       -- We must call `Recursion.checkModule` before `Check.checkModule`
       -- or else we might loop, attempting to expand recursive type synonyms
       Recursion.checkModule m
       Check.checkModule m
       Serializability.checkModule m
       PartyLits.checkModule m
-    NameCollision.runCheckModuleDeps world0 m
+    NameCollision.runCheckModuleDeps world m
 
 -- | Check whether the whole package satisfies the name collision condition.
 nameCheckPackage :: Package -> Either Error ()

diff --git a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/ExtractDar.hs b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/ExtractDar.hs
@@ -0,0 +1,59 @@
+-- Copyright (c) 2020 The DAML Authors. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+module DA.Daml.Compiler.ExtractDar
+  ( ExtractedDar(..)
+  , extractDar
+  , getEntry
+  ) where
+
+import qualified "zip-archive" Codec.Archive.Zip as ZipArchive
+import Control.Monad.Extra
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.UTF8 as BSUTF8
+import Data.List.Extra
+import System.FilePath
+import DA.Daml.LF.Reader
+
+data ExtractedDar = ExtractedDar
+    { edSdkVersions :: String
+    , edMain :: [ZipArchive.Entry]
+    , edConfFiles :: [ZipArchive.Entry]
+    , edDalfs :: [ZipArchive.Entry]
+    , edSrcs :: [ZipArchive.Entry]
+    }
+
+-- | Extract a dar archive
+extractDar :: FilePath -> IO ExtractedDar
+extractDar fp = do
+    bs <- BSL.readFile fp
+    let archive = ZipArchive.toArchive bs
+    manifest <- getEntry manifestPath archive
+    dalfManifest <- either fail pure $ readDalfManifest archive
+    mainDalfEntry <- getEntry (mainDalfPath dalfManifest) archive
+    sdkVersion <-
+        case parseManifestFile $ BSL.toStrict $ ZipArchive.fromEntry manifest of
+            Left err -> fail err
+            Right manifest ->
+                case lookup "Sdk-Version" manifest of
+                    Nothing -> fail "No Sdk-Version entry in manifest"
+                    Just version -> pure $! trim $ BSUTF8.toString version
+    let confFiles =
+            [ e
+            | e <- ZipArchive.zEntries archive
+            , ".conf" `isExtensionOf` ZipArchive.eRelativePath e
+            ]
+    let srcs =
+            [ e
+            | e <- ZipArchive.zEntries archive
+            , takeExtension (ZipArchive.eRelativePath e) `elem`
+                  [".daml", ".hie", ".hi"]
+            ]
+    dalfs <- forM (dalfPaths dalfManifest) $ \p -> getEntry p archive
+    pure (ExtractedDar sdkVersion [mainDalfEntry] confFiles dalfs srcs)
+
+-- | Get an entry from a dar or fail.
+getEntry :: FilePath -> ZipArchive.Archive -> IO ZipArchive.Entry
+getEntry fp dar =
+    maybe (fail $ "Package does not contain " <> fp) pure $
+    ZipArchive.findEntryByPath fp dar
diff --git a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Validate.hs b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Validate.hs
@@ -0,0 +1,63 @@
+-- Copyright (c) 2020 The DAML Authors. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+module DA.Daml.Compiler.Validate (validateDar) where
+
+import Control.Exception.Extra (errorIO)
+import Control.Monad (forM_)
+import qualified "zip-archive" Codec.Archive.Zip as ZipArchive
+import qualified DA.Daml.LF.Ast as LF
+import qualified DA.Daml.LF.Proto3.Archive as Archive
+import qualified Data.ByteString.Lazy as BSL
+
+import DA.Daml.Compiler.ExtractDar (extractDar,ExtractedDar(..))
+import DA.Daml.LF.Ast.Version
+import DA.Daml.LF.Ast.World (initWorldSelf)
+import DA.Pretty (renderPretty)
+import qualified DA.Daml.LF.TypeChecker as TC (checkPackage)
+import qualified DA.Daml.LF.TypeChecker.Error as TC
+
+
+data ValidationError
+  = VeArchiveError FilePath Archive.ArchiveError
+  | VeTypeError TC.Error
+
+instance Show ValidationError where
+  show = \case
+    VeArchiveError fp err -> unlines
+      [ "Invalid DAR."
+      , "DALF entry cannot be decoded: " <> fp
+      , show err ]
+    VeTypeError err -> unlines
+      [ "Invalid DAR."
+      , "The DAR is not well typed."
+      , renderPretty err ]
+
+
+validationError :: ValidationError -> IO a
+validationError = errorIO . show
+
+-- | Validate a loaded DAR: that all DALFs are well-typed and consequently that the DAR is closed
+validateDar :: FilePath -> IO Int
+validateDar inFile = do
+  ExtractedDar{edDalfs} <- extractDar inFile
+  extPackages <- mapM (decodeDalfEntry Archive.DecodeAsDependency) edDalfs
+  validateWellTyped edDalfs extPackages
+  return $ length extPackages
+
+validateWellTyped :: [ZipArchive.Entry] -> [LF.ExternalPackage] -> IO ()
+validateWellTyped entries extPackages = do
+  forM_ entries $ \e -> do
+    LF.ExternalPackage{extPackagePkg=self} <- decodeDalfEntry Archive.DecodeAsMain e
+    let world = initWorldSelf extPackages self
+    let version = versionDev
+    case TC.checkPackage world version of
+      Right () -> return ()
+      Left err -> validationError $ VeTypeError err
+
+decodeDalfEntry :: Archive.DecodingMode -> ZipArchive.Entry -> IO LF.ExternalPackage
+decodeDalfEntry decodeAs entry = do
+  let bs = BSL.toStrict $ ZipArchive.fromEntry entry
+  case Archive.decodeArchive decodeAs bs of
+    Left err -> validationError $ VeArchiveError (ZipArchive.eRelativePath entry) err
+    Right (pid,package) -> return $ LF.ExternalPackage pid package
diff --git a/compiler/damlc/lib/DA/Cli/Damlc.hs b/compiler/damlc/lib/DA/Cli/Damlc.hs
@@ -24,11 +24,13 @@ import DA.Cli.Damlc.IdeState
 import DA.Cli.Damlc.Packaging
 import DA.Cli.Damlc.Test
 import DA.Daml.Compiler.Dar
+import DA.Daml.Compiler.ExtractDar (getEntry)
 import qualified DA.Daml.Compiler.Repl as Repl
 import DA.Daml.Compiler.DocTest
 import DA.Daml.Compiler.Scenario
 import qualified DA.Daml.LF.ReplClient as ReplClient
 import DA.Daml.Compiler.Upgrade
+import DA.Daml.Compiler.Validate (validateDar)
 import qualified DA.Daml.LF.Ast as LF
 import qualified DA.Daml.LF.Proto3.Archive as Archive
 import DA.Daml.LF.Reader
@@ -106,6 +108,7 @@ data CommandName =
   | Init
   | Inspect
   | InspectDar
+  | ValidateDar
   | License
   | Lint
   | MergeDars
@@ -304,6 +307,13 @@ cmdInspectDar =
   where
     cmd = execInspectDar <$> inputDarOpt
 
+cmdValidateDar :: Mod CommandFields Command
+cmdValidateDar =
+    command "validate-dar" $
+    info (helper <*> cmd) $ progDesc "Validate a DAR archive" <> fullDesc
+  where
+    cmd = execValidateDar <$> inputDarOpt
+
 cmdMigrate :: Mod CommandFields Command
 cmdMigrate =
     command "migrate" $
@@ -742,6 +752,14 @@ execInspectDar inFile =
               (dropExtension $ takeFileName $ ZipArchive.eRelativePath dalfEntry) <> " " <>
               show (LF.unPackageId pkgId)
 
+execValidateDar :: FilePath -> Command
+execValidateDar inFile =
+  Command ValidateDar Nothing effect
+  where
+    effect = do
+      n <- validateDar inFile -- errors if validation fails
+      putStrLn $ "DAR is valid; contains " <> show n <> " packages."
+
 execMigrate ::
        ProjectOpts
     -> FilePath
@@ -881,6 +899,7 @@ options numProcessors =
       <> cmdVisual
       <> cmdVisualWeb
       <> cmdInspectDar
+      <> cmdValidateDar
       <> cmdDocTest numProcessors
       <> cmdLint numProcessors
       <> cmdRepl numProcessors

diff --git a/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs b/compiler/damlc/lib/DA/Cli/Damlc/Packaging.hs
@@ -2,12 +2,7 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 module DA.Cli.Damlc.Packaging
-  ( ExtractedDar(..)
-  , extractDar
-
-  , createProjectPackageDb
-
-  , getEntry
+  ( createProjectPackageDb
   , mbErr
   , getUnitId
   ) where
@@ -20,7 +15,6 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Maybe
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BSL
-import qualified Data.ByteString.UTF8 as BSUTF8
 import Data.Graph
 import Data.List.Extra
 import qualified Data.Map.Strict as MS
@@ -46,10 +40,10 @@ import DA.Cli.Damlc.Base
 import DA.Cli.Damlc.IdeState
 import DA.Daml.Compiler.Dar
 import DA.Daml.Compiler.DataDependencies as DataDeps
+import DA.Daml.Compiler.ExtractDar (extractDar,ExtractedDar(..))
 import qualified DA.Daml.LF.Ast as LF
 import DA.Daml.LF.Ast.Optics (packageRefs)
 import qualified DA.Daml.LF.Proto3.Archive as Archive
-import DA.Daml.LF.Reader
 import DA.Daml.Options.Types
 import qualified DA.Pretty
 import Development.IDE.Core.RuleTypes.Daml
@@ -360,43 +354,6 @@ baseImports =
        )
     ]
 
-data ExtractedDar = ExtractedDar
-    { edSdkVersions :: String
-    , edMain :: [ZipArchive.Entry]
-    , edConfFiles :: [ZipArchive.Entry]
-    , edDalfs :: [ZipArchive.Entry]
-    , edSrcs :: [ZipArchive.Entry]
-    }
-
--- | Extract a dar archive
-extractDar :: FilePath -> IO ExtractedDar
-extractDar fp = do
-    bs <- BSL.readFile fp
-    let archive = ZipArchive.toArchive bs
-    manifest <- getEntry manifestPath archive
-    dalfManifest <- either fail pure $ readDalfManifest archive
-    mainDalfEntry <- getEntry (mainDalfPath dalfManifest) archive
-    sdkVersion <-
-        case parseManifestFile $ BSL.toStrict $ ZipArchive.fromEntry manifest of
-            Left err -> fail err
-            Right manifest ->
-                case lookup "Sdk-Version" manifest of
-                    Nothing -> fail "No Sdk-Version entry in manifest"
-                    Just version -> pure $! trim $ BSUTF8.toString version
-    let confFiles =
-            [ e
-            | e <- ZipArchive.zEntries archive
-            , ".conf" `isExtensionOf` ZipArchive.eRelativePath e
-            ]
-    let srcs =
-            [ e
-            | e <- ZipArchive.zEntries archive
-            , takeExtension (ZipArchive.eRelativePath e) `elem`
-                  [".daml", ".hie", ".hi"]
-            ]
-    dalfs <- forM (dalfPaths dalfManifest) $ \p -> getEntry p archive
-    pure (ExtractedDar sdkVersion [mainDalfEntry] confFiles dalfs srcs)
-
 -- | A helper to construct package ref to unit id maps.
 getUnitId :: UnitId -> MS.Map LF.PackageId UnitId -> LF.PackageRef -> UnitId
 getUnitId thisUnitId pkgMap =
@@ -459,12 +416,6 @@ getGhcPkgPath =
 mbErr :: String -> Maybe a -> IO a
 mbErr err = maybe (hPutStrLn stderr err >> exitFailure) pure
 
--- | Get an entry from a dar or fail.
-getEntry :: FilePath -> ZipArchive.Archive -> IO ZipArchive.Entry
-getEntry fp dar =
-    maybe (fail $ "Package does not contain " <> fp) pure $
-    ZipArchive.findEntryByPath fp dar
-
 lfVersionString :: LF.Version -> String
 lfVersionString = DA.Pretty.renderPretty
 

diff --git a/compiler/damlc/tests/BUILD.bazel b/compiler/damlc/tests/BUILD.bazel
@@ -52,16 +52,18 @@ da_haskell_test(
     ],
     hackage_deps = [
         "base",
+        "bytestring",
         "directory",
         "extra",
         "filepath",
         "process",
         "tasty",
         "tasty-hunit",
+        "zip-archive",
     ],
     main_function = "DamlcTest.main",
     src_strip_prefix = "tests",
-    visibility = ["//visibility:private"],
+    visibility = ["//visibility:public"],
     deps = [
         "//:sdk-version-hs-lib",
         "//compiler/damlc:damlc-lib",