{-# LANGUAGE OverloadedStrings, ViewPatterns, NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, PatternGuards, NamedFieldPuns #-} module Main where import Smart hiding (hoogledb) import Cache import Converter import Args import Special import Lang import Logger import Result import Html import Hash import Snap import Snap.Core import Snap.Http.Server (httpServe) import Snap.Http.Server.Config import Snap.Util.FileServe (getSafePath, serveDirectoryWith, simpleDirectoryConfig) import qualified Data.Text as T import qualified Data.Text.IO as T import System.FilePath ((), takeExtension, dropExtension) import System.Directory (doesFileExist) import System.IO (hSetBuffering, stdin, BufferMode(NoBuffering)) import Control.Concurrent (threadDelay, forkIO, killThread) import Control.Monad (when) import Control.Monad.Trans (liftIO) import Control.Applicative ((<|>)) import Data.Time (getCurrentTime, diffUTCTime) import Data.Maybe (listToMaybe) --------------------------------------------------------------- main :: IO () main = getArgs >>= mainWithArgs mainWithArgs :: Args -> IO () mainWithArgs args@(Args {verbose, port, static, logdir, hoogledb, fileservedir, gendir, mainpage, restartpath, sourcedir, includedir}) = do log <- newLogger verbose $ logdir "interpreter.log" ch <- startGHCiServer [sourcedir] log hoogledb cache <- newCache 10 logStrMsg 2 log ("lang: " ++ lang args) putStrLn "Press any key to stop the server." t <- forkIO $ httpServe ( setPort port . setAccessLog (if null logdir then ConfigNoLog else ConfigFileLog (logdir "access.log")) . setErrorLog (if null logdir then ConfigNoLog else ConfigFileLog (logdir "error.log")) $ emptyConfig ) ( method GET ( serveDirectoryWith simpleDirectoryConfig fileservedir <|> serveHtml ch <|> ifTop (redirectString mainpage) <|> pathString restartpath (liftIO $ restart ch >> clearCache cache) ) <|> method POST (exerciseServer (sourcedir:includedir) (cache, ch) args) <|> notFound ) hSetBuffering stdin NoBuffering _ <- getChar killThread t where serveHtml ch = do p <- getSafePath when (not static && takeExtension p `elem` [".xml"]) $ liftIO $ convert ch args $ dropExtension p serveDirectoryWith simpleDirectoryConfig gendir notFound :: Snap () notFound = do writeText "Page not found." getResponse >>= finishWith . setResponseCode 404 --------------------------------------------------------------- type TaskChan' = (Cache (Int, T.Text), TaskChan) exerciseServer :: [FilePath] -> TaskChan' -> Args -> Snap () exerciseServer sourcedirs (cache, ch) args@(Args {magicname, lang, exercisedir, verboseinterpreter}) = do params <- fmap show getParams when (length params > 3000) $ do writeText "Too long request." getResponse >>= finishWith . setResponseCode 400 let md5Id = mkHash params -- could be more efficient liftIO $ logStrMsg 2 (logger ch) $ " eval " ++ show md5Id ++ " " ++ params j <- liftIO $ lookupCache cache md5Id (>>= writeText) $ case j of Left (delay, res) -> liftIO $ do logStrMsg 2 (logger ch) $ " ch " ++ show md5Id threadDelay delay return res Right cacheAction -> do time <- liftIO $ getCurrentTime res <- fmap renderHtml $ do Just [ss, fn_, x, y, T.unpack -> lang'] <- fmap sequence $ mapM getTextParam ["c","f","x","y","lang"] let fn = exercisedir T.unpack fn_ ext = case takeExtension fn of ('.':ext) -> ext _ -> "" fnExists <- liftIO $ doesFileExist fn if fnExists then do Just task <- liftIO $ fmap (eval_ ext ss y . T.splitOn (T.pack delim)) $ T.readFile fn liftIO $ exerciseServer' ('X':magicname) ch verboseinterpreter fn x lang' md5Id task else return (inconsistencyError lang') <|> return (inconsistencyError lang) liftIO $ do time' <- getCurrentTime let delay = round $ 1000000 * (realToFrac $ diffUTCTime time' time :: Double) :: Int logStrMsg 2 (logger ch) $ " end " ++ show md5Id ++ " " ++ show delay ++ " ms " ++ T.unpack res cacheAction (delay, res) return res where inconsistencyError :: String -> Html inconsistencyError lang' = renderResult $ Error True $ translate lang' "Inconsistency between server and client." eval_ :: String -> T.Text -> T.Text -> [T.Text] -> Maybe SpecialTask eval_ _ "eval" _ [_] = Just Eval eval_ _ "eval" _ [_, goodsol] = Just $ Compare magicname $ T.unpack $ T.drop (length magicname + 4) $ goodsol eval_ ext comm (T.unpack -> s) [env, hidden, re -> Just (is :: [([String],String)]), T.unpack -> j, T.unpack -> i, re -> Just funnames] = Just $ case comm of "eval2" -> Compare2 env funnames s "check" -> Check ext sourcedirs env funnames is i j eval_ _ _ _ _ = Nothing maybeRead :: Read a => String -> Maybe a maybeRead s = listToMaybe [a | (a,"") <- reads s] re :: Read b => T.Text -> Maybe b re = maybeRead . T.unpack