diff --git a/codeworld-server/codeworld-server.cabal b/codeworld-server/codeworld-server.cabal index be241e21..7ed4ee28 100644 --- a/codeworld-server/codeworld-server.cabal +++ b/codeworld-server/codeworld-server.cabal @@ -15,7 +15,7 @@ Description: Executable codeworld-server Hs-source-dirs: src Main-is: Main.hs - Other-modules: Model, Util + Other-modules: Model, Util, Config Build-depends: aeson, @@ -23,6 +23,7 @@ Executable codeworld-server 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 diff --git a/codeworld-server/src/Config.hs b/codeworld-server/src/Config.hs new file mode 100644 index 00000000..63794c67 --- /dev/null +++ b/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 diff --git a/codeworld-server/src/Main.hs b/codeworld-server/src/Main.hs index bb86c075..3864bd14 100644 --- a/codeworld-server/src/Main.hs +++ b/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" diff --git a/config/keter.yaml b/config/keter.yaml index 72527856..add66b3d 100644 --- a/config/keter.yaml +++ b/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 diff --git a/run.sh b/run.sh index 0aad6c5f..31534eab 100755 --- a/run.sh +++ b/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