cleanup extension usage

This commit is contained in:
1computer1 2020-06-16 22:42:29 -04:00
parent e27755cdda
commit b493eb67ed
4 changed files with 7 additions and 17 deletions

View file

@ -23,33 +23,25 @@ source-repository head
common shared common shared
default-language: Haskell2010 default-language: Haskell2010
default-extensions: default-extensions:
BlockArguments
ConstraintKinds ConstraintKinds
DataKinds DataKinds
DeriveAnyClass DeriveAnyClass
DeriveGeneric DeriveGeneric
DeriveTraversable
DerivingStrategies DerivingStrategies
FlexibleContexts FlexibleContexts
FlexibleInstances FlexibleInstances
FunctionalDependencies FunctionalDependencies
GADTs
GeneralizedNewtypeDeriving GeneralizedNewtypeDeriving
KindSignatures
LambdaCase LambdaCase
MultiParamTypeClasses MultiParamTypeClasses
MultiWayIf MultiWayIf
NamedFieldPuns NamedFieldPuns
OverloadedStrings OverloadedStrings
PatternSynonyms PatternSynonyms
PolyKinds
RankNTypes
ScopedTypeVariables
TupleSections TupleSections
TypeApplications TypeApplications
TypeFamilies TypeFamilies
TypeOperators TypeOperators
ViewPatterns
build-depends: build-depends:
aeson aeson
, async , async

View file

@ -16,7 +16,7 @@ import Myriad.Server
runMyriadServer :: FilePath -> FilePath -> IO () runMyriadServer :: FilePath -> FilePath -> IO ()
runMyriadServer configPath languagesDir = do runMyriadServer configPath languagesDir = do
env <- initEnv configPath languagesDir env <- initEnv configPath languagesDir
runMyriadT env do runMyriadT env $ do
buildAllImages buildAllImages
startCleanup startCleanup
logInfo ["Finished Docker-related setup"] logInfo ["Finished Docker-related setup"]

View file

@ -62,12 +62,12 @@ buildAllImages = do
startCleanup :: Myriad () startCleanup :: Myriad ()
startCleanup = do startCleanup = do
Config { cleanupInterval } <- asks config Config { cleanupInterval } <- asks config
when_ (cleanupInterval > 0) do when_ (cleanupInterval > 0) $ do
let t = fromIntegral cleanupInterval * 60000000 let t = fromIntegral cleanupInterval * 60000000
fork $ timer t fork $ timer t
where where
timer :: Int -> Myriad () timer :: Int -> Myriad ()
timer t = forever do timer t = forever $ do
threadDelay t threadDelay t
n <- killContainers n <- killContainers
logInfo ["Cleaned up ", cs $ show n, " containers"] logInfo ["Cleaned up ", cs $ show n, " containers"]
@ -133,11 +133,11 @@ killContainer lang = do
killContainers :: Myriad [ContainerName] killContainers :: Myriad [ContainerName]
killContainers = do killContainers = do
containers <- asks containers >>= readMVar containers <- asks containers >>= readMVar
xs <- forConcurrently (M.toList containers) \(k, v) -> (v,) <$> killContainer k xs <- forConcurrently (M.toList containers) $ \(k, v) -> (v,) <$> killContainer k
pure . map fst $ filter snd xs pure . map fst $ filter snd xs
evalCode :: Language -> Int -> String -> Myriad EvalResult evalCode :: Language -> Int -> String -> Myriad EvalResult
evalCode lang@Language { name, timeout, retries } numRetries code = withContainer \cnt -> do evalCode lang@Language { name, timeout, retries } numRetries code = withContainer $ \cnt -> do
doneRef <- newMVar False -- For keeping track of if the evaluation is done, i.e. succeeded or timed out. doneRef <- newMVar False -- For keeping track of if the evaluation is done, i.e. succeeded or timed out.
void . fork $ timer doneRef -- `race` could not have been used here since some evals can't be cancelled. void . fork $ timer doneRef -- `race` could not have been used here since some evals can't be cancelled.
snowflakeGen <- asks snowflakeGen snowflakeGen <- asks snowflakeGen
@ -171,7 +171,7 @@ evalCode lang@Language { name, timeout, retries } numRetries code = withContaine
Env { containerSems, evalSems } <- ask Env { containerSems, evalSems } <- ask
csem <- (M.! name) <$> readMVar containerSems csem <- (M.! name) <$> readMVar containerSems
esem <- (M.! name) <$> readMVar evalSems esem <- (M.! name) <$> readMVar evalSems
bracket_ (waitQSem esem) (signalQSem esem) do bracket_ (waitQSem esem) (signalQSem esem) $ do
cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang cnt <- bracket_ (waitQSem csem) (signalQSem csem) $ setupContainer lang
f cnt f cnt
@ -179,7 +179,7 @@ evalCode lang@Language { name, timeout, retries } numRetries code = withContaine
timer doneRef = do timer doneRef = do
threadDelay $ fromIntegral timeout * 1000000 threadDelay $ fromIntegral timeout * 1000000
done <- readMVar doneRef done <- readMVar doneRef
unless_ done do unless_ done $ do
writeMVar doneRef True writeMVar doneRef True
killContainer name killContainer name

View file

@ -1,5 +1,3 @@
{-# LANGUAGE DeriveAnyClass #-}
module Myriad.Server module Myriad.Server
( app ( app
) where ) where