Merge pull request #474 from sorki/srk/interepreter

init implicit-interepreter

.gitignore

@@ -8,13 +8,14 @@
 *.png
 *.ps
 *.stl
-!tests/golden/*.stl
 *.svg
 *.ascii.stl
 *.asciistl
 *.three.js
 *.threejs
 *.obj
+# Don't gitignore golden preimages
+!tests/golden/
 # Generated by the build process
 cabal.project.local
 Setup

cabal.project

@@ -1 +1,6 @@
-packages: .
+packages:
+  ./implicit.cabal
+  ./implicit-interpreter/implicit-interpreter.cabal
+
+-- due to interpreter tests
+write-ghc-environment-files: always

default.nix

@@ -1,14 +1,28 @@
-{ rev ? "679cadfdfed2b90311a247b2d6ef6dfd3d6cab73"
+{ pkgs ? import <nixpkgs> { }
+, compiler ? null
 , withImplicitSnap ? false
-, pkgs ?
-    if ((rev == "") || (rev == "default") || (rev == "local"))
-      then import <nixpkgs> { }
-      # Do not guard with hash, so the project is able to use current channels (rolling `rev`) of Nixpkgs
-      else import (builtins.fetchTarball "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz") { }
 }:
 let
-  src = pkgs.nix-gitignore.gitignoreSource [ ] ./.;
-in
-  if withImplicitSnap
-  then pkgs.haskellPackages.callCabal2nixWithOptions "implicit" src "-fimplicitsnap" { }
-  else pkgs.haskellPackages.callCabal2nix "implicit" src { }
+  overlay = import ./overlay.nix pkgs compiler withImplicitSnap;
+  overrideHaskellPackages = orig: {
+    buildHaskellPackages =
+      orig.buildHaskellPackages.override overrideHaskellPackages;
+    overrides = if orig ? overrides
+      then pkgs.lib.composeExtensions orig.overrides overlay
+      else overlay;
+  };
+
+  packageSet =
+    if compiler == null
+    then pkgs.haskellPackages
+    else pkgs.haskell.packages.${compiler};
+
+  haskellPackages = packageSet.override overrideHaskellPackages;
+in {
+  inherit (haskellPackages)
+    implicit
+    implicit-interpreter;
+
+  inherit haskellPackages;
+  inherit pkgs;
+}

implicit-interpreter/CHANGELOG.md

@@ -0,0 +1,10 @@
+# Version [0.1.0.0](https://github.com/HaskellThings/ImplicitCAD/compare/interpreter-0.1.0.0...interpreter-0.1.0.0) (2024-MM-DD)
+
+* Initial release
+
+---
+
+`implicit-interpreter` uses [PVP Versioning][1].
+
+[1]: https://pvp.haskell.org
+

implicit-interpreter/README.md

@@ -0,0 +1,3 @@
+# implicit-interpreter
+
+Interpret implicit objects using [Hint](https://hackage.haskell.org/package/hint).

implicit-interpreter/implicit-interpreter.cabal

@@ -0,0 +1,48 @@
+cabal-version:       2.2
+name:                implicit-interpreter
+version:             0.1.0.0
+synopsis:            ImplicitCAD Haskell intepreter
+description:         Interpret implicit objects using Hint
+homepage:            https://github.com/HaskellThings/ImplicitCAD
+License:             AGPL-3.0-or-later
+license-file:        LICENSE
+author:              Sorki
+maintainer:          [email protected]
+copyright:           2024 Sorki
+category:            Graphics
+build-type:          Simple
+
+extra-source-files:
+    LICENSE
+    README.md
+
+extra-doc-files:
+    CHANGELOG.md
+
+library
+  ghc-options:         -Wall -Wunused-packages
+  hs-source-dirs:      src
+  exposed-modules:     Graphics.Implicit.Interpreter
+  build-depends:       base >= 4.7 && < 5
+                     , filepath
+                     , hint
+                     , transformers
+                     , temporary
+                     , exceptions
+                     , text
+  default-language:    Haskell2010
+
+test-suite implicit-interpreter-tests
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  build-depends:       base >= 4.7 && < 5
+                     , implicit
+                     , implicit-interpreter
+                     , hspec
+                     , text
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/HaskellThings/ImplicitCAD

implicit-interpreter/src/Graphics/Implicit/Interpreter.hs

@@ -0,0 +1,228 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Graphics.Implicit.Interpreter (
+    ImplicitInterpreterError(..)
+  , renderError
+  , interpret
+  , interpretText
+  ) where
+
+import Control.Monad.Catch (MonadMask)
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Data.Typeable (Typeable)
+import Data.Text (Text)
+import Language.Haskell.Interpreter (InterpreterError(..), InterpreterT)
+
+import qualified Control.Monad.IO.Class
+import qualified Data.Foldable
+import qualified Data.Maybe
+import qualified Data.Text
+import qualified Data.Text.IO
+import qualified Language.Haskell.Interpreter
+import qualified System.FilePath
+import qualified System.IO.Temp
+import qualified Type.Reflection
+
+data ImplicitInterpreterError
+  = ImplicitInterpreterError_Unsafe -- ^ Thrown when module contains unsafe functions
+  | ImplicitInterpreterError_Hint InterpreterError
+  deriving Show
+
+renderError :: ImplicitInterpreterError -> Text
+renderError ImplicitInterpreterError_Unsafe = "Refusing to evaluate unsafe functions"
+renderError (ImplicitInterpreterError_Hint e) = renderHintError e
+
+renderHintError :: InterpreterError -> Text
+renderHintError (WontCompile ghcErrs) =
+  Data.Text.unlines
+  $ Data.Text.pack
+  . Language.Haskell.Interpreter.errMsg
+  <$> ghcErrs
+renderHintError (UnknownError str) = "Unknown error: " <> Data.Text.pack str
+renderHintError (NotAllowed str) = "Not allowed: " <> Data.Text.pack str
+renderHintError (GhcException str) = "GHC exception: " <> Data.Text.pack str
+
+-- | Interpret a file, trying to evaluate @obj@ variable
+-- representing @SymbolicObj2@ or @SymbolicObj3@.
+--
+-- If file defines resolution as @res@ variable,
+-- evaluate it (if it is a Double, Float, Int or Integer)
+-- and return alongside an evaluated object. Return
+-- default resolution of 1 if not defined.
+interpret
+  :: forall a
+   . Typeable a
+  => FilePath
+  -> IO (Either ImplicitInterpreterError (Double, a))
+interpret modFile = do
+  let
+      -- we always eval obj variable
+      exprToEval = "obj"
+      initialResolution = 1
+
+  mo <-
+    Language.Haskell.Interpreter.runInterpreter
+    $ do
+        Language.Haskell.Interpreter.set
+          [ Language.Haskell.Interpreter.searchPath
+            Language.Haskell.Interpreter.:=
+            pure (System.FilePath.takeDirectory modFile)
+          ]
+
+        Language.Haskell.Interpreter.loadModules
+          [modFile]
+
+        loadedMods
+          <- Language.Haskell.Interpreter.getLoadedModules
+
+        Language.Haskell.Interpreter.setTopLevelModules
+          loadedMods
+
+        obj <-
+          Language.Haskell.Interpreter.interpret
+            exprToEval
+            (Language.Haskell.Interpreter.as @a)
+
+        mRes <-
+          runMaybeT
+          $ Data.Foldable.asum
+          $ map
+              MaybeT
+              [                       evalRes @Double
+              , fmap realToFrac   <$> evalRes @Float
+              , fmap fromIntegral <$> evalRes @Int
+              , fmap fromIntegral <$> evalRes @Integer
+              ]
+
+        pure
+          ( Data.Maybe.fromMaybe initialResolution mRes
+          , obj
+          )
+
+  pure $ case mo of
+    Right x -> Right x
+    Left e -> Left $ ImplicitInterpreterError_Hint e
+
+evalRes
+  :: forall t m
+   . ( MonadIO m
+     , MonadMask m
+     , Typeable t
+     , Num t
+     )
+  => InterpreterT m (Maybe t)
+evalRes = do
+  tcs <-
+    Language.Haskell.Interpreter.typeChecks
+      (  "res :: "
+      <> (show $ Type.Reflection.typeOf @t 0)
+      )
+  if tcs
+  then
+    Just
+    <$> Language.Haskell.Interpreter.interpret
+          "res"
+          (Language.Haskell.Interpreter.as @t)
+  else pure Nothing
+
+-- | Interpret a text
+-- representing @SymbolicObj2@ or @SymbolicObj3@.
+--
+-- Inpute can be either a full module or bare object
+-- expression like @sphere 3@ in which case it is
+-- wrapped in a module template using @makeModule@ with typical
+-- imports and equated to @obj = sphere 3@.
+--
+-- Temporary directory is created with a @Object.hs@ file
+-- which is then passed to @interpret@, which sets a search
+-- path to the directory.
+--
+-- Since this is used by implicit-servant to evaluate
+-- untrusted input, we refuse to evaluate anything
+-- containing @unsafe@ string, which could be used
+-- to perform @IO@ using e.g. @unsafePerformIO@
+-- during @obj@ evaluation which is otherwise pure.
+interpretText
+  :: forall a
+   . Typeable a
+  => Text
+  -> IO (Either ImplicitInterpreterError (Double, a))
+interpretText code | isUnsafe (describeInput code) =
+  pure $ Left ImplicitInterpreterError_Unsafe
+interpretText code =
+  let
+    InputDesc{..} = describeInput code
+    codeModule =
+      if hasImports && hasModule
+      then code
+      else makeModule code
+  in
+    withModuleAsFile
+      codeModule
+      interpret
+
+withModuleAsFile
+  :: ( MonadMask m
+     , MonadIO m
+     )
+  => Text
+  -> (FilePath -> m a)
+  -> m a
+withModuleAsFile source action = do
+  System.IO.Temp.withSystemTempDirectory
+    "implicitInterpreter"
+    $ \dir -> do
+        let
+          fp =
+            System.FilePath.joinPath
+              [ dir
+              , "Object.hs"
+              ]
+
+        Control.Monad.IO.Class.liftIO
+          $ Data.Text.IO.writeFile
+              fp
+              source
+
+        action fp
+
+-- | Input description
+data InputDesc = InputDesc {
+    hasImports :: Bool -- ^ Contains import statements
+  , hasModule :: Bool -- ^ Contains module definition
+  , hasPragmas :: Bool -- ^ Contains LANGAUGE pragmas
+  , isUnsafe :: Bool -- ^ Contains any @unsafe@ functions
+  } deriving (Eq, Show)
+
+-- | Check if input is a proper module, with
+-- imports and detect any @unsafe@ functions.
+describeInput :: Text -> InputDesc
+describeInput src =
+  let
+    has what x = what `Data.Text.isInfixOf` x
+    hasImports = has "import" src
+    hasModule = has "module" src
+    hasPragmas = has "LANGUAGE" src
+    isUnsafe = has "unsafe" src
+  in InputDesc {..}
+
+-- describeInput "module Blah where\nimport Foo\nunsafePerform\nLANGUAGE"
+-- InputDesc {hasImports = True, hasModule = True, hasPragmas = True, isUnsafe = True}
+
+makeModule
+  :: Text -- ^ Input sauce
+  -> Text
+makeModule rawExpr =
+  Data.Text.unlines
+    [ "module Object (obj) where"
+    , mempty
+    , "import Linear"
+    , "import Graphics.Implicit"
+    , "import Graphics.Implicit.Definitions"
+    , mempty
+    , "obj = " <> rawExpr
+    ]