WIP: Start verifying imports protected by the semantic hash

src/dhall_clj/fail.clj

@@ -47,6 +47,7 @@
 (ex/derive ::missing-file    ::imports)
 (ex/derive ::missing-imports ::imports)
 (ex/derive ::cyclic-import   ::imports)
+(ex/derive ::hash-mismatch   ::imports)
 
 (defn missing-keyword!
   "Throws an ex-info from the `missing` keyword"
@@ -88,6 +89,15 @@
     {:type ::cyclic-import
      :import import}))
 
+(defn hash-mismatch!
+  "Throws an ex-info on hash protection mismatch"
+  [import actual-hash expression]
+  (throw-data
+    "Hash mismatch"
+    {:type ::hash-mismatch
+     :import import
+     :actual-hash actual-hash
+     :expression expression}))
 
 ;;
 ;; Serialization

src/dhall_clj/import.clj

@@ -4,10 +4,13 @@
             [digest :refer [sha-256]]
             [me.raynes.fs :as fs]
             [clojure.java.io :as io]
+            [clojure.string :as str]
             [dhall-clj.parse :refer [parse expr]]
-            [dhall-clj.state :as state]
             [dhall-clj.fail :as fail]
-            [clojure.string :as str]
+            [dhall-clj.alpha-normalize :refer [alpha-normalize]]
+            [dhall-clj.beta-normalize :refer [beta-normalize]]
+            [dhall-clj.typecheck :refer [typecheck]]
+            [dhall-clj.binary :as binary]
             [dhall-clj.state :as s])
   (:import [dhall_clj.ast Import Local Remote Env Missing]))
 
@@ -134,9 +137,20 @@
                              (expr-from-import data mode))
               resolved-expr (resolve-imports
                               dynamic-expr
-                              (update state :stack conj data))]
-          ;; TODO: typecheck + normalize
-          resolved-expr))))
+                              (update state :stack conj data))
+              _             (typecheck resolved-expr {})
+              normalized    (beta-normalize resolved-expr)]
+          (if-not hash?
+            normalized
+            ;; TODO TEST THIS
+            (let [expected-hash (str/lower-case hash?)
+                  actual-hash   (-> normalized
+                                   alpha-normalize
+                                   binary/encode
+                                   sha-256)]
+              (if (= expected-hash actual-hash)
+                normalized
+                (fail/hash-mismatch! this actual-hash normalized))))))))
 
   dhall_clj.ast.ImportAlt
   (resolve-imports [this state]

test/dhall_clj/beta_normalize_test.clj

@@ -55,14 +55,16 @@
 
 ;; Haskell implementation test suite
 
-(def test-folder "dhall-haskell/tests/normalization")
+(def test-folder "dhall-lang/tests/normalization/success")
 
 (def problematic
   "Here we list all the tests that blow up, so we categorize and exclude them.
   Note: they are vectors because the path creation is platform-sensitive."
   [
+   ;; Waiting on issue #23
+   ["dhall-lang" "tests" "normalization" "success" "tutorial" "access" "1"]
    ;; Waiting for single quote strings to be standardized
-   ["dhall-haskell" "tests" "normalization" "remoteSystems"]])
+   ["dhall-lang" "tests" "normalization" "success" "remoteSystems"]])
 
 
 (defn valid-testcases []
@@ -72,16 +74,17 @@
        (apply dissoc all))))
 
 (deftest normalization-suite
-  (doseq [[testcase {:keys [actual expected]}] (valid-testcases)]
-    (let [parent (fs/parent testcase)
-          f #(fs/with-mutable-cwd
-               (fs/chdir parent)
-               (-> %
-                  parse
-                  expr
-                  (resolve-imports (s/new))
-                  beta-normalize))]
-      (println "TESTCASE" testcase)
-      (testing testcase
-        (is (= (f actual)
-               (f expected)))))))
+  (let [import-cache (s/new)]
+    (doseq [[testcase {:keys [actual expected]}] (valid-testcases)]
+      (let [parent (fs/parent testcase)
+            f #(fs/with-mutable-cwd
+                 (fs/chdir parent)
+                 (-> %
+                    parse
+                    expr
+                    (resolve-imports import-cache)
+                    beta-normalize))]
+        (println "TESTCASE" testcase)
+        (testing testcase
+          (is (= (f actual)
+                 (f expected))))))))

test/dhall_clj/typecheck_test.clj

@@ -7,7 +7,8 @@
              [dhall-clj.typecheck :refer [typecheck]]
              [dhall-clj.state :as s]
              [dhall-clj.test-utils :refer :all]
-             [me.raynes.fs :as fs]))
+             [me.raynes.fs :as fs]
+             [clojure.java.io :as io]))
 
 
 ;; Simple regression tests
@@ -29,33 +30,53 @@
 
 ;; Haskell implementation test suite
 
-(def test-folder "dhall-haskell/tests/typecheck")
+(def test-folder "dhall-lang/tests/typecheck")
+
+(def problematic
+  "Here we list all the tests that blow up, so we categorize and exclude them.
+  Note: they are vectors because the path creation is platform-sensitive."
+  [
+   ;; Waiting on issue #23
+   ["dhall-lang" "tests" "typecheck" "success" "simple" "access" "1"]
+   ;; Waiting on issue #17
+   ["dhall-lang" "tests" "typecheck" "success" "simple" "kindParameter"]
+   ["dhall-lang" "tests" "typecheck" "success" "simple" "fieldsAreTypes"]])
+
+
+(defn valid-testcases []
+  (let [all (success-testcases test-folder)]
+    (->> problematic
+       (map #(->> % (apply io/file) str))
+       (apply dissoc all))))
 
 (deftest typecheck-success-suite
-  (doseq [[testcase {:keys [actual expected]}] (success-testcases test-folder)]
-    (let [parent (fs/parent testcase)
-          run (fn []
-                (fs/with-mutable-cwd
-                  (fs/chdir parent)
-                  (-> (->Annot
-                       (-> actual parse expr)
-                       (-> expected parse expr))
-                     (resolve-imports (s/new))
-                     (typecheck {})))
-                nil)]
-      (testing testcase
-        (is (= nil (run)))))))
+  (let [import-cache (s/new)]
+    (doseq [[testcase {:keys [actual expected]}] (valid-testcases)]
+      (let [parent (fs/parent testcase)
+            run (fn []
+                  (fs/with-mutable-cwd
+                    (fs/chdir parent)
+                    (-> (->Annot
+                         (-> actual parse expr)
+                         (-> expected parse expr))
+                       (resolve-imports import-cache)
+                       (typecheck {})))
+                  nil)]
+        (println "TESTCASE" testcase)
+        (testing testcase
+          (is (= nil (run))))))))
 
 (deftest typecheck-failure-suite
-  (doseq [[testcase dhall] (failure-testcases test-folder)]
-    (let [parent (fs/parent testcase)
-          run (fn []
-                (fs/with-mutable-cwd
-                  (fs/chdir parent)
-                  (-> dhall
-                     parse
-                     expr
-                     (resolve-imports (s/new))
-                     (typecheck {}))))]
-      (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Typecheck error:"
-                            (run))))))
+  (let [import-cache (s/new)]
+    (doseq [[testcase dhall] (failure-testcases test-folder)]
+      (let [parent (fs/parent testcase)
+            run (fn []
+                  (fs/with-mutable-cwd
+                    (fs/chdir parent)
+                    (-> dhall
+                       parse
+                       expr
+                       (resolve-imports import-cache)
+                       (typecheck {}))))]
+        (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Typecheck error:"
+                              (run)))))))