feat(forms): Introduce more convenient form validation

ChangeLog.md

@@ -1,3 +1,7 @@
+  * Version 26.06.2019
+  
+    Rudimentäre Unterstützung für Klausurbetrieb
+
   * Version 07.06.2019
 
     Abgaben können bestimmte Dateinamen und Endungen erzwingen

messages/uniworx/de.msg

@@ -1148,4 +1148,6 @@ ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Klausur #{exam} angemeldet
 ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Klausur #{exam} abgemeldet
 ExamRegistered: Angemeldet
 ExamNotRegistered: Nicht angemeldet
-ExamRegistration: Anmeldung
+ExamRegistration: Anmeldung
+
+ExamEndMustBeAfterStart: Beginn der Klausur muss vor ihrem Ende liegen

src/Handler/Exam.hs

@@ -25,6 +25,8 @@ import Text.Blaze.Html.Renderer.String (renderHtml)
 
 import qualified Data.CaseInsensitive as CI
 
+import qualified Control.Monad.State.Class as State
+
 
 getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamListR tid ssh csh = do
@@ -438,6 +440,16 @@ examTemplate cid = runMaybeT $ do
     , efCorrectors       = Set.empty
     }
 
+
+validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m ()
+validateExam = do
+  ExamForm{..} <- State.get
+  
+  guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop (Just efStart)
+
+  -- TODO
+
+
 getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamNewR = postCExamNewR
 postCExamNewR tid ssh csh = do
@@ -446,7 +458,7 @@ postCExamNewR tid ssh csh = do
     template <- examTemplate cid
     return (cid, template)
   
-  ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost $ examForm template
+  ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template
 
   formResult newExamResult $ \ExamForm{..} -> do
     insertRes <- runDBJobs $ do
@@ -525,7 +537,7 @@ postEEditR tid ssh csh examn = do
 
     return (cid, eId, template)
 
-  ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . examForm $ Just template
+  ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
 
   formResult editExamResult $ \ExamForm{..} -> do
     insertRes <- runDBJobs $ do

src/Utils/Form.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
 module Utils.Form where
@@ -23,8 +24,11 @@ import qualified Data.Set as Set
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Reader.Class (MonadReader(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
-import Control.Monad.Trans.RWS (mapRWST)
+import Control.Monad.State.Class (MonadState(..))
+import Control.Monad.Trans.RWS (RWST, execRWST, mapRWST)
 import Control.Monad.Trans.Except (ExceptT, runExceptT)
+import Control.Monad.Fix (MonadFix)
+import Control.Monad.Morph (MFunctor(..))
 
 import Data.List ((!!))
 
@@ -779,6 +783,56 @@ prismAForm p outer form = review p <$> form inner
   where
     inner = outer >>= preview p
 
+newtype FormValidator r m a = FormValidator { unFormValidator :: RWST () [SomeMessage (HandlerSite m)] r m a }
+
+deriving newtype instance Functor m => Functor (FormValidator r m)
+deriving newtype instance Monad m => Applicative (FormValidator r m)
+deriving newtype instance Monad m => Monad (FormValidator r m)
+deriving newtype instance Monad m => MonadState r (FormValidator r m)
+deriving newtype instance MonadFix m => MonadFix (FormValidator r m)
+instance MonadTrans (FormValidator r) where
+  lift = FormValidator . lift
+
+validateForm :: MonadHandler m
+             => FormValidator a m ()
+             -> (Markup -> MForm m (FormResult a, xml))
+             -> (Markup -> MForm m (FormResult a, xml))
+validateForm valF form csrf = do
+  (res, xml) <- form csrf
+  res' <- for res $ lift . execRWST (unFormValidator valF) ()
+  (, xml) <$> case res' of
+    FormSuccess (x, []  ) -> return $ FormSuccess x
+    FormSuccess (_, msgs) -> formFailure msgs
+    FormMissing           -> return FormMissing
+    FormFailure errs      -> return $ FormFailure errs
+
+validateFormDB :: ( MonadHandler m
+                  , YesodPersist (HandlerSite m)
+                  )
+               => FormValidator a (YesodDB (HandlerSite m)) ()
+               -> (Markup -> MForm m (FormResult a, xml))
+               -> (Markup -> MForm m (FormResult a, xml))
+validateFormDB (FormValidator valF) = validateForm . FormValidator $ hoist (liftHandlerT . runDB) valF
+
+tellValidationError :: ( MonadHandler m
+                       , RenderMessage (HandlerSite m) msg
+                       )
+                    => msg -> FormValidator r m ()
+tellValidationError = FormValidator . tell . pure . SomeMessage
+
+guardValidation :: ( MonadHandler m
+                   , RenderMessage (HandlerSite m) msg
+                   )
+                => msg -> Bool -> FormValidator r m ()
+guardValidation _   False = return ()
+guardValidation msg True  = tellValidationError msg
+
+guardValidationM :: ( MonadHandler m
+                    , RenderMessage (HandlerSite m) msg
+                    )
+                 => msg -> m Bool -> FormValidator r m ()
+guardValidationM = (. lift) . (=<<) . guardValidation
+
 -----------------------
 -- Form Manipulation --
 -----------------------