chore(exam): add convenience function to duplicate exam occurrences to another day

src/CryptoID.hs

@@ -121,7 +121,7 @@ instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "PrintJob" (CI FilePath)) where
 
 
 -- instance PathPiece a => PathPiece [a] where
---   toPathPiece   = textBracket '[' ']' . Text.intercalate "," . map toPathPiece
+--   toPathPiece    = textBracket '[' ']' . Text.intercalate "," . map toPathPiece
 --   fromPathPiece (textUnbracket '[' ']' . Text.strip -> Just t)
 --     | null t      = Just []
 --     | otherwise   = mapM fromPathPiece $ Text.split (==',') t

src/Handler/Exam/Form.hs

@@ -8,7 +8,7 @@ module Handler.Exam.Form
   , ExamPartForm(..)
   , examForm
   , examOccurrenceMultiForm, examOccurrenceForm
-  , upsertExamOccurrences
+  , upsertExamOccurrences, copyExamOccurrences
   , examFormTemplate, examTemplate
   , validateExam
   ) where
@@ -315,10 +315,48 @@ examOccurrenceMultiForm prev = wFormToAForm $ do
     miIdent' :: Text
     miIdent' = "exam-occurrences"
 
+
+examOccurrenceTemplate :: ExamOccurrence -> ExamOccurrenceForm
+examOccurrenceTemplate ExamOccurrence{..} = ExamOccurrenceForm{..}
+  where
+    eofId           = Nothing
+    eofName         = Just examOccurrenceName
+    eofExaminer     = examOccurrenceExaminer
+    eofRoom         = examOccurrenceRoom
+    eofRoomHidden   = examOccurrenceRoomHidden
+    eofCapacity     = examOccurrenceCapacity
+    eofStart        = examOccurrenceStart
+    eofEnd          = examOccurrenceEnd
+    eofDescription  = examOccurrenceDescription
+
+-- | copy all exam occurrences of an exam, that start on a specified day, to another day, preserving everything else
+--   if the occurrence name contains the day it is replaced, otherwise guessExamOccurrenceName is invoked
+copyExamOccurrences :: forall backend m . (PersistUniqueRead backend, PersistQueryRead backend
+                                        , PersistUniqueWrite backend,  BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend
+                                        , MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX)
+                         => Key Exam -> Day -> Day -> ReaderT backend m Int
+copyExamOccurrences eId dfrom dto = do
+  let dfts = ["%d.%m.%Y", "%d.%m.%y", "%Y-%m-%d", "%y-%m-%d", "%d.%m", "%d-%m", "%m-%d"]
+      fts fs = (,) <$> formatTime' fs dfrom <*> formatTime' fs dto
+      shiftDay :: Day -> Day = addDays $ diffDays dto dfrom
+  drepl <- mapM fts dfts
+  exOccs <- Ex.select $ do
+    occ <- Ex.from $ Ex.table @ExamOccurrence
+    Ex.where_ $ occ Ex.^. ExamOccurrenceExam Ex.==. Ex.val eId
+        Ex.&&. Ex.day (occ Ex.^. ExamOccurrenceStart) Ex.==. Ex.val dfrom
+    return occ
+  res <- forM exOccs $ \Entity{entityVal=eo@ExamOccurrence{examOccurrenceName=oldName}} -> do
+    let eo' = _examOccurrenceStart       . _utctDay %~ shiftDay $
+              _examOccurrenceEnd . _Just . _utctDay %~ shiftDay $ eo
+    newName <- maybeM (guessExamOccurrenceName eId $ examOccurrenceTemplate eo') return $ return (fmap CI.mk $ textReplaceFirst drepl $ CI.original oldName)
+    insertUnique_ (eo'{examOccurrenceName=newName})
+  return $ length $ catMaybes res
+
 -- | generate an exam-unique occurrence name from data
 --   Pattern: <initials-examiner>_<mm-dd>_<room>_<roman_numeral>
 --   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)
+guessExamOccurrenceName :: forall backend m . (PersistUniqueRead backend, PersistQueryRead backend, BaseBackend backend ~ SqlBackend, BackendCompatible SqlBackend backend
+                                              , MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX)
                          => Key Exam -> ExamOccurrenceForm -> ReaderT backend m ExamOccurrenceName
 guessExamOccurrenceName eId ExamOccurrenceForm{..} = do
     -- oday <- formatTime' "%m-%d" eofStart

src/Handler/Utils/DateTime.hs

@@ -97,6 +97,10 @@ toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeO
 addHours :: Integral n => n -> UTCTime -> UTCTime
 addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600)
 
+-- Use  _utctDay %~ addDays n instead!
+-- addDaysSimple :: Integer -> UTCTime -> UTCTime
+-- addDaysSimple n t = t { utctDay = addDays n (utctDay t) }
+
 instance HasLocalTime UTCTime where
   toLocalTime = utcToLocalTime
 

src/Utils.hs

@@ -376,6 +376,15 @@ text2asciiAlphaNum = text2AlphaNumPlus ['-','_']
   . Text.replace "ğ" "g"
   . Text.replace "ñ" "n"
 
+-- | Attempt to replace several possible needles in a Text, returning the first successfull replacement.
+textReplaceFirst :: [(Text,Text)] -> Text -> Maybe Text
+textReplaceFirst frags told = firstJust attemptRepl frags
+  where
+    attemptRepl (frold,frnew) =
+      let tnew = Text.replace frold frnew told
+      in  if tnew == told then Nothing else Just tnew
+
+
 -- | Convert text as it is to Html, may prevent ambiguous types
 -- This function definition is mainly for documentation purposes
 text2Html :: Text -> Html