Add remoteStatus{,With} utilities (#2131)

These make it easier to securely interpret Dhall code from a server
dhall-lang · Jan 9, 2021 · 4d3bb47 · 4d3bb47
1 parent eb77c42
commit 4d3bb47
Show file tree

Hide file tree

Showing 2 changed files with 54 additions and 30 deletions.
diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs
@@ -124,6 +124,8 @@ module Dhall.Import (
     , chainedChangeMode
     , emptyStatus
     , emptyStatusWithManager
+    , remoteStatus
+    , remoteStatusWithManager
     , stack
     , cache
     , Depends(..)
@@ -1062,7 +1064,49 @@ emptyStatus = emptyStatusWithManager defaultNewManager
 
 -- | See 'emptyStatus'.
 emptyStatusWithManager :: IO Manager -> FilePath -> Status
-emptyStatusWithManager newManager = emptyStatusWith newManager fetchRemote
+emptyStatusWithManager newManager rootDirectory =
+    emptyStatusWith newManager fetchRemote rootImport
+  where
+    prefix = if FilePath.isRelative rootDirectory
+      then Here
+      else Absolute
+
+    pathComponents =
+        fmap Text.pack (reverse (FilePath.splitDirectories rootDirectory))
+
+    directoryAsFile = File (Directory pathComponents) "."
+
+    rootImport = Import
+      { importHashed = ImportHashed
+        { hash = Nothing
+        , importType = Local prefix directoryAsFile
+        }
+      , importMode = Code
+      }
+
+{-| Default `Status` appropriate for a server interpreting Dhall code
+
+    Using this `Status` ensures that interpreted Dhall code cannot access
+    server-local resources (like files or environment variables)
+-}
+remoteStatus
+    :: URL
+    -- ^ Public address of the server
+    -> Status
+remoteStatus = remoteStatusWithManager defaultNewManager
+
+-- | See `remoteStatus`
+remoteStatusWithManager :: IO Manager -> URL -> Status
+remoteStatusWithManager newManager url =
+    emptyStatusWith newManager fetchRemote rootImport
+  where
+    rootImport = Import
+      { importHashed = ImportHashed
+        { hash = Nothing
+        , importType = Remote url
+        }
+      , importMode = Code
+      }
 
 {-| Generalized version of `load`
 

diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs
@@ -14,21 +14,14 @@ import Data.Text.Prettyprint.Doc        (Pretty (..))
 import Data.Void                        (Void)
 import Dhall.Context                    (Context)
 import Dhall.Core
-    ( Directory (..)
-    , Expr
-    , File (..)
-    , FilePrefix (..)
+    ( Expr
     , Import (..)
-    , ImportHashed (..)
-    , ImportMode (..)
-    , ImportType (..)
     , ReifiedNormalizer (..)
     , URL
     )
 import Dhall.Map                        (Map)
 import Dhall.Parser                     (Src)
 import Lens.Family                      (LensLike')
-import System.FilePath                  (isRelative, splitDirectories)
 
 #ifdef WITH_HTTP
 import qualified Dhall.Import.Manager
@@ -124,10 +117,14 @@ data Status = Status
     --   cache directory
     }
 
--- | Initial `Status`, parameterised over the HTTP 'Manager' and the remote resolver,
---   importing relative to the given directory.
-emptyStatusWith :: IO Manager -> (URL -> StateT Status IO Data.Text.Text) -> FilePath -> Status
-emptyStatusWith _newManager _remote rootDirectory = Status {..}
+-- | Initial `Status`, parameterised over the HTTP 'Manager' and the remote
+--   resolver, importing relative to the given root import.
+emptyStatusWith
+    :: IO Manager
+    -> (URL -> StateT Status IO Data.Text.Text)
+    -> Import
+    -> Status
+emptyStatusWith _newManager _remote rootImport = Status {..}
   where
     _stack = pure (Chained rootImport)
 
@@ -147,23 +144,6 @@ emptyStatusWith _newManager _remote rootDirectory = Status {..}
 
     _cacheWarning = CacheNotWarned
 
-    prefix = if isRelative rootDirectory
-      then Here
-      else Absolute
-    pathComponents =
-        fmap Data.Text.pack (reverse (splitDirectories rootDirectory))
-
-    dirAsFile = File (Directory pathComponents) "."
-
-    -- Fake import to set the directory we're relative to.
-    rootImport = Import
-      { importHashed = ImportHashed
-        { hash = Nothing
-        , importType = Local prefix dirAsFile
-        }
-      , importMode = Code
-      }
-
 -- | Lens from a `Status` to its `_stack` field
 stack :: Functor f => LensLike' f Status (NonEmpty Chained)
 stack k s = fmap (\x -> s { _stack = x }) (k (_stack s))