{-# LANGUAGE OverloadedStrings, ViewPatterns, NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, PatternGuards, NamedFieldPuns #-} module Main where import Smart 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 Control.Concurrent (threadDelay) import Control.Monad (when) import Control.Applicative ((<|>)) import System.Locale (defaultTimeLocale) import Data.Time (getCurrentTime, formatTime, diffUTCTime) import Data.Maybe (listToMaybe) --import Prelude hiding (catch) --------------------------------------------------------------- main :: IO () main = getArgs >>= mainWithArgs mainWithArgs :: Args -> IO () mainWithArgs args@(Args {verbose, port, static, logdir, hoogledb, fileservedir, gendir, mainpage, restartpath, sourcedir, includedir}) = do ti <- getCurrentTime log <- newLogger verbose $ logdir "interpreter_" ++ formatTime defaultTimeLocale "%Y-%m-%d-%H-%M-%S" ti ++ ".log" -- "%Y-%m-%d-%H:%M:%S" is not ok, colons are not supported in filenames under windows ch <- startGHCiServer [sourcedir] log hoogledb cache <- newCache 10 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 ) 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 renderResults $ 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 = reverse $ takeWhile (/='.') $ reverse fn True <- liftIO $ doesFileExist fn 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 <|> return [Error True $ translate lang "Inconsistency between server and client."] 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 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