cleanup extension usage
This commit is contained in:
parent
e27755cdda
commit
b493eb67ed
4 changed files with 7 additions and 17 deletions
|
@ -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
|
||||||
|
|
|
@ -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"]
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,3 @@
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
|
||||||
|
|
||||||
module Myriad.Server
|
module Myriad.Server
|
||||||
( app
|
( app
|
||||||
) where
|
) where
|
||||||
|
|
Loading…
Reference in a new issue