chore(exam): auto name generation for examOccurrences

src/Handler/Exam/Form.hs

@@ -25,12 +25,17 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 import qualified Database.Esqueleto.Legacy as E
--- import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Experimental as Ex
+import qualified Database.Esqueleto.Utils as Ex
 
 import qualified Control.Monad.State.Class as State
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 
+import Text.Pandoc.Shared (toRomanNumeral)
+import qualified Data.Char      as Char
+import qualified Data.Text      as Text
 import qualified Data.Text.Lazy as LT
+import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Conduit.Combinators as C
 
@@ -63,7 +68,7 @@ data ExamForm = ExamForm
 
 data ExamOccurrenceForm = ExamOccurrenceForm
   { eofId :: Maybe CryptoUUIDExamOccurrence
-  , eofName :: ExamOccurrenceName
+  , eofName :: Maybe ExamOccurrenceName
   , eofExaminer :: Maybe UserId
   , eofRoom :: Maybe RoomReference
   , eofRoomHidden :: Bool
@@ -256,7 +261,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
 examOccurrenceForm :: (Text -> Text) -> Maybe ExamOccurrenceForm -> Form ExamOccurrenceForm
 examOccurrenceForm nudge mPrev csrf = do
       (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
-      (eofNameRes, eofNameView) <- mpreq (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev)
+      (eofNameRes, eofNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev)
       (eofExaminerRes, eofExaminerView) <- mopt examinerField (fslI MsgExamStaff & addName (nudge "examiner")) (eofExaminer <$> mPrev) -- TODO: restrict suggestions!
       (eofRoomRes', eofRoomView) <- ($ mempty) . renderAForm FormVertical $ (,)
         <$> roomReferenceFormOpt (fslI MsgExamRoomRoom & addName (nudge "room")) (eofRoom <$> mPrev)
@@ -310,39 +315,92 @@ examOccurrenceMultiForm prev = wFormToAForm $ do
     miIdent' :: Text
     miIdent' = "exam-occurrences"
 
--- upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm) => ExamId -> mono -> DB ()     -- to specific
+-- | generate an exam-unique occurrence name from data
-upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm,
+--   Pattern: <initials-examiner>_<mm-dd>_<room>_<roman_numeral>
-                          PersistStoreWrite backend, MonadHandler m, BaseBackend backend ~ SqlBackend, HandlerSite m ~ UniWorX)
+--   eofName is entirely ignored, assumed to be Nothing
+guessExamOccurrenceName :: forall backend m . (PersistUniqueRead backend, PersistQueryRead backend, MonadHandler m, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend, HandlerSite m ~ UniWorX, MonadThrow m)
+                         => Key Exam -> ExamOccurrenceForm -> ReaderT backend m ExamOccurrenceName
+guessExamOccurrenceName eId ExamOccurrenceForm{..} = do
+    -- oday <- formatTime' "%m-%d" eofStart
+    oday <- formatTime' "%d.%m." eofStart
+    ohour <- ifM hasMoreThanOneHour (formatTime' "at%H"   eofStart) (return mempty)
+    inis <- ifMoreThanOne ExamOccurrenceExaminer $ foldMapM getInitials eofExaminer
+    room <- case eofRoom of
+              Just (RoomReferenceSimple t) -> ifMoreThanOne ExamOccurrenceRoom $ return $ Text.take 4 t   -- Text.cons '-' $ Text.take 4 t
+              _ -> return mempty
+    let pfx  = CI.mk $ inis <> oday <> ohour <> room
+        eons = ocheck pfx : [ ocheck $ pfx <> CI.mk (Text.cons '_' $ toRomanNumeral n) | n <- [2..3999]]
+    fromMaybe "Handler.Exam.Form.guessExamOccurrenceName failed to guess a unique name"
+      <$> firstJustM eons
+  where
+    getInitials uid = get uid <&> foldMap (Text.filter Char.isUpper . userDisplayName) -- flip Text.snoc '_' .
+    ocheck eon = existsBy (UniqueExamOccurrence eId eon) <&> (flip toMaybe eon . not)
+
+    ifMoreThanOne :: (PersistField t, Monoid o) => EntityField ExamOccurrence (Maybe t) -> ReaderT backend m o -> ReaderT backend m o
+    ifMoreThanOne eoprop act = ifM (hasMoreThanOne eoprop) act (return mempty)
+
+    hasMoreThanOne :: PersistField t => EntityField ExamOccurrence (Maybe t) -> ReaderT backend m Bool
+    hasMoreThanOne eoprop = $(memcachedByHere) (Just . Right $ 1 * diffMinute) (eId, tshow $ persistFieldDef eoprop) $ Ex.selectExists $ do
+      exOcc <- Ex.from $ Ex.table @ExamOccurrence
+      Ex.where_ $ (exOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
+          Ex.&&. Ex.isJust (exOcc Ex.^. eoprop)
+          Ex.&&. Ex.exists (do
+            otOcc <- Ex.from $ Ex.table @ExamOccurrence
+            Ex.where_ $ (otOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
+              Ex.&&.  Ex.isJust (otOcc Ex.^. eoprop)
+              Ex.&&.  otOcc Ex.^. eoprop Ex.!=. exOcc Ex.^. eoprop
+          )
+
+    hasMoreThanOneHour :: ReaderT backend m Bool
+    hasMoreThanOneHour = $(memcachedByHere) (Just . Right $ 1 * diffMinute) eId $ Ex.selectExists $ do
+      exOcc <- Ex.from $ Ex.table @ExamOccurrence
+      Ex.where_ $ (exOcc Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
+          Ex.&&. Ex.exists (do
+            other <- Ex.from $ Ex.table @ExamOccurrence
+            Ex.where_ $ (other Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId)
+              Ex.&&. (Ex.day (other Ex.^. ExamOccurrenceStart) Ex.==. Ex.day (exOcc Ex.^. ExamOccurrenceStart))
+              Ex.&&. (        other Ex.^. ExamOccurrenceStart  Ex.!=.         exOcc Ex.^. ExamOccurrenceStart)
+          )
+
+
+-- upsertExamOccurrences :: (MonoFoldable mono, Element mono ~ ExamOccurrenceForm) => ExamId -> mono -> DB ()     -- too specific
+upsertExamOccurrences :: ( MonoFoldable mono, Element mono ~ ExamOccurrenceForm, HandlerSite m ~ UniWorX, MonadHandler m, MonadThrow m
+                         , PersistQueryRead backend, PersistUniqueRead backend, PersistStoreWrite backend
+                         , BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend)
   => Key Exam -> mono -> ReaderT backend m ()
 upsertExamOccurrences eId = mapM_ $ \case
-  ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
+    eof@ExamOccurrenceForm{ eofId = Nothing, eofName = eofNameMb, .. } -> do
-    ExamOccurrence
+      eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb)
-      { examOccurrenceExam = eId
+      $logInfoS "ExamOccurrenceForm" [st|New Exam Occurrence: #{eofName}|]
-      , examOccurrenceName = eofName
+      insert_ ExamOccurrence
-      , examOccurrenceExaminer = eofExaminer
+          { examOccurrenceExam = eId
-      , examOccurrenceRoom = eofRoom
+          , examOccurrenceName = eofName
-      , examOccurrenceRoomHidden = eofRoomHidden
+          , examOccurrenceExaminer = eofExaminer
-      , examOccurrenceCapacity = eofCapacity
+          , examOccurrenceRoom = eofRoom
-      , examOccurrenceStart = eofStart
+          , examOccurrenceRoomHidden = eofRoomHidden
-      , examOccurrenceEnd = eofEnd
+          , examOccurrenceCapacity = eofCapacity
-      , examOccurrenceDescription = eofDescription
+          , examOccurrenceStart = eofStart
-      }
+          , examOccurrenceEnd = eofEnd
-  ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
+          , examOccurrenceDescription = eofDescription
-    cID <- hoistMaybe eofId
+          }
-    eofId' <- decrypt cID
+    eof@ExamOccurrenceForm{eofName = eofNameMb, .. } -> void . runMaybeT $ do
-    oldOcc <- MaybeT $ get eofId'
+      cID <- hoistMaybe eofId
-    guard $ examOccurrenceExam oldOcc == eId
+      eofId' <- decrypt cID
-    lift $ replace eofId' ExamOccurrence
+      oldOcc <- MaybeT $ get eofId'
-      { examOccurrenceExam = eId
+      guard $ examOccurrenceExam oldOcc == eId
-      , examOccurrenceName = eofName
+      lift $ do
-      , examOccurrenceExaminer = eofExaminer
+        eofName <- fromMaybeM (guessExamOccurrenceName eId eof) (pure eofNameMb)
-      , examOccurrenceRoom = eofRoom
+        replace eofId' ExamOccurrence
-      , examOccurrenceRoomHidden = eofRoomHidden
+          { examOccurrenceExam = eId
-      , examOccurrenceCapacity = eofCapacity
+          , examOccurrenceName = eofName
-      , examOccurrenceStart = eofStart
+          , examOccurrenceExaminer = eofExaminer
-      , examOccurrenceEnd = eofEnd
+          , examOccurrenceRoom = eofRoom
-      , examOccurrenceDescription = eofDescription
+          , examOccurrenceRoomHidden = eofRoomHidden
-      }
+          , examOccurrenceCapacity = eofCapacity
+          , examOccurrenceStart = eofStart
+          , examOccurrenceEnd = eofEnd
+          , examOccurrenceDescription = eofDescription
+          }
 
 examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
 examPartsForm prev = wFormToAForm $ do
@@ -420,7 +478,7 @@ examFormTemplate (Entity eId Exam{..}) = do
         (Just -> eofId, ExamOccurrence{..}) <- occurrences'
         return ExamOccurrenceForm
           { eofId
-          , eofName        = examOccurrenceName
+          , eofName        = examOccurrenceName & Just
           , eofExaminer    = examOccurrenceExaminer
           , eofRoom        = examOccurrenceRoom
           , eofRoomHidden  = examOccurrenceRoomHidden
@@ -524,10 +582,10 @@ validateExam cId oldExam = do
   guardValidation MsgExamPartsFromMustBeBeforeFinished                     $ NTop efFinished                     >= NTop efPartsFrom
                                                                           || is _Nothing efPartsFrom
 
-  forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
+  forM_ efOccurrences $ \ExamOccurrenceForm{eofName=fold->eofName, ..} -> do
-    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)
+    guardValidation (MsgExamOccurrenceEndMustBeAfterStart       eofName) $ NTop eofEnd >= NTop (Just eofStart)
     guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
-    warnValidation  (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName)    $ NTop eofEnd <= NTop efEnd
+    warnValidation  (MsgExamOccurrenceEndMustBeBeforeExamEnd    eofName) $ NTop eofEnd <= NTop efEnd
 
   forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
     eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)
@@ -540,7 +598,7 @@ validateExam cId oldExam = do
       , (/=) `on` fmap (LT.strip . renderHtml . markupOutput) . eofDescription
       ]
 
-    guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b
+    guardValidation (MsgExamOccurrenceDuplicateName $ fold $ eofName a) $ ((/=) `on` eofName) a b
 
   oldOccurrencesWithRegistrations <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examOccurrence -> do
     E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId

src/Handler/Exam/New.hs

@@ -70,19 +70,7 @@ postCExamNewR tid ssh csh = do
                 examPartWeight    = epfWeight
           ]
 
-        insertMany_
+        upsertExamOccurrences examid efOccurrences
-          [ ExamOccurrence{..}
-          | ExamOccurrenceForm{..} <- Set.toList efOccurrences
-          , let examOccurrenceExam        = examid
-                examOccurrenceName        = eofName
-                examOccurrenceExaminer    = eofExaminer
-                examOccurrenceRoom        = eofRoom
-                examOccurrenceRoomHidden  = eofRoomHidden
-                examOccurrenceCapacity    = eofCapacity
-                examOccurrenceStart       = eofStart
-                examOccurrenceEnd         = eofEnd
-                examOccurrenceDescription = eofDescription
-          ]
 
         insertMany_ [ ExamOfficeSchool ssh' examid | ssh' <- Set.toList efOfficeSchools ]
 

src/Handler/Tutorial/Users.hs

@@ -57,7 +57,7 @@ mkExamOccurrenceForm exs eom = renderAForm FormStandard maa
           <*> apreq hiddenField "" (Just cueId)
           <*> apreq (mkSetField hiddenField) "" cuEoIds
           <*  aformInfoWidget ewgt
-          <*> examOccurrenceMultiForm eos
+          <*> examOccurrenceMultiForm eos -- TODO filter occurrences to cuEoIds
       )
 
 data TutorialUserAction

src/Handler/Utils/Course/Cache.hs

@@ -176,7 +176,7 @@ convertExamOccurrenceMap eom = Map.fromListWith (<>) $ map aux $ Map.toList eom
     aux :: (ExamOccurrenceId, (ExamOccurrence, CryptoUUIDExamOccurrence, (ExamId, ExamName))) -> (ExamId, (Set CryptoUUIDExamOccurrence, Set ExamOccurrenceForm))
     aux (_, (ExamOccurrence{..}, cueoId, (eid,_))) = (eid, (Set.singleton cueoId, Set.singleton ExamOccurrenceForm
             { eofId          = Just cueoId
-            , eofName        = examOccurrenceName
+            , eofName        = Just examOccurrenceName
             , eofExaminer    = examOccurrenceExaminer
             , eofRoom        = examOccurrenceRoom
             , eofRoomHidden  = examOccurrenceRoomHidden

src/Utils.hs

@@ -1020,7 +1020,7 @@ positiveSum = maybePositive . getSum
 maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
 maybeM dft act mb = mb >>= maybe dft act
 
--- maybeEmptyM, maybeNotingM
+-- maybeEmptyM, maybeNothingM
 traverseJoin :: (Applicative m, Traversable maybe, Monad maybe) => (a -> m (maybe b)) -> maybe a -> m (maybe b)
 traverseJoin f x = join <$> (f `traverse` x)
 
@@ -1150,12 +1150,6 @@ firstJustM  = Fold.foldr go (return Nothing)
     go :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
     go n p = n >>= \case {Nothing -> p; res -> return res}
 
--- firstJustM1  :: (Monad m, MonoFoldable mono, Element mono ~ m (Maybe a)) =>  mono -> m (Maybe a)
--- firstJustM1  = foldr go (return Nothing)
---   where
---     go n p = n >>= \case {Nothing -> p; res -> return res}
-
-
 -- | Run the maybe computation repeatedly until the first Just is returned
 --   or the number of maximum retries is exhausted.
 --   So like Control.Monad.Loops.untilJust, but with a maximum number of attempts.