Add support for SHA-256 integrity checks on imports (#166)

Related to #162

You can now add `sha256:XXX...XXX` after any import to verify that the import
has the expected hash.  This allows you to purify import code and protect the
code against malicious modifications

This is analogous to an IPFS-style import except that the hash is verified
directly by the interpreter instead of trusting that the IPFS URL has not been
compromised

default.nix

@@ -1,8 +1,9 @@
-{ mkDerivation, ansi-wl-pprint, base, bytestring, case-insensitive
+{ mkDerivation, ansi-wl-pprint, base, base16-bytestring, bytestring
-, charset, containers, contravariant, exceptions, http-client
+, case-insensitive, charset, containers, contravariant, cryptohash
-, http-client-tls, lens, optparse-generic, parsers, prettyprinter
+, exceptions, http-client, http-client-tls, lens, optparse-generic
-, stdenv, system-fileio, system-filepath, tasty, tasty-hunit, text
+, parsers, prettyprinter, stdenv, system-fileio, system-filepath
-, text-format, transformers, trifecta, unordered-containers, vector
+, tasty, tasty-hunit, text, text-format, transformers, trifecta
+, unordered-containers, vector
 }:
 mkDerivation {
   pname = "dhall";
@@ -11,10 +12,11 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    ansi-wl-pprint base bytestring case-insensitive charset containers
+    ansi-wl-pprint base base16-bytestring bytestring case-insensitive
-    contravariant exceptions http-client http-client-tls lens parsers
+    charset containers contravariant cryptohash exceptions http-client
-    prettyprinter system-fileio system-filepath text text-format
+    http-client-tls lens parsers prettyprinter system-fileio
-    transformers trifecta unordered-containers vector
+    system-filepath text text-format transformers trifecta
+    unordered-containers vector
   ];
   executableHaskellDepends = [
     base optparse-generic prettyprinter system-filepath text trifecta

dhall.cabal

@@ -93,11 +93,13 @@ Library
     Build-Depends:
         base                 >= 4.9.0.0  && < 5   ,
         ansi-wl-pprint                      < 0.7 ,
+        base16-bytestring                   < 0.2 ,
         bytestring                          < 0.11,
         case-insensitive                    < 1.3 ,
         charset                             < 0.4 ,
         containers           >= 0.5.0.0  && < 0.6 ,
         contravariant                       < 1.5 ,
+        cryptohash                          < 0.12,
         exceptions           >= 0.8.3    && < 0.9 ,
         http-client          >= 0.4.30   && < 0.6 ,
         http-client-tls      >= 0.2.0    && < 0.4 ,

src/Dhall/Core.hs

@@ -19,6 +19,7 @@ module Dhall.Core (
       Const(..)
     , HasHome(..)
     , PathType(..)
+    , PathHashed(..)
     , PathMode(..)
     , Path(..)
     , Var(..)
@@ -63,6 +64,9 @@ import Numeric.Natural (Natural)
 import Prelude hiding (FilePath, succ)
 
 import qualified Control.Monad
+import qualified Data.ByteString
+import qualified Data.ByteString.Char8
+import qualified Data.ByteString.Base16
 import qualified Data.Char
 import qualified Data.HashSet
 import qualified Data.List
@@ -105,7 +109,7 @@ data HasHome = Home | Homeless deriving (Eq, Ord, Show)
 data PathType
     = File HasHome FilePath
     -- ^ Local path
-    | URL  Text (Maybe PathType)
+    | URL  Text (Maybe PathHashed)
     -- ^ URL of emote resource and optional headers stored in a path
     | Env  Text
     -- ^ Environment variable
@@ -132,14 +136,27 @@ instance Buildable PathType where
 -- | How to interpret the path's contents (i.e. as Dhall code or raw text)
 data PathMode = Code | RawText deriving (Eq, Ord, Show)
 
+data PathHashed = PathHashed
+    { hash     :: Maybe Data.ByteString.ByteString
+    , pathType :: PathType
+    } deriving (Eq, Ord, Show)
+
+instance Buildable PathHashed where
+    build (PathHashed  Nothing p) = build p
+    build (PathHashed (Just h) p) = build p <> "sha256:" <> build string <> " "
+      where
+        bytes = Data.ByteString.Base16.encode h
+
+        string = Data.ByteString.Char8.unpack bytes
+
 -- | Path to an external resource
 data Path = Path
-    { pathType :: PathType
+    { pathHashed :: PathHashed
-    , pathMode :: PathMode
+    , pathMode   :: PathMode
     } deriving (Eq, Ord, Show)
 
 instance Buildable Path where
-    build (Path {..}) = build pathType <> suffix
+    build (Path {..}) = build pathHashed <> suffix
       where
         suffix = case pathMode of
             RawText -> "as Text"

src/Dhall/Import.hs

@@ -134,7 +134,13 @@ import Data.Traversable (traverse)
 import Data.Typeable (Typeable)
 import Filesystem.Path ((</>), FilePath)
 import Dhall.Core
-    (Expr(..), HasHome(..), PathMode(..), PathType(..), Path(..))
+    ( Expr(..)
+    , HasHome(..)
+    , PathHashed(..)
+    , PathMode(..)
+    , PathType(..)
+    , Path(..)
+    )
 import Dhall.Parser (Parser(..), ParseError(..), Src(..))
 import Dhall.TypeCheck (X(..))
 #if MIN_VERSION_http_client(0,5,0)
@@ -148,7 +154,10 @@ import Text.Trifecta (Result(..))
 import Text.Trifecta.Delta (Delta(..))
 
 import qualified Control.Monad.Trans.State.Strict as State
+import qualified Crypto.Hash.SHA256
 import qualified Data.ByteString
+import qualified Data.ByteString.Base16
+import qualified Data.ByteString.Char8
 import qualified Data.ByteString.Lazy
 import qualified Data.CaseInsensitive
 import qualified Data.List                        as List
@@ -157,6 +166,7 @@ import qualified Data.Text.Encoding
 import qualified Data.Text.Lazy                   as Text
 import qualified Data.Text.Lazy.Builder           as Builder
 import qualified Data.Text.Lazy.Encoding
+import qualified Data.Text.Lazy.IO
 import qualified Data.Vector
 import qualified Dhall.Core
 import qualified Dhall.Parser
@@ -376,7 +386,7 @@ canonicalize (File hasHome0 file0:paths0) =
     go currPath (Env  _           :_    ) = File Homeless (clean currPath)
     go currPath (URL  url0 headers:rest ) = combine prefix suffix
       where
-        headers' = fmap (\h -> canonicalize (h:rest)) headers
+        headers' = fmap (onPathType (\h -> canonicalize (h:rest))) headers
 
         prefix = parentURL (removeAtFromURL url0)
 
@@ -409,19 +419,29 @@ canonicalize (File hasHome0 file0:paths0) =
         file' = Filesystem.parent (removeAtFromFile file) </> currPath
 canonicalize (URL path headers:rest) = URL path headers'
   where
-    headers' = fmap (\h -> canonicalize (h:rest)) headers
+    headers' = fmap (onPathType (\h -> canonicalize (h:rest))) headers
 canonicalize (Env env         :_   ) = Env env
 
+onPathType :: (PathType -> PathType) -> PathHashed -> PathHashed
+onPathType f (PathHashed a b) = PathHashed a (f b)
+
 canonicalizePath :: [Path] -> Path
 canonicalizePath [] =
     Path
-        { pathMode = Code
+        { pathMode   = Code
-        , pathType = canonicalize []
+        , pathHashed = PathHashed
+            { hash = Nothing
+            , pathType = canonicalize []
+            }
         }
 canonicalizePath (path:paths) =
     Path
-        { pathMode = pathMode path
+        { pathMode   = pathMode path
-        , pathType = canonicalize (map pathType (path:paths))
+        , pathHashed = (pathHashed path)
+             { hash     = hash (pathHashed path)
+             , pathType =
+                 canonicalize (map (pathType . pathHashed) (path:paths))
+             }
         }
 
 parentURL :: Text -> Text
@@ -503,6 +523,67 @@ instance Show InternalError where
 
 instance Exception InternalError
 
+-- | Exception thrown when an integrity check fails
+data HashMismatch = HashMismatch
+    { expectedHash :: Data.ByteString.ByteString
+    , actualHash   :: Data.ByteString.ByteString
+    } deriving (Typeable)
+
+instance Exception HashMismatch
+
+instance Show HashMismatch where
+    show (HashMismatch {..}) =
+            "\n"
+        <>  "\ESC[1;31mError\ESC[0m: Import integrity check failed\n"
+        <>  "\n"
+        <>  "Expected hash:\n"
+        <>  "\n"
+        <>  "↳ " <> toString expectedHash <> "\n"
+        <>  "\n"
+        <>  "Actual hash:\n"
+        <>  "\n"
+        <>  "↳ " <> toString actualHash <> "\n"
+      where
+        toString =
+            Data.ByteString.Char8.unpack . Data.ByteString.Base16.encode
+
+assertHash :: Maybe Data.ByteString.ByteString -> Text -> IO ()
+assertHash  Nothing _ =
+    return ()
+assertHash (Just expectedHash) text =
+    if expectedHash == actualHash
+    then return ()
+    else Control.Exception.throwIO (HashMismatch {..})
+  where
+    actualBytes = Data.Text.Lazy.Encoding.encodeUtf8 text
+
+    actualHash = Crypto.Hash.SHA256.hashlazy actualBytes
+
+parseFromFileEx
+    :: Maybe Data.ByteString.ByteString
+    -> Text.Trifecta.Parser a
+    -> FilePath
+    -> IO (Text.Trifecta.Result a)
+parseFromFileEx hash parser path = do
+    text <- Data.Text.Lazy.IO.readFile stringPath
+    assertHash hash text
+
+    let lazyBytes = Data.Text.Lazy.Encoding.encodeUtf8 text
+
+    let strictBytes = Data.ByteString.Lazy.toStrict lazyBytes
+
+    let delta = Directed bytesPath 0 0 0 0
+
+    return (Text.Trifecta.parseByteString parser delta strictBytes)
+  where
+    stringPath = Filesystem.Path.CurrentOS.encodeString path
+
+    textPath = case Filesystem.Path.CurrentOS.toText path of
+       Left  text -> text
+       Right text -> text
+
+    bytesPath = Data.Text.Encoding.encodeUtf8 textPath
+
 -- | Parse an expression from a `Path` containing a Dhall program
 exprFromPath :: Manager -> Path -> IO (Expr Src Path)
 exprFromPath m (Path {..}) = case pathType of
@@ -521,23 +602,17 @@ exprFromPath m (Path {..}) = case pathType of
                     then return ()
                     else Control.Exception.throwIO MissingFile
 
-                let string = Filesystem.Path.CurrentOS.encodeString path
-
                 -- Unfortunately, GHC throws an `InappropriateType` exception
                 -- when trying to read a directory, but does not export the
                 -- exception, so I must resort to a more heavy-handed `catch`
                 let handler :: IOException -> IO (Result (Expr Src Path))
                     handler e = do
-                        let string' =
-                                Filesystem.Path.CurrentOS.encodeString
-                                    (path </> "@")
-
                         -- If the fallback fails, reuse the original exception
                         -- to avoid user confusion
-                        Text.Trifecta.parseFromFileEx parser string'
+                        parseFromFileEx hash parser (path </> "@")
                             `onException` throwIO e
 
-                x <- Text.Trifecta.parseFromFileEx parser string `catch` handler
+                x <- parseFromFileEx hash parser path `catch` handler
                 case x of
                     Failure errInfo -> do
                         throwIO (ParseError (Text.Trifecta._errDoc errInfo))
@@ -545,6 +620,7 @@ exprFromPath m (Path {..}) = case pathType of
                         return expr
             RawText -> do
                 text <- Filesystem.readTextFile path
+                assertHash hash (Text.fromStrict text)
                 return (TextLit (build text))
     URL url headerPath -> do
         request <- HTTP.parseUrlThrow (Text.unpack url)
@@ -605,6 +681,8 @@ exprFromPath m (Path {..}) = case pathType of
             Left  err  -> throwIO err
             Right text -> return text
 
+        assertHash hash text
+
         case pathMode of
             Code -> do
                 let urlBytes = Data.Text.Lazy.Encoding.encodeUtf8 url
@@ -641,6 +719,8 @@ exprFromPath m (Path {..}) = case pathType of
         x <- System.Environment.lookupEnv (Text.unpack env)
         case x of
             Just str -> do
+                assertHash hash (Text.pack str)
+
                 case pathMode of
                     Code -> do
                         let envBytes = Data.Text.Lazy.Encoding.encodeUtf8 env
@@ -654,6 +734,8 @@ exprFromPath m (Path {..}) = case pathType of
                     RawText -> return (TextLit (build str))
             Nothing  -> throwIO (MissingEnvironmentVariable env)
   where
+    PathHashed {..} = pathHashed
+
     parser = unParser (do
         Text.Parser.Token.whiteSpace
         r <- Dhall.Parser.expr
@@ -691,15 +773,15 @@ loadStaticWith :: MonadCatch m => (Path -> m (Expr Src Path))
 loadStaticWith from_path ctx path = do
     paths <- zoom stack State.get
 
-    let local (Path (URL url _) _) =
+    let local (Path (PathHashed _ (URL url _)) _) =
             case HTTP.parseUrlThrow (Text.unpack url) of
                 Nothing      -> False
                 Just request -> case HTTP.host request of
                     "127.0.0.1" -> True
                     "localhost" -> True
                     _           -> False
-        local (Path (File _ _ ) _) = True
+        local (Path (PathHashed _ (File _ _ )) _) = True
-        local (Path (Env  _   ) _) = True
+        local (Path (PathHashed _ (Env  _   )) _) = True
 
     let parent = canonicalizePath paths
     let here   = canonicalizePath (path:paths)

src/Dhall/Parser.hs

@@ -43,6 +43,7 @@ import Text.Trifecta
 import Text.Trifecta.Delta (Delta)
 
 import qualified Control.Monad
+import qualified Data.ByteString.Base16.Lazy
 import qualified Data.Char
 import qualified Data.HashSet
 import qualified Data.Map
@@ -931,7 +932,7 @@ http = do
     whitespace
     b <- optional (do
         _using
-        pathType_ )
+        pathHashed_ )
     return (URL (Data.Text.Lazy.Builder.toLazyText a) b)
 
 env :: Parser PathType
@@ -1493,10 +1494,27 @@ exprA = completeExpression
 pathType_ :: Parser PathType
 pathType_ = choice [ file, http, env ]
 
+pathHashed_ :: Parser PathHashed
+pathHashed_ = do
+    pathType <- pathType_
+    hash     <- optional pathHash_
+    return (PathHashed {..})
+  where
+    pathHash_ = do
+        _ <- Text.Parser.Char.text "sha256:"
+        builder <- count 64 (satisfy hexdig <?> "hex digit")
+        whitespace
+        let lazyText = Data.Text.Lazy.Builder.toLazyText builder
+        let lazyBytes = Data.Text.Lazy.Encoding.encodeUtf8 lazyText
+        let (hash, suffix) = Data.ByteString.Base16.Lazy.decode lazyBytes
+        if Data.ByteString.Lazy.null suffix
+            then return (Data.ByteString.Lazy.toStrict hash)
+            else fail "Invalid sha256 hash"
+
 import_ :: Parser Path
 import_ = (do
-    pathType <- pathType_
+    pathHashed <- pathHashed_
-    pathMode <- alternative <|> pure Code
+    pathMode   <- alternative <|> pure Code
     return (Path {..}) ) <?> "import"
   where
     alternative = do