Manage a farm of virtual machines for students
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

Event.hs 4.7KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121
  1. {-# LANGUAGE OverloadedStrings #-}
  2. {-
  3. This file is part of the package merkel. It is subject to the license
  4. terms in the LICENSE file found in the top-level directory of this
  5. distribution and at:
  6. git://git.devalot.com/merkel.git
  7. No part of this package, including this file, may be copied, modified,
  8. propagated, or distributed except according to the terms contained in
  9. the LICENSE file.
  10. -}
  11. --------------------------------------------------------------------------------
  12. module Merkel.Operations.Term.Event
  13. ( replay
  14. ) where
  15. --------------------------------------------------------------------------------
  16. import Control.Monad.IO.Class (MonadIO)
  17. import Control.Monad.Trans.Maybe
  18. import Data.Maybe (listToMaybe, catMaybes)
  19. import Data.Text (Text)
  20. import Data.Time
  21. import Database.Groundhog.Core
  22. import Database.Groundhog.Generic
  23. --------------------------------------------------------------------------------
  24. import Merkel.Types
  25. import Merkel.Types.API.Term.Event
  26. import qualified Merkel.Util.Database.Term as Term
  27. import Merkel.Util.Groundhog
  28. --------------------------------------------------------------------------------
  29. -- | Fetch all events so far.
  30. replay :: (MonadIO m) => Text -> MerkelT EmptyResponse m [TermEvent]
  31. replay code = exceptDB EmptyResponse $ do
  32. term <- Term.byCode code
  33. let cutoff = termStart (recordVal term)
  34. es <- enrollmentsAfter (recordKey term) cutoff
  35. vs <- vmEventsAfter (recordKey term) cutoff
  36. tes <- mapM (termEnrolled $ recordKey term) es
  37. tves <- catMaybes <$> mapM termVMEvent vs
  38. return (tes ++ tves)
  39. where
  40. -- | Turn query results into @TermEvent@.
  41. termEnrolled :: AutoKey Term
  42. -> (Enrollment, Student)
  43. -> Query TermEvent
  44. termEnrolled term (e, s) = do
  45. let studentKey = enrollmentStudent e
  46. vms <- select' ( VmTermField ==. term &&.
  47. VmAssignedStudentField ==. Just studentKey )
  48. let vmname = vmName <$> listToMaybe vms
  49. return $ TermEnrolled (keyToInt studentKey) (studentName s) vmname
  50. -- | Turn query results into @TermEvent@.
  51. termVMEvent :: (VirtualMachineEventLog, VirtualMachine)
  52. -> Query (Maybe TermEvent)
  53. termVMEvent (vme, vm) =
  54. case vmAssignedStudent vm of
  55. Nothing -> return Nothing
  56. Just k -> return (Just $ TermVMEvent (keyToInt k) (vmName vm) (vmeEvent vme))
  57. --------------------------------------------------------------------------------
  58. -- | Fetch all enrollments that occurred after the given time.
  59. enrollmentsAfter :: DefaultKey Term
  60. -> UTCTime
  61. -> Query [(Enrollment, Student)]
  62. enrollmentsAfter key cutoff =
  63. MaybeT (Just <$> (queryRaw False sql [ toPrimitivePersistValue key
  64. , toPrimitivePersistValue cutoff
  65. ] >>= streamToList >>= mapM decode))
  66. where
  67. decode = fmap fst . projectionResult ( EnrollmentConstructor
  68. , StudentConstructor
  69. )
  70. sql = "SELECT enrollment_term, enrollment_student, enrollment_time, \
  71. \ student_created_at, student_name, student_email, student_account \
  72. \ FROM enrollment, student \
  73. \ WHERE enrollment.enrollment_student = student.id \
  74. \ AND enrollment.enrollment_term = ? \
  75. \ AND enrollment.enrollment_time >= ? \
  76. \ ORDER BY enrollment_time DESC"
  77. --------------------------------------------------------------------------------
  78. vmEventsAfter :: DefaultKey Term
  79. -> UTCTime
  80. -> Query [(VirtualMachineEventLog, VirtualMachine)]
  81. vmEventsAfter key cutoff =
  82. MaybeT (Just <$> (queryRaw False sql [ toPrimitivePersistValue key
  83. , toPrimitivePersistValue cutoff
  84. ] >>= streamToList >>= mapM decode))
  85. where
  86. decode = fmap fst . projectionResult
  87. ( VirtualMachineEventLogConstructor
  88. , VirtualMachineConstructor
  89. )
  90. sql = "SELECT DISTINCT ON (vme_event, vme_machine) \
  91. \ vme_machine, vme_time, vme_event, \
  92. \ vm_name, vm_term, vm_assigned_student, vm_address, \
  93. \ vm_available, \"vm_root_password#clear\", \"vm_root_password#hashed\", \
  94. \ \"vm_student_password#clear\", \"vm_student_password#hashed\", vm_access_token \
  95. \ FROM virtual_machine_event_log, virtual_machine \
  96. \ WHERE vme_machine = virtual_machine.id \
  97. \ AND virtual_machine.vm_assigned_student IS NOT NULL \
  98. \ AND virtual_machine.vm_term = ? \
  99. \ AND vme_time >= ? \
  100. \ ORDER BY vme_event, vme_machine, vme_time DESC"