Implement previews

codeworld-server/codeworld-server.cabal

@@ -15,14 +15,15 @@ Description:
 Executable codeworld-server
   Hs-source-dirs: src
   Main-is: Main.hs
-  Other-modules: Model, Util
+  Other-modules: Model, Util, Config
 
   Build-depends:
     aeson,
     base,
     base64-bytestring,
     bytestring,
     codeworld-compiler,
+    containers,
     cryptonite,
     data-default,
     directory,
@@ -45,7 +46,8 @@ Executable codeworld-server
     temporary,
     text,
     unix,
-    vector
+    vector,
+    yaml
 
   Ghc-options: -threaded
                -Wall

codeworld-server/src/Config.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Config
+  ( Config (..)
+  , PreviewConfig (..)
+  , loadConfig
+  ) 
+where
+
+import Data.Map (Map, fromAscList)
+import Data.Text (Text)
+import Data.Yaml (FromJSON(..), withObject, (.:?), (.!=), decodeFileEither, prettyPrintParseException)
+import System.Environment (lookupEnv, getExecutablePath)
+import System.FilePath (FilePath, takeDirectory)
+import System.IO (hPutStrLn, stderr)
+
+data Config = Config 
+  { previewConfig :: PreviewConfig
+  } deriving Show
+
+data PreviewConfig = PreviewConfig
+  { enabledByDefault :: Bool
+  , defaultHoleValues :: Map Text Text
+  } deriving Show
+
+defaultConfig :: Config
+defaultConfig = Config
+  { previewConfig = defaultPreviewConfig
+  }
+
+defaultPreviewConfig :: PreviewConfig
+defaultPreviewConfig = PreviewConfig
+  { enabledByDefault = False
+  , defaultHoleValues = fromAscList []
+  }
+
+instance FromJSON Config where
+  parseJSON = withObject "Config" $ \v -> Config
+    <$> v .:? "preview" .!= defaultPreviewConfig
+
+instance FromJSON PreviewConfig where
+  parseJSON = withObject "PreviewConfig" $ \v -> PreviewConfig
+    <$> v .:? "enabledByDefault" .!= False
+    <*> v .:? "defaultHoleValues" .!= fromAscList []
+
+determineConfigPath :: IO FilePath
+determineConfigPath = do
+  configPathFromEnv <- lookupEnv "CONFIG_PATH" :: IO (Maybe FilePath)
+  case configPathFromEnv of
+    Just path -> pure path
+    Nothing -> do
+      exePath <- getExecutablePath
+      pure (takeDirectory exePath ++ "/config.yaml")
+
+
+loadConfig :: IO Config
+loadConfig = do
+  configPath <- determineConfigPath
+  parseResult <- decodeFileEither configPath
+  case parseResult of
+    Left err -> do
+      hPutStrLn stderr ("Warning: Failed to load CodeWorld config from " ++ configPath ++ ". Resuming with default config. ")
+      hPutStrLn stderr $ prettyPrintParseException err
+      pure defaultConfig
+    Right cfg -> do 
+      putStrLn "Successfully loaded CodeWorld config."
+      print cfg
+      pure cfg

codeworld-server/src/Main.hs

@@ -27,6 +27,7 @@ module Main where
 
 import CodeWorld.Compile
 import CodeWorld.Compile.Base
+import Config
 import Control.Applicative
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MSem (MSem)
@@ -42,6 +43,7 @@ import qualified Data.ByteString.Lazy as LB
 import Data.Char (isSpace)
 import Data.List
 import Data.List.Extra (replace)
+import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid
 import Data.Text (Text)
@@ -64,6 +66,7 @@ import System.IO.Temp
 import System.Environment (lookupEnv)
 import Util
 import Text.Read (readMaybe)
+import Text.Regex.TDFA
 
 maxSimultaneousCompiles :: Int
 maxSimultaneousCompiles = 4
@@ -74,24 +77,27 @@ maxSimultaneousErrorChecks = 2
 data Context = Context
   { compileSem :: MSem Int,
     errorSem :: MSem Int,
-    baseSem :: MSem Int
+    baseSem :: MSem Int,
+    config :: Config
   }
 
 main :: IO ()
 main = do
-  ctx <- makeContext
+  cfg <- loadConfig
+  ctx <- makeContext cfg
   port <- maybe Nothing readMaybe <$> lookupEnv "PORT" :: IO (Maybe Int)
   cfg <- S.commandLineConfig ((maybe id (\p -> S.setPort p) port) S.defaultConfig)
   forkIO $ baseVersion >>= buildBaseIfNeeded ctx >> return ()
   httpServe cfg $ (processBody >> site ctx) <|> site ctx
 
-makeContext :: IO Context
-makeContext = do
+makeContext :: Config -> IO Context
+makeContext cfg = do
   ctx <-
     Context
       <$> MSem.new maxSimultaneousCompiles
       <*> MSem.new maxSimultaneousErrorChecks
       <*> MSem.new 1
+      <*> pure cfg
   return ctx
 
 -- | A CodeWorld Snap API action
@@ -152,39 +158,91 @@ withProgramLock (BuildMode mode) (ProgramId hash) action = do
   let tmpFile = tmpDir </> "codeworld" <.> T.unpack hash <.> mode
   withFileLock tmpFile Exclusive (const action)
 
-compileHandler :: CodeWorldHandler
-compileHandler ctx = do
-  mode <- getBuildMode
-  Just source <- getParam "source"
-  let programId = sourceToProgramId source
-      deployId = sourceToDeployId source
-      id = unProgramId programId
-      did = unDeployId deployId
 
-  (compileStatus, responseBody) <- liftIO $ withSystemTempDirectory "codeworld" $ \tempDir -> do
+runCompile :: Context -> ProgramId -> BuildMode -> Text -> IO (CompileStatus, Either Text (Text,Text))
+runCompile ctx programId mode source = withSystemTempDirectory "codeworld" $ \tempDir -> do
     let sourceDir = tempDir </> "source"
         buildDir = tempDir </> "build"
     createDirectoryIfMissing True sourceDir
     createDirectoryIfMissing True buildDir
 
     status <- withProgramLock mode programId $ do
-      B.writeFile (sourceDir </> sourceFile programId) source
+      T.writeFile (sourceDir </> sourceFile programId) source
       compileIfNeeded ctx tempDir mode programId
 
     hasResultFile <- doesFileExist (buildDir </> resultFile programId)
 
-    resBody <- case status of
+    case status of
       CompileSuccess | hasResultFile -> do
         content <- readFile (buildDir </> resultFile programId)
         target <- readFile (buildDir </> targetFile programId)
-        pure $ T.intercalate "\n=======================\n" [id,did,T.pack content,T.pack target]
+        pure (status, Right (T.pack content,T.pack target))
       _ | hasResultFile -> do
         content <- readFile (buildDir </> resultFile programId)
-        pure $ T.intercalate "\n=======================\n" [id,did,T.pack content]
-      _ -> pure "Something went wrong"
-
-    pure (status, resBody)
-
+        pure (status, Left $ T.pack content)
+      _ -> pure (status, Left "Something went wrong")
+
+replaceHolesWithDefaultValue :: [(Int,Int,Text)] -> M.Map Text Text -> Text -> Maybe Text
+replaceHolesWithDefaultValue holes defaults input = T.unlines <$> replaceHolesInLines lines
+  where 
+    lines = zip [1 :: Int ..] $ T.lines input
+
+    replaceHolesInLines lines = traverse (\(num,line) -> replaceHolesInLine (filter (\(r,_,_) -> r == num) holes) 1 line) lines
+
+    replaceHolesInLine [] _ line = Just line
+    replaceHolesInLine ((_,c,ty):xs) cursor line = 
+      let (before,rest) = T.splitAt (c - cursor) line
+       in case M.lookup ty defaults of
+        Nothing -> Nothing
+        Just defaultValue -> do
+          newRest <- replaceHolesInLine xs (c + 1) (T.drop 1 rest)
+          pure $ before <> "(" <> defaultValue <> ")" <> newRest
+
+
+compileHandler :: CodeWorldHandler
+compileHandler ctx = do
+  mode <- getBuildMode
+  let previewConf = previewConfig $ config ctx
+  Just source <- (T.decodeUtf8 <$>) <$> getParam "source"
+  mPreview <- getParam "enablePreview"
+  let programId = sourceToProgramId $ T.encodeUtf8 source
+      id = unProgramId programId
+      did = "deploy_id"
+      previewsEnabled = case mPreview of
+        Just "True" -> True
+        Just "true" -> True
+        Just "False" -> False
+        Just "false" -> False
+        _ -> enabledByDefault previewConf
+
+  (compileStatus, result) <- do 
+    (status, res) <- liftIO $ runCompile ctx programId mode source
+    if not previewsEnabled || status /= CompileSuccess
+      then pure (status, res)
+      else do 
+        let sourceWithHoles = T.replace "undefined" "_" source
+        (status',res') <- liftIO $ runCompile ctx programId mode sourceWithHoles
+        case res' of
+          Right _ -> pure (status', res')
+          Left error -> do
+            let errorSplit = T.splitOn "\n\n" error
+                regex = "^program\\.hs:([[:digit:]]+):([[:digit:]]+): error:[[:cntrl:]] +[^F]+Found hole: _ :: ([[:print:]]+)[[:cntrl:]]" :: Text
+                matches = concatMap (\block -> block =~ regex :: [[Text]]) errorSplit
+                textToInt = read . T.unpack
+                holes = mapMaybe (\input -> case input of { [_,line,col,ty] -> Just (textToInt line, textToInt col, ty); _ -> Nothing } ) matches
+                replacementMap = defaultHoleValues previewConf
+
+            case replaceHolesWithDefaultValue holes replacementMap sourceWithHoles of
+              Nothing -> pure (status, res)
+              Just withDefaultValues -> do
+                (status'',res'') <- liftIO $ runCompile ctx programId mode withDefaultValues
+                case status'' of
+                  CompileSuccess -> pure (status'', res'')
+                  _ -> pure (status, res)
+
+  let responseBody = T.intercalate "\n=======================\n" $ case result of 
+          Right (content, target) -> [id,did,content,target]
+          Left errorMessage -> [id,did,errorMessage]    
 
   modifyResponse $ setResponseCode (responseCodeFromCompileStatus compileStatus)
   modifyResponse $ setContentType "text/plain"

config/keter.yaml

@@ -11,6 +11,7 @@ stanzas:
       LC_ALL: "C.UTF-8"
       PATH: "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/opt/codeworld/build/bin"
       EXTENSIONS_CONFIG_PATH: "/opt/codeworld/extensions.yaml"
+      CONFIG_PATH: "/opt/codeworld/config.yaml"
 
     hosts:
       - localhost

run.sh

@@ -28,5 +28,6 @@ fuser -k -n tcp "${PORT}"
 
 mkdir -p log
 
+export CONFIG_PATH=$(pwd)/config.yaml
 export EXTENSIONS_CONFIG_PATH=$(pwd)/extensions.yaml
 run . ./build/bin/codeworld-server -p $PORT --no-access-log