Browse Source

Allow outside control of the deploy parallel limit

  * The deploy and transfer commands now have a `--limit' option

  * Added some notes to the TODO.org file
master
Peter J. Jones 2 years ago
parent
commit
93098f5719
Signed by: Peter Jones <pjones@devalot.com> GPG Key ID: 9DAFAA8D01941E49
3 changed files with 38 additions and 24 deletions
  1. 2
    1
      docs/TODO.org
  2. 10
    11
      lib/Merkel/Util/NixOps/Process.hs
  3. 26
    12
      src/Merkel/UI/VM.hs

+ 2
- 1
docs/TODO.org View File

@@ -3,7 +3,8 @@
#+EMAIL: pjones@devalot.com
#+STARTUP: content

* Bugs [2/7]
* Bugs [2/8]
** TODO The Secure Coding VM Needs More Disk Space
** TODO The term dashboard should show the name of the course
** TODO Space Leak on Each Snap Request
** TODO Remove Brittle SQL Used for Joins

+ 10
- 11
lib/Merkel/Util/NixOps/Process.hs View File

@@ -403,30 +403,28 @@ create term course = do

--------------------------------------------------------------------------------
-- | Deploy all resources and machines.
deploy :: (MonadIO m) => NixOps -> IncludedVMs -> Merkel m ()
deploy nixops vms = do
let limit = 1 -- FIXME: this should be a config option.

deploy :: (MonadIO m) => NixOps -> IncludedVMs -> Int -> Merkel m ()
deploy nixops vms limit = do
let name = nixopsDeploymentName nixops

resources <- info nixops
let names = map resourceName resources

logInfo "deploying nixops resources"
go name limit [ x | ResourceNonMachine x <- names]
go name [ x | ResourceNonMachine x <- names]

logInfo "deploying nixops machines"
let machines = case vms of
AllMachines -> [ x | ResourceMachine x <- names]
NamedMachines ns -> ns
go name limit machines
go name machines

logInfo "updating the database from NixOps"
updateDB nixops vms

where
go :: (MonadIO m) => Text -> Int -> [Text] -> Merkel m ()
go name limit names =
go :: (MonadIO m) => Text -> [Text] -> Merkel m ()
go name names =
forM_ (chunksOf limit names) $ \ns ->
run_ "deploy" (Just name) (args ns)

@@ -520,11 +518,12 @@ disable nixops vms disposition =
-- | Transfer machines from one 'Term' to another. This will cause a
-- deployment and virtual machine reset.
transfer :: (MonadIO m)
=> (Record Term, Record Course)
=> Int
-> (Record Term, Record Course)
-> (Record Term, Record Course)
-> Merkel m ()

transfer (t1, c1) (t2, c2) = do
transfer limit (t1, c1) (t2, c2) = do
when (recordKey t1 == recordKey t2) $
die "when transferring machines the source and \
\destination terms must be different"
@@ -541,5 +540,5 @@ transfer (t1, c1) (t2, c2) = do

removeFiles g1
disable g1 AllMachines KeepStudent
deploy g2 AllMachines
deploy g2 AllMachines limit
reset g2 AllMachines

+ 26
- 12
src/Merkel/UI/VM.hs View File

@@ -35,12 +35,12 @@ import Merkel.Util.Groundhog
import qualified Merkel.Util.NixOps as NixOps

--------------------------------------------------------------------------------
data Command = CmdDeploy NixOps.IncludedVMs
data Command = CmdDeploy Int NixOps.IncludedVMs
| CmdStart NixOps.IncludedVMs
| CmdStop NixOps.IncludedVMs
| CmdReset NixOps.IncludedVMs
| CmdDisable NixOps.IncludedVMs NixOps.AssignmentDisposition Bool
| CmdTransfer String
| CmdTransfer Int String
| CmdDelete

--------------------------------------------------------------------------------
@@ -75,7 +75,7 @@ optionsParser =
(info (parser <**> helper) (progDesc desc))

deployCmd =
mkCmd "deploy" (CmdDeploy <$> parseMachineNames)
mkCmd "deploy" (CmdDeploy <$> parseLimit 1 <*> parseMachineNames)
"Deploy NixOps resources, creating them if necessary"

startCmd =
@@ -95,7 +95,9 @@ optionsParser =
"Disable NixOps resources"

transferCmd =
mkCmd "transfer" (CmdTransfer <$> argument str (metavar "CODE"))
mkCmd "transfer" (CmdTransfer
<$> parseLimit 1
<*> argument str (metavar "CODE"))
"Transfer machines from one term to another"

deleteCmd =
@@ -119,6 +121,16 @@ optionsParser =
, help "Preserve the student assignments"
])

parseLimit :: Int -> Parser Int
parseLimit defaultLimit =
option auto $
mconcat [ long "limit"
, value defaultLimit
, showDefault
, metavar "NUM"
, help "Limit to NUM machines at a time"
]

parseDisable :: Parser Command
parseDisable =
CmdDisable
@@ -131,13 +143,14 @@ optionsParser =

--------------------------------------------------------------------------------
runDeploy :: (MonadIO m)
=> NixOps.IncludedVMs
=> Int
-> NixOps.IncludedVMs
-> Record Term
-> Record Course
-> Merkel m ()
runDeploy vms term course = do
runDeploy limit vms term course = do
nixops <- NixOps.create term course
NixOps.deploy nixops vms
NixOps.deploy nixops vms limit

--------------------------------------------------------------------------------
runStart :: (MonadIO m)
@@ -184,15 +197,16 @@ runDisable vms keep stop term course = do

--------------------------------------------------------------------------------
runTransfer :: (MonadIO m)
=> String
=> Int
-> String
-> Record Term
-> Record Course
-> Merkel m ()
runTransfer code t1 c1 = do
runTransfer limit code t1 c1 = do
dest <- exceptDB "can't find destination term"
(Term.forNixOps $ Text.pack code)

NixOps.transfer (t1, c1) dest
NixOps.transfer limit (t1, c1) dest

--------------------------------------------------------------------------------
runDelete :: (MonadIO m)
@@ -208,10 +222,10 @@ run Options{..} = do
(term, course) <- exceptDB "failed to load term" (Term.forNixOps code)

case optionCommand of
CmdDeploy vms -> runDeploy vms term course
CmdDeploy limit vms -> runDeploy limit vms term course
CmdStart vms -> runStart vms term course
CmdStop vms -> runStop vms term course
CmdReset vms -> runReset vms term course
CmdDisable vms keep stop -> runDisable vms keep stop term course
CmdTransfer code2 -> runTransfer code2 term course
CmdTransfer limit code2 -> runTransfer limit code2 term course
CmdDelete -> runDelete term course

Loading…
Cancel
Save