Merge branch 'master' into 'live'

Master

See merge request !92

.vscode/tasks.json

@@ -28,8 +28,20 @@
         "focus": false,
         "panel": "dedicated",
         "showReuseMessage": false
-      },
-      "problemMatcher": []
+      }      
+    },
+    {
+      "label": "test",
+      "type": "shell",
+      "command": "./test.sh",
+      "group": "test",
+      "presentation": {
+        "echo": true,
+        "reveal": "always",
+        "focus": true,
+        "panel": "dedicated",
+        "showReuseMessage": false
+      }
     }
   ]
 }

ChangeLog.md

@@ -1,3 +1,10 @@
+  * Version 09.11.2018
+
+    Bugfix: Zahlreiche Knöpfe/Formulare funktionieren wieder bei eingeschaltetem Javascript
+
+    Verschiedene Verbesserungen für Korrektoren
+
+
   * Version 19.10.2018
 
     Benutzer können sich in der Testphase komplett selbst löschen

messages/uniworx/de.msg

@@ -274,6 +274,16 @@ RatingUpdated: Korrektur gespeichert
 RatingDeleted: Korrektur zurückgesetzt
 RatingFilesUpdated: Korrigierte Dateien überschrieben
 
+RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc}
+RatingMissingSeparator: Could not split rating header from comments
+RatingMultiple: Encountered multiple point values in rating
+RatingInvalid parseErr@String: Failed to parse rating point value #{parseErr}
+RatingFileIsDirectory: We do not expect this to, it's included for totality
+RatingNegative: Rating points must be non-negative
+RatingExceedsMax: Rating point must not exceed maximum points
+RatingNotExpected: Rating not expected
+RatingBinaryExpected: Rating must be 0 or 1
+
 NoTableContent: Kein Tabelleninhalt
 NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
 

src/Foundation.hs

@@ -220,14 +220,16 @@ embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>)
 embedRenderMessage ''UniWorX ''StudyFieldType id
 embedRenderMessage ''UniWorX ''SheetFileType id
 embedRenderMessage ''UniWorX ''CorrectorState id
+embedRenderMessage ''UniWorX ''RatingException id
 embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
-embedRenderMessage ''UniWorX ''SheetType ("SheetType" <>)
 
-newtype SheetTypeComplete = SheetTypeComplete SheetType 
-instance RenderMessage UniWorX (SheetTypeComplete) where
-  renderMessage foundation ls (SheetTypeComplete sheetType) = case sheetType of
-      NotGraded -> mr NotGraded
-      other -> mr (grading other) <> ", " <> mr other
+newtype SheetTypeHeader = SheetTypeHeader SheetType
+embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
+
+instance RenderMessage UniWorX (SheetType) where
+  renderMessage foundation ls sheetType = case sheetType of
+      NotGraded -> mr $ SheetTypeHeader NotGraded
+      other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
     where 
       mr :: RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls

src/Handler/Corrections.hs

@@ -500,26 +500,31 @@ postCorrectionR tid ssh csh shn cid = do
       case corrResult of
         FormMissing -> return ()
         FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
-        FormSuccess (rated, ratingPoints', ratingComment') -> do
-          runDBJobs $ do
-            uid <- liftHandlerT requireAuthId
-            now <- liftIO getCurrentTime
-          
-            update sub [ SubmissionRatingBy      =. (uid <$ guard rated)
--- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
---                        , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes?
-                       , SubmissionRatingTime    =. (now <$ guard rated)
-                       , SubmissionRatingPoints  =. ratingPoints'
-                       , SubmissionRatingComment =. ratingComment'
-                       ]
+        FormSuccess (rated, ratingPoints', ratingComment') 
+          | errs <- validateRating sheetType Rating'
+                      { ratingPoints=ratingPoints'
+                      , ratingComment=ratingComment'
+                      , ratingTime=Nothing
+                      }
+            -> mapM_ (addMessageI Error) errs
+          | otherwise -> do
+            runDBJobs $ do
+              uid <- liftHandlerT requireAuthId
+              now <- liftIO getCurrentTime
+            
+              update sub  [ SubmissionRatingBy      =. Just uid
+                          , SubmissionRatingTime    =. (now <$ guard rated)
+                          , SubmissionRatingPoints  =. ratingPoints'
+                          , SubmissionRatingComment =. ratingComment'
+                          ]
 
-            addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
+              addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
 
-            when (rated && isNothing submissionRatingTime) $ do
-              $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
-              queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub 
+              when (rated && isNothing submissionRatingTime) $ do
+                $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
+                queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub 
 
-          redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
+            redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       case uploadResult of
         FormMissing -> return ()

src/Handler/Home.hs

@@ -245,7 +245,7 @@ instance RenderMessage UniWorX HelpIdentOptions where
 
 data HelpForm = HelpForm
   { hfReferer:: Maybe Text
-  , hfUserId :: Either (Maybe Email) UserId
+  , hfUserId :: Either (Maybe Address) UserId
   , hfRequest:: Text
   }
 
@@ -256,13 +256,13 @@ helpForm mReferer mUid = HelpForm
     <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
     <*  submitButton
   where
-    identActions :: Map _ (AForm _ (Either (Maybe Email) UserId))
+    identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
     identActions = Map.fromList $ case mUid of 
       (Just uid) -> (HIUser, pure $ Right uid):defaultActions
       Nothing    -> defaultActions 
     
     defaultActions =
-      [ (HIEmail, Left . Just <$> apreq emailField (fslI MsgEMail) Nothing)
+      [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing))
       , (HIAnonymous, pure $ Left Nothing)
       ]
 

src/Handler/Sheet.hs

@@ -162,7 +162,7 @@ getSheetListR tid ssh csh = do
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
           $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
       , sortable Nothing (i18nCell MsgSheetType)
-          $ \(Entity _ Sheet{..}, _, _) -> i18nCell $ SheetTypeComplete sheetType
+          $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType
       , sortable Nothing (i18nCell MsgSubmission)
           $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
               Nothing -> mempty

src/Handler/Utils/Rating.hs

@@ -2,6 +2,7 @@
 
 module Handler.Utils.Rating
   ( Rating(..), Rating'(..)
+  , validateRating
   , getRating
   , formatRating
   , ratingFile
@@ -15,12 +16,10 @@ module Handler.Utils.Rating
 
 import Import
 
-
 import Text.PrettyPrint.Leijen.Text hiding ((<$>))
 
 import Control.Monad.Trans.Maybe
 
-import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import Data.Text.Encoding.Error (UnicodeException(..))
@@ -35,9 +34,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
 
 import Text.Read (readEither)
 
-import GHC.Generics (Generic)
-import Data.Typeable (Typeable)
-
 import System.FilePath
 import qualified System.FilePath.Cryptographic as FilePath (decrypt)
 
@@ -61,29 +57,19 @@ instance Pretty SheetGrading where
   pretty PassBinary     = pretty ( "Bestanden (1) /  Nicht bestanden (0)" :: String )
 
 
-data Rating = Rating
-  { ratingCourseName :: CourseName
-  , ratingSheetName :: SheetName
-  , ratingCorrectorName :: Maybe Text
-  , ratingSheetType :: SheetType
-  , ratingValues :: Rating'
-  } deriving (Read, Show, Eq, Generic, Typeable)
-
-data Rating' = Rating'
-  { ratingPoints :: Maybe Points
-  , ratingComment :: Maybe Text
-  , ratingTime :: Maybe UTCTime
-  } deriving (Read, Show, Eq, Generic, Typeable)
-
-data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
-                     | RatingMissingSeparator -- ^ Could not split rating header from comments
-                     | RatingMultiple -- ^ Encountered multiple point values in rating
-                     | RatingInvalid String -- ^ Failed to parse rating point value
-                     | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
-  deriving (Show, Eq, Generic, Typeable)
-
-instance Exception RatingException
-
+validateRating :: SheetType -> Rating' -> [RatingException]
+validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
+  | rp < 0 
+    = [RatingNegative] 
+  | NotGraded <- ratingSheetType 
+    = [RatingNotExpected]
+  | (Just maxPoints ) <- ratingSheetType ^?  _grading . _maxPoints
+  , rp > maxPoints 
+    = [RatingExceedsMax]
+  | (Just PassBinary) <- ratingSheetType ^? _grading
+  , not (rp == 0 || rp == 1)
+    = [RatingBinaryExpected]
+validateRating _ _ = []
 
 getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
 getRating submissionId = runMaybeT $ do

src/Handler/Utils/Submission.hs

@@ -395,7 +395,7 @@ sinkSubmission userId mExists isUpdate = do
           touchSubmission
           lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
   
-      Right (submissionId', Rating'{..}) -> do
+      Right (submissionId', r'@Rating'{..}) -> do
         $logDebugS "sinkSubmission" $ tshow submissionId'
 
         unless (submissionId' == submissionId) $ do
@@ -417,9 +417,12 @@ sinkSubmission userId mExists isUpdate = do
         -- 'ratingTime' is ignored for consistency with 'File's:
         -- 
         -- 'fileModified' is simply stored and never inspected while
-        -- 'submissionChanged' is always set to @now@.
-
+        -- 'submissionChanged' is always set to @now@.          
         when anyChanges $ do
+
+          Sheet{..} <- lift $ getJust submissionSheet
+          mapM_ throwM $ validateRating sheetType r' 
+                  
           touchSubmission
           lift $ update submissionId
             [ SubmissionRatingPoints =. ratingPoints

src/Handler/Utils/Table/Cells.hs

@@ -83,9 +83,6 @@ sheetCell crse shn =
       link= CSheetR tid ssh csh shn SShowR
   in anchorCell link $ display2widget shn
 
-sheetTypeCell :: IsDBTable m a => SheetType -> DBCell m a
-sheetTypeCell sheetType = i18nCell $ SheetTypeComplete sheetType
-
 submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
 submissionCell crse shn sid =
   let tid = crse ^. _1

src/Import/NoFoundation.hs

@@ -7,6 +7,7 @@ import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJS
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
+import Model.Rating           as Import
 import Settings               as Import
 import Settings.StaticFiles   as Import
 import Yesod.Auth             as Import
@@ -37,11 +38,14 @@ import GHC.Generics           as Import (Generic)
 
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..))
+import Data.Text.Encoding.Error    as Import(UnicodeException(..))
 
 import Control.Monad.Morph    as Import (MFunctor(..))
 
 import Control.Monad.Trans.Resource as Import (ReleaseKey)
 
+import Network.Mail.Mime.Instances as Import ()
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Jobs/Handler/HelpRequest.hs

@@ -14,7 +14,7 @@ import Utils.Lens
 import Data.Bitraversable
   
 
-dispatchJobHelpRequest :: Either (Maybe Email) UserId
+dispatchJobHelpRequest :: Either (Maybe Address) UserId
                        -> UTCTime
                        -> Text -- ^ Help Request
                        -> Maybe Text -- ^ Referer
@@ -22,9 +22,10 @@ dispatchJobHelpRequest :: Either (Maybe Email) UserId
 dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
   supportAddress <- getsYesod $ appMailSupport . appSettings
   userInfo <- bitraverse return (runDB . getEntity) jSender
-  let userAddress = either (fmap $ Address Nothing)
-                           (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
-                           userInfo
+  let userAddress = either
+        id
+        (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
+        userInfo
   mailT def $ do
     _mailTo .= [supportAddress]
     whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress

src/Jobs/Types.hs

@@ -15,7 +15,7 @@ import Data.List.NonEmpty (NonEmpty)
 data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
          | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
          | JobQueueNotification { jNotification :: Notification }
-         | JobHelpRequest { jSender :: Either (Maybe Email) UserId
+         | JobHelpRequest { jSender :: Either (Maybe Address) UserId
                           , jRequestTime :: UTCTime
                           , jHelpRequest :: Text, jReferer :: Maybe Text }
          | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }         

src/Model/Rating.hs

@@ -0,0 +1,37 @@
+module Model.Rating where
+
+import ClassyPrelude.Yesod
+import Model
+
+-- import Data.Text (Text)
+import Data.Text.Encoding.Error (UnicodeException(..))
+import GHC.Generics (Generic)
+import Data.Typeable (Typeable)
+
+
+data Rating = Rating
+  { ratingCourseName :: CourseName
+  , ratingSheetName :: SheetName
+  , ratingCorrectorName :: Maybe Text
+  , ratingSheetType :: SheetType
+  , ratingValues :: Rating'
+  } deriving (Read, Show, Eq, Generic, Typeable)
+
+data Rating' = Rating'
+  { ratingPoints :: Maybe Points
+  , ratingComment :: Maybe Text
+  , ratingTime :: Maybe UTCTime
+  } deriving (Read, Show, Eq, Generic, Typeable)
+
+data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
+                     | RatingMissingSeparator -- ^ Could not split rating header from comments
+                     | RatingMultiple -- ^ Encountered multiple point values in rating
+                     | RatingInvalid String -- ^ Failed to parse rating point value
+                     | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
+                     | RatingNegative -- ^ Rating points must be non-negative
+                     | RatingExceedsMax -- ^ Rating point must not exceed maximum points
+                     | RatingNotExpected -- ^ Rating not expected
+                     | RatingBinaryExpected -- ^ Rating must be 0 or 1
+  deriving (Show, Eq, Generic, Typeable)
+
+instance Exception RatingException

src/Network/Mail/Mime/Instances.hs

@@ -0,0 +1,25 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Network.Mail.Mime.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Network.Mail.Mime
+import Data.Hashable (Hashable)
+
+import Data.Aeson
+import Data.Aeson.TH
+
+import Utils.PathPiece
+  
+
+deriving instance Read Address
+deriving instance Ord Address
+deriving instance Generic Address
+
+instance Hashable Address
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''Address

src/Settings.hs

@@ -49,6 +49,7 @@ import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, Auth
 import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
 
 import Network.Mail.Mime (Address)
+import Network.Mail.Mime.Instances ()
 
 import Mail (VerpMode)
 
@@ -255,12 +256,6 @@ deriveFromJSON
     }
   ''SmtpAuthConf
 
-deriveFromJSON
-  defaultOptions
-    { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-    }
-  ''Address
-
 
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do

src/index.md

@@ -97,6 +97,9 @@ CryptoID
 Model.Migration
   : Manuelle Datenbank-Migration
 
+Model.Rating
+  : Types for Submission Ratings that the Database does not depend on, but needed in Foundation
+
 Jobs
   : `handleJobs` worker thread handling background jobs
     `JobQueueException`

templates/mail/support.hamlet

@@ -6,9 +6,12 @@ $newline never
   <body>
     <dl>
       $case userInfo
-        $of Left (Just email)
+        $of Left (Just Address{..})
+          $maybe name <- addressName
+            <dt>Name
+            <dd>#{name}
           <dt>E-Mail
-          <dd>#{email}
+          <dd>#{addressEmail}
         $of Left  Nothing
         $of Right Nothing
           <dt>Ungültige UserId erhalten!

templates/sheetShow.hamlet

@@ -18,7 +18,7 @@ $maybe descr <- sheetDescription sheet
       <dt .deflist__dt>_{MsgSheetSolutionFrom}
       <dd .deflist__dd>#{solution}
     <dt .deflist__dt>_{MsgSheetType}
-    <dd .deflist__dd>_{SheetTypeComplete (sheetType sheet)}
+    <dd .deflist__dd>_{sheetType sheet}
     $if CorrectorSubmissions == sheetSubmissionMode sheet
       <dt .deflist__dt>_{MsgSheetPseudonym}
       <dd .deflist__dd #pseudonym>

templates/standalone/inputs.lucius

@@ -30,6 +30,12 @@
   }
 }
 
+.form-group--optional {
+  .form-group__label::after {
+    content: '';
+  }
+}
+
 .form-group--submit .form-group__input {
   grid-column: 2;
 }

test/Handler/Utils/ZipSpec.hs

@@ -18,9 +18,9 @@ import Data.Time
 
 instance Arbitrary File where
   arbitrary = do
-    fileTitle <- joinPath <$> arbitrary
+    fileTitle <- (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
     date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
-    fileModified <- addUTCTime <$> arbitrary <*> pure (UTCTime date 0)
+    fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
     fileContent <- arbitrary
     return File{..}
   shrink = genericShrink
@@ -35,8 +35,7 @@ spec = describe "Zip file handling" $ do
               = makeValid . dropWhile isPathSeparator . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid
             acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2
         (shouldBe `on` acceptableFilenameChanges) (fileTitle file') (fileTitle file)
-        when (inZipRange $ fileModified file) $
-          (fileModified file', fileModified file) `shouldSatisfy` uncurry acceptableTimeDifference
+        (fileModified file', fileModified file) `shouldSatisfy` uncurry acceptableTimeDifference
         (fileContent file') `shouldBe` (fileContent file)
 
 inZipRange :: UTCTime -> Bool