content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE MultiWayIf #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# OPTIONS_GHC -fno-warn-incomplete-patterns
      -fno-warn-name-shadowing
      -fno-warn-unused-imports
      -fno-warn-unused-matches #-}
  
  {-
    Copyright 2020 The CodeWorld Authors. All rights reserved.
  
    Licensed under the Apache License, Version 2.0 (the "License");
    you may not use this file except in compliance with the License.
    You may obtain a copy of the License at
  
        http://www.apache.org/licenses/LICENSE-2.0
  
    Unless required by applicable law or agreed to in writing, software
    distributed under the License is distributed on an "AS IS" BASIS,
    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
    See the License for the specific language governing permissions and
    limitations under the License.
  -}
  module Main where
  
  import CodeWorld.Account (UserId)
  import CodeWorld.Auth
    ( AuthConfig,
      authMethod,
      authRoutes,
      authenticated,
      getAuthConfig,
    )
  import CodeWorld.Compile
  import CodeWorld.Compile.Base
  import Control.Applicative
  import Control.Concurrent (forkIO)
  import Control.Concurrent.MSem (MSem)
  import qualified Control.Concurrent.MSem as MSem
  import Control.Exception (bracket_)
  import Control.Exception.Lifted (catch)
  import Control.Monad
  import Control.Monad.Trans
  import Data.Aeson
  import qualified Data.ByteString as B
  import Data.ByteString.Builder (toLazyByteString)
  import qualified Data.ByteString.Lazy as LB
  import Data.Char (isSpace)
  import Data.List
  import Data.Maybe
  import Data.Monoid
  import Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import qualified Data.Text.IO as T
  import qualified Data.Vector as V
  import Model
  import Network.HTTP.Simple
  import Ormolu (OrmoluException, defaultConfig, ormolu)
  import Snap.Core
  import Snap.Http.Server (quickHttpServe)
  import Snap.Util.FileServe
  import Snap.Util.FileUploads
  import System.Directory
  import System.FileLock
  import System.FilePath
  import System.IO.Temp
  import Util
  
  maxSimultaneousCompiles :: Int
  maxSimultaneousCompiles = 4
  
  maxSimultaneousErrorChecks :: Int
  maxSimultaneousErrorChecks = 2
  
  data Context = Context
    { authConfig :: AuthConfig,
      compileSem :: MSem Int,
      errorSem :: MSem Int,
      baseSem :: MSem Int
    }
  
  main :: IO ()
  main = do
    ctx <- makeContext
    forkIO $ baseVersion >>= buildBaseIfNeeded ctx >> return ()
    quickHttpServe $ (processBody >> site ctx) <|> site ctx
  
  makeContext :: IO Context
  makeContext = do
    ctx <-
      Context <$> (getAuthConfig =<< getCurrentDirectory)
        <*> MSem.new maxSimultaneousCompiles
        <*> MSem.new maxSimultaneousErrorChecks
        <*> MSem.new 1
    putStrLn $ "Authentication method: " ++ authMethod (authConfig ctx)
    return ctx
  
  -- | A CodeWorld Snap API action
  type CodeWorldHandler = Context -> Snap ()
  
  -- | A public handler that can be called from both authenticated and
  --  unauthenticated clients and that does not need access to the user
  --  ID.
  public :: CodeWorldHandler -> CodeWorldHandler
  public = id
  
  -- | A private handler that can only be called from authenticated
  --  clients and needs access to the user ID.
  private :: (UserId -> CodeWorldHandler) -> CodeWorldHandler
  private handler ctx = authenticated (flip handler ctx) (authConfig ctx)
  
  -- A revised upload policy that allows up to 8 MB of uploaded data in a
  -- request.  This is needed to handle uploads of projects including editor
  -- history.
  codeworldUploadPolicy :: UploadPolicy
  codeworldUploadPolicy =
    setMaximumFormInputSize (2 ^ (23 :: Int)) defaultUploadPolicy
  
  -- Processes the body of a multipart request.
  #if MIN_VERSION_snap_core(1,0,0)
  processBody :: Snap ()
  processBody = do
      handleMultipart codeworldUploadPolicy (\x y -> return ())
      return ()
  #else
  processBody :: Snap ()
  processBody = do
      handleMultipart codeworldUploadPolicy (\x -> return ())
      return ()
  #endif
  
  getBuildMode :: Snap BuildMode
  getBuildMode =
    getParam "mode" >>= \case
      Just "haskell" -> return (BuildMode "haskell")
      Just "blocklyXML" -> return (BuildMode "blocklyXML")
      _ -> return (BuildMode "codeworld")
  
  site :: CodeWorldHandler
  site ctx =
    let routes =
          [ ("loadProject", loadProjectHandler ctx),
            ("saveProject", saveProjectHandler ctx),
            ("deleteProject", deleteProjectHandler ctx),
            ("createFolder", createFolderHandler ctx),
            ("deleteFolder", deleteFolderHandler ctx),
            ("listFolder", listFolderHandler False ctx),
            ("listFolders", listFolderHandler True ctx),
            ("updateChildrenIndexes", updateChildrenIndexesHandler ctx),
            ("shareFolder", shareFolderHandler ctx),
            ("shareContent", shareContentHandler ctx),
            ("moveProject", moveProjectHandler ctx),
            ("compile", compileHandler ctx),
            ("errorCheck", errorCheckHandler ctx),
            ("saveXMLhash", saveXMLHashHandler ctx),
            ("loadXML", loadXMLHandler ctx),
            ("loadSource", loadSourceHandler ctx),
            ("run", runHandler ctx),
            ("runJS", runHandler ctx),
            ("runBaseJS", runBaseHandler ctx),
            ("runMsg", runMessageHandler ctx),
            ("haskell", serveFile "web/env.html"),
            ("blocks", serveFile "web/blocks.html"),
            ("funblocks", serveFile "web/blocks.html"),
            ("indent", indentHandler ctx),
            ("gallery/:shareHash", galleryHandler ctx),
            ("log", logHandler ctx)
          ]
            ++ authRoutes (authConfig ctx)
     in route routes <|> serveDirectory "web"
  
  -- A DirectoryConfig that sets the cache-control header to avoid errors when new
  -- changes are made to JavaScript.
  dirConfig :: DirectoryConfig Snap
  dirConfig = defaultDirectoryConfig {preServeHook = disableCache}
    where
      disableCache _ = modifyRequest (addHeader "Cache-control" "no-cache")
  
  createFolderHandler :: CodeWorldHandler
  createFolderHandler = private $ \userId ctx -> do
    mode <- getBuildMode
    Just path <- fmap (splitDirectories . T.unpack . T.decodeUtf8) <$> getParam "path"
    let pathText = map T.pack path
        dirIds = map nameToDirId pathText
        finalDir = joinPath $ map dirBase dirIds
        name = last pathText
    liftIO $ ensureUserBaseDir mode userId finalDir
    liftIO $ createDirectory $ userProjectDir mode userId </> finalDir
    modifyResponse $ setContentType "text/plain"
    liftIO $
      T.writeFile
        (userProjectDir mode userId </> finalDir </> "dir.info")
        name
  
  deleteFolderHandler :: CodeWorldHandler
  deleteFolderHandler = private $ \userId ctx -> do
    mode <- getBuildMode
    Just path <- fmap (splitDirectories . T.unpack . T.decodeUtf8) <$> getParam "path"
    let dirIds = map (nameToDirId . T.pack) path
    let finalDir = joinPath $ map dirBase dirIds
    liftIO $ ensureUserDir mode userId finalDir
    let dir = userProjectDir mode userId </> finalDir
    liftIO $ removeDirectoryIfExists dir
  
  loadProjectHandler :: CodeWorldHandler
  loadProjectHandler = private $ \userId ctx -> do
    mode <- getBuildMode
    Just name <- getParam "name"
    let projectName = T.decodeUtf8 name
    let projectId = nameToProjectId projectName
    Just path <- fmap (splitDirectories . T.unpack . T.decodeUtf8) <$> getParam "path"
    let dirIds = map (nameToDirId . T.pack) path
    let finalDir = joinPath $ map dirBase dirIds
    liftIO $ ensureProjectDir mode userId finalDir projectId
    let file =
          userProjectDir mode userId </> finalDir
            </> projectFile projectId
    modifyResponse $ setContentType "application/json"
    serveFile file
  
  saveProjectHandler :: CodeWorldHandler
  saveProjectHandler = private $ \userId ctx -> do
    mode <- getBuildMode
    Just path <- fmap (splitDirectories . T.unpack . T.decodeUtf8) <$> getParam "path"
    let dirIds = map (nameToDirId . T.pack) path
    let finalDir = joinPath $ map dirBase dirIds
    Just project <- decode . LB.fromStrict . fromJust <$> getParam "project"
    let projectId = nameToProjectId (projectName project)
    liftIO $ ensureProjectDir mode userId finalDir projectId
    let file =
          userProjectDir mode userId </> finalDir
            </> projectFile projectId
    liftIO $ LB.writeFile file $ encode project
  
  deleteProjectHandler :: CodeWorldHandler
  deleteProjectHandler = private $ \userId ctx -> do
    mode <- getBuildMode
    Just name <- getParam "name"
    let projectName = T.decodeUtf8 name
    let projectId = nameToProjectId projectName
    Just path <- fmap (splitDirectories . T.unpack . T.decodeUtf8) <$> getParam "path"
    let dirIds = map (nameToDirId . T.pack) path
    let finalDir = joinPath $ map dirBase dirIds
    liftIO $ ensureProjectDir mode userId finalDir projectId
    let file =
          userProjectDir mode userId </> finalDir
            </> projectFile projectId
    liftIO $ removeFileIfExists file
  
  listFolderHandler :: Bool -> CodeWorldHandler
  listFolderHandler recurse = private $ \userId ctx -> do
    mode <- getBuildMode
    Just path <- fmap (splitDirectories . T.unpack . T.decodeUtf8) <$> getParam "path"
    let dirIds = map (nameToDirId . T.pack) path
    let finalDir = joinPath $ map dirBase dirIds
    liftIO $ ensureUserBaseDir mode userId finalDir
    liftIO $ ensureUserDir mode userId finalDir
    let projectDir = userProjectDir mode userId
    entries <- liftIO $ fsEntries recurse (projectDir </> finalDir)
    modifyResponse $ setContentType "application/json"
    writeLBS (encode entries)
  
  -- | Update order of elements inside of given directory
  updateChildrenIndexesHandler :: CodeWorldHandler
  updateChildrenIndexesHandler = private $ \userId ctx -> do
    mode <- getBuildMode
    let projectDir = userProjectDir mode userId
    Just path <-
      fmap
        ( (\p -> projectDir </> p </> "order.info")
            . joinPath
            . (map (dirBase . nameToDirId . T.pack))
            . splitDirectories
            . T.unpack
            . T.decodeUtf8
        )
        <$> getParam "path"
    param <- getParam "entries"
    -- Encoding just to check if request param is correct
    Just entries <- decodeStrict . fromJust <$> getParam "entries" :: Snap (Maybe [FileSystemEntry])
    liftIO $ LB.writeFile path $ encode entries
  
  shareFolderHandler :: CodeWorldHandler
  shareFolderHandler = private $ \userId ctx -> do
    mode <- getBuildMode
    Just path <- fmap (splitDirectories . T.unpack . T.decodeUtf8) <$> getParam "path"
    let dirIds = map (nameToDirId . T.pack) path
    let finalDir = joinPath $ map dirBase dirIds
    checkSum <-
      liftIO $ dirToCheckSum $ userProjectDir mode userId </> finalDir
    liftIO $ ensureShareDir mode $ ShareId checkSum
    liftIO
      $ B.writeFile (shareRootDir mode </> shareLink (ShareId checkSum))
      $ T.encodeUtf8 (T.pack (userProjectDir mode userId </> finalDir))
    modifyResponse $ setContentType "text/plain"
    writeBS $ T.encodeUtf8 checkSum
  
  shareContentHandler :: CodeWorldHandler
  shareContentHandler = private $ \userId ctx -> do
    mode <- getBuildMode
    Just shash <- getParam "shash"
    sharingFolder <-
      liftIO $
        B.readFile
          (shareRootDir mode </> shareLink (ShareId $ T.decodeUtf8 shash))
    Just name <- fmap T.decodeUtf8 <$> getParam "name"
    let dirPath = dirBase $ nameToDirId name
    liftIO $ ensureUserBaseDir mode userId dirPath
    liftIO
      $ copyDirIfExists (T.unpack (T.decodeUtf8 sharingFolder))
      $ userProjectDir mode userId </> dirPath
    liftIO $
      T.writeFile
        (userProjectDir mode userId </> dirPath </> "dir.info")
        name
  
  moveProjectHandler :: CodeWorldHandler
  moveProjectHandler = private $ \userId ctx -> do
    mode <- getBuildMode
    Just moveTo <- fmap (splitDirectories . T.unpack . T.decodeUtf8) <$> getParam "moveTo"
    let moveToDir = joinPath $ map (dirBase . nameToDirId . T.pack) moveTo
    Just moveFrom <- fmap (splitDirectories . T.unpack . T.decodeUtf8) <$> getParam "moveFrom"
    let projectDir = userProjectDir mode userId
    let moveFromDir =
          projectDir
            </> joinPath (map (dirBase . nameToDirId . T.pack) moveFrom)
    let parentFrom =
          if moveFrom == []
            then []
            else init moveFrom
    Just isFile <- getParam "isFile"
    case (moveTo == moveFrom, moveTo == parentFrom, isFile) of
      (False, _, "true") -> do
        Just name <- getParam "name"
        let projectId = nameToProjectId $ T.decodeUtf8 name
            file = moveFromDir </> projectFile projectId
            toFile = projectDir </> moveToDir </> projectFile projectId
        liftIO $ ensureProjectDir mode userId moveToDir projectId
        liftIO $ copyFile file toFile
        liftIO $ removeFileIfExists file
      (_, False, "false") -> do
        let dirName = last $ splitDirectories moveFromDir
        let dir = moveToDir </> dirName
        liftIO $ ensureUserBaseDir mode userId dir
        liftIO $ copyDirIfExists moveFromDir $ projectDir </> dir
        liftIO $ removeDirectoryIfExists moveFromDir
      (_, _, _) -> return ()
  
  withProgramLock :: BuildMode -> ProgramId -> IO a -> IO a
  withProgramLock (BuildMode mode) (ProgramId hash) action = do
    tmpDir <- getTemporaryDirectory
    let tmpFile = tmpDir </> "codeworld" <.> T.unpack hash <.> mode
    withFileLock tmpFile Exclusive (const action)
  
  saveXMLHashHandler :: CodeWorldHandler
  saveXMLHashHandler = public $ \ctx -> do
    mode <- getBuildMode
    unless (mode == BuildMode "blocklyXML")
      $ modifyResponse
      $ setResponseCode 500
    Just source <- getParam "source"
    let programId = sourceToProgramId source
    liftIO $ withProgramLock mode programId $ do
      ensureSourceDir mode programId
      B.writeFile (sourceRootDir mode </> sourceXML programId) source
    modifyResponse $ setContentType "text/plain"
    writeBS (T.encodeUtf8 (unProgramId programId))
  
  compileHandler :: CodeWorldHandler
  compileHandler = public $ \ctx -> do
    mode <- getBuildMode
    Just source <- getParam "source"
    let programId = sourceToProgramId source
        deployId = sourceToDeployId source
    status <- liftIO $ withProgramLock mode programId $ do
      ensureSourceDir mode programId
      B.writeFile (sourceRootDir mode </> sourceFile programId) source
      writeDeployLink mode deployId programId
      compileIfNeeded ctx mode programId
    modifyResponse $ setResponseCode (responseCodeFromCompileStatus status)
    modifyResponse $ setContentType "text/plain"
    let result = CompileResult (unProgramId programId) (unDeployId deployId)
    writeLBS (encode result)
  
  errorCheckHandler :: CodeWorldHandler
  errorCheckHandler = public $ \ctx -> do
    mode <- getBuildMode
    Just source <- getParam "source"
    (status, output) <- liftIO $ errorCheck ctx mode source
    modifyResponse $ setResponseCode (responseCodeFromCompileStatus status)
    modifyResponse $ setContentType "text/plain"
    writeBS output
  
  getHashParam :: Bool -> BuildMode -> Snap ProgramId
  getHashParam allowDeploy mode = do
    maybeHash <- getParam "hash"
    case maybeHash of
      Just h -> return (ProgramId (T.decodeUtf8 h))
      Nothing
        | allowDeploy -> do
          Just dh <- getParam "dhash"
          let deployId = DeployId (T.decodeUtf8 dh)
          liftIO $ resolveDeployId mode deployId
        | otherwise -> pass
  
  loadXMLHandler :: CodeWorldHandler
  loadXMLHandler = public $ \ctx -> do
    mode <- getBuildMode
    unless (mode == BuildMode "blocklyXML")
      $ modifyResponse
      $ setResponseCode 500
    programId <- getHashParam False mode
    modifyResponse $ setContentType "text/plain"
    serveFile (sourceRootDir mode </> sourceXML programId)
  
  loadSourceHandler :: CodeWorldHandler
  loadSourceHandler = public $ \ctx -> do
    mode <- getBuildMode
    programId <- getHashParam False mode
    modifyResponse $ setContentType "text/x-haskell"
    serveFile (sourceRootDir mode </> sourceFile programId)
  
  runHandler :: CodeWorldHandler
  runHandler = public $ \ctx -> do
    mode <- getBuildMode
    programId <- getHashParam True mode
    result <-
      liftIO
        $ withProgramLock mode programId
        $ compileIfNeeded ctx mode programId
    modifyResponse $ setResponseCode (responseCodeFromCompileStatus result)
    when (result == CompileSuccess) $ do
      modifyResponse $ setContentType "text/javascript"
      serveFile (buildRootDir mode </> targetFile programId)
  
  runBaseHandler :: CodeWorldHandler
  runBaseHandler = public $ \ctx -> do
    maybeVer <- fmap T.decodeUtf8 <$> getParam "version"
    hasProgram <-
      (\mode hash dhash -> mode && (hash || dhash))
        <$> hasParam "mode" <*> hasParam "hash" <*> hasParam "dhash"
    case maybeVer of
      Just ver -> serveFile (baseCodeFile ver)
      Nothing | hasProgram -> do
        mode <- getBuildMode
        programId <- getHashParam True mode
        result <-
          liftIO
            $ withProgramLock mode programId
            $ compileIfNeeded ctx mode programId
        modifyResponse $ setResponseCode (responseCodeFromCompileStatus result)
        when (result == CompileSuccess) $ do
          ver <-
            liftIO $
              B.readFile (buildRootDir mode </> baseVersionFile programId)
          impliedVersion ver
      _ -> do
        ver <- liftIO baseVersion
        liftIO $ buildBaseIfNeeded ctx ver
        impliedVersion (T.encodeUtf8 ver)
    where
      impliedVersion ver = redirect $ "/runBaseJS?version=" <> ver
      hasParam name = (/= Nothing) <$> getParam name
  
  runMessageHandler :: CodeWorldHandler
  runMessageHandler = public $ \ctx -> do
    mode <- getBuildMode
    programId <- getHashParam False mode
    modifyResponse $ setContentType "text/plain"
    serveFile (buildRootDir mode </> resultFile programId)
  
  indentHandler :: CodeWorldHandler
  indentHandler = public $ \ctx -> do
    mode <- getBuildMode
    Just source <- getParam "source"
    reformat source `catch` handleError
    where
      reformat source = do
        result <- ormolu defaultConfig "program.hs" (T.unpack (T.decodeUtf8 source))
        modifyResponse $ setContentType "text/x-haskell"
        writeBS $ T.encodeUtf8 result
      handleError (e :: OrmoluException) = do
        modifyResponse $ setResponseCode 500 . setContentType "text/plain"
        writeLBS $ LB.fromStrict $ T.encodeUtf8 $ T.pack (show e)
  
  galleryHandler :: CodeWorldHandler
  galleryHandler = public $ const $ do
    mode <- getBuildMode
    Just shareHash <- getParam "shareHash"
    let shareId = ShareId (T.decodeUtf8 shareHash)
    gallery <- liftIO $ do
      folder <- T.unpack . T.decodeUtf8 <$> B.readFile (shareRootDir mode </> shareLink shareId)
      files <- sort <$> projectFileNames folder
      Gallery <$> mapM (galleryItemFromProject mode folder) files
    writeLBS $ encode gallery
  
  galleryItemFromProject :: BuildMode -> FilePath -> Text -> IO GalleryItem
  galleryItemFromProject mode@(BuildMode modeName) folder name = do
    let projectId = nameToProjectId name
    let file = folder </> projectFile projectId
    Just project <- decode <$> LB.readFile file
  
    let source = T.encodeUtf8 $ projectSource project
    let programId = sourceToProgramId source
    let deployId = sourceToDeployId source
  
    liftIO $ withProgramLock mode programId $ do
      ensureSourceDir mode programId
      B.writeFile (sourceRootDir mode </> sourceFile programId) source
      writeDeployLink mode deployId programId
  
    let baseURL = "/" <> if modeName == "codeworld" then "" else T.pack modeName
  
    return
      GalleryItem
        { galleryItemName = name,
          galleryItemURL =
            "run.html"
              <> "?mode="
              <> T.pack modeName
              <> "&dhash="
              <> unDeployId deployId,
          galleryItemCode = Just (baseURL <> "#" <> unProgramId programId)
        }
  
  logHandler :: CodeWorldHandler
  logHandler = public $ \ctx -> do
    Just message <- fmap T.decodeUtf8 <$> getParam "message"
    title <-
      fromMaybe "User-reported unhelpful error message"
        <$> fmap T.decodeUtf8
        <$> getParam "title"
    tag <- fromMaybe "error-message" <$> fmap T.decodeUtf8 <$> getParam "tag"
  
    liftIO $ do
      let body =
            object
              [ ("title", String title),
                ("body", String message),
                ("labels", toJSON [tag])
              ]
      authToken <- B.readFile "github-auth-token.txt"
      let authHeader = "token " <> authToken
      let userAgent = "https://code.world github integration by cdsmith"
      request <-
        addRequestHeader "Authorization" authHeader
          <$> addRequestHeader "User-agent" userAgent
          <$> setRequestBodyJSON body
          <$> parseRequestThrow "POST https://api.github.com/repos/google/codeworld/issues"
      httpNoBody request
    return ()
  
  responseCodeFromCompileStatus :: CompileStatus -> Int
  responseCodeFromCompileStatus CompileSuccess = 200
  responseCodeFromCompileStatus CompileError = 400
  responseCodeFromCompileStatus CompileAborted = 503
  
  compileIfNeeded :: Context -> BuildMode -> ProgramId -> IO CompileStatus
  compileIfNeeded ctx mode programId = do
    hasResult <- doesFileExist (buildRootDir mode </> resultFile programId)
    hasTarget <- doesFileExist (buildRootDir mode </> targetFile programId)
    if
        | hasResult && hasTarget -> return CompileSuccess
        | hasResult -> return CompileError
        | otherwise ->
          MSem.with (compileSem ctx) $ compileProgram ctx mode programId
  
  compileProgram :: Context -> BuildMode -> ProgramId -> IO CompileStatus
  compileProgram ctx mode programId = do
    ver <- baseVersion
    baseStatus <- buildBaseIfNeeded ctx ver
  
    case baseStatus of
      CompileSuccess -> do
        status <- compileIncrementally mode programId ver
        T.writeFile (buildRootDir mode </> baseVersionFile programId) ver
  
        -- It's possible that a new library was built during the compile.  If so, then the code
        -- we've just built is suspect, and it's better to just build it anew!
        checkVer <- baseVersion
        if ver == checkVer
          then return status
          else compileProgram ctx mode programId
      _ -> return CompileAborted
  
  compileIncrementally :: BuildMode -> ProgramId -> Text -> IO CompileStatus
  compileIncrementally mode programId ver =
    compileSource stage source (projectModuleFinder mode) result (getMode mode) False
    where
      source = sourceRootDir mode </> sourceFile programId
      target = buildRootDir mode </> targetFile programId
      result = buildRootDir mode </> resultFile programId
      baseURL = "runBaseJS?version=" ++ T.unpack ver
      stage = UseBase target (baseSymbolFile ver) baseURL
  
  projectModuleFinder :: BuildMode -> String -> IO (Maybe FilePath)
  projectModuleFinder mode modName
    | length modName /= 23 || '.' `elem` modName = return Nothing
    | "P" `isPrefixOf` modName = go (ProgramId (T.pack modName))
    | "D" `isPrefixOf` modName = do
      let deployId = DeployId (T.pack modName)
      resolveDeployId mode deployId >>= go
    | otherwise = return Nothing
    where
      go programId = do
        let path = sourceRootDir mode </> sourceFile programId
        exists <- doesFileExist path
        if exists then return (Just path) else return Nothing
  
  noModuleFinder :: String -> IO (Maybe FilePath)
  noModuleFinder _ = return Nothing
  
  buildBaseIfNeeded :: Context -> Text -> IO CompileStatus
  buildBaseIfNeeded ctx ver = do
    codeExists <- doesFileExist (baseCodeFile ver)
    symbolsExist <- doesFileExist (baseSymbolFile ver)
    if not codeExists || not symbolsExist
      then MSem.with (baseSem ctx) $ withSystemTempDirectory "genbase" $ \tmpdir -> do
        let linkMain = tmpdir </> "LinkMain.hs"
        let linkBase = tmpdir </> "LinkBase.hs"
        let err = tmpdir </> "output.txt"
        generateBaseBundle basePaths baseIgnore "codeworld" linkMain linkBase
        let stage = GenBase "LinkBase" linkBase (baseCodeFile ver) (baseSymbolFile ver)
        compileSource stage linkMain noModuleFinder err "codeworld" False
      else return CompileSuccess
  
  basePaths :: [FilePath]
  basePaths = ["codeworld-base/dist/doc/html/codeworld-base/codeworld-base.txt"]
  
  baseIgnore :: [Text]
  baseIgnore = ["fromCWText", "toCWText", "randomsFrom"]
  
  errorCheck :: Context -> BuildMode -> B.ByteString -> IO (CompileStatus, B.ByteString)
  errorCheck ctx mode source = withSystemTempDirectory "cw_errorCheck" $ \dir -> do
    let srcFile = dir </> "program.hs"
    let errFile = dir </> "output.txt"
    B.writeFile srcFile source
    status <-
      MSem.with (errorSem ctx) $ MSem.with (compileSem ctx) $
        compileSource ErrorCheck srcFile (projectModuleFinder mode) errFile (getMode mode) False
    hasOutput <- doesFileExist errFile
    output <- if hasOutput then B.readFile errFile else return B.empty
    return (status, output)
  
  getMode :: BuildMode -> String
  getMode (BuildMode m) = m
  