From 1d69bd8d078852634b3efd2e6fdbf530864535aa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 9 Nov 2018 13:57:11 +0100 Subject: [PATCH 1/4] Allow setting name when sending help request without account --- src/Handler/Home.hs | 6 +++--- src/Import/NoFoundation.hs | 2 ++ src/Jobs/Handler/HelpRequest.hs | 9 +++++---- src/Jobs/Types.hs | 2 +- src/Network/Mail/Mime/Instances.hs | 25 +++++++++++++++++++++++++ src/Settings.hs | 7 +------ templates/mail/support.hamlet | 7 +++++-- templates/standalone/inputs.lucius | 6 ++++++ 8 files changed, 48 insertions(+), 16 deletions(-) create mode 100644 src/Network/Mail/Mime/Instances.hs diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 479e50a97..32e0f0ec9 100644 --- a/src/Handler/Home.hs +++ b/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) ] diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9d80282a3..6983ce3de 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -42,6 +42,8 @@ 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) diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index d1f98d5ad..1ec904e2b 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 6a6e65109..b07fcaf52 100644 --- a/src/Jobs/Types.hs +++ b/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 } diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs new file mode 100644 index 000000000..b7d1b26d6 --- /dev/null +++ b/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 diff --git a/src/Settings.hs b/src/Settings.hs index b91a2b6a4..b05ae3c5d 100644 --- a/src/Settings.hs +++ b/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 diff --git a/templates/mail/support.hamlet b/templates/mail/support.hamlet index 1b3d7e1f7..da915339e 100644 --- a/templates/mail/support.hamlet +++ b/templates/mail/support.hamlet @@ -6,9 +6,12 @@ $newline never
$case userInfo - $of Left (Just email) + $of Left (Just Address{..}) + $maybe name <- addressName +
Name +
#{name}
E-Mail -
#{email} +
#{addressEmail} $of Left Nothing $of Right Nothing
Ungültige UserId erhalten! diff --git a/templates/standalone/inputs.lucius b/templates/standalone/inputs.lucius index 470efdb1b..54e6aa5a6 100644 --- a/templates/standalone/inputs.lucius +++ b/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; } From 7bc72505a4311d621af3ca46979cd95359bff621 Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 9 Nov 2018 13:59:14 +0100 Subject: [PATCH 2/4] Ratings are now validated, some refactoring --- .vscode/tasks.json | 16 ++++++++++-- ChangeLog.md | 7 ++++++ messages/uniworx/de.msg | 10 ++++++++ src/Foundation.hs | 14 ++++++----- src/Handler/Corrections.hs | 39 ++++++++++++++++------------- src/Handler/Sheet.hs | 2 +- src/Handler/Utils/Rating.hs | 42 +++++++++++--------------------- src/Handler/Utils/Submission.hs | 9 ++++--- src/Handler/Utils/Table/Cells.hs | 3 --- src/Import/NoFoundation.hs | 2 ++ src/Model/Rating.hs | 37 ++++++++++++++++++++++++++++ src/index.md | 3 +++ templates/sheetShow.hamlet | 2 +- 13 files changed, 125 insertions(+), 61 deletions(-) create mode 100644 src/Model/Rating.hs diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 88fe3a8fb..ac3e4e9ee 100644 --- a/.vscode/tasks.json +++ b/.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 + } } ] } \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md index e5e39dee3..8448a5c55 100644 --- a/ChangeLog.md +++ b/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 diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index bf3acc5d3..6b9c99c63 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 5b7ec8500..6dbc131bf 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index d89257eee..e97f93c9e 100644 --- a/src/Handler/Corrections.hs +++ b/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 () diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 97ef5fcfb..b40e165de 100644 --- a/src/Handler/Sheet.hs +++ b/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 diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 269fd927a..be259344f 100644 --- a/src/Handler/Utils/Rating.hs +++ b/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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index e6cbe3c37..c1e2648c5 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 8dc0e38ee..85d8571f7 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9d80282a3..7ad1135ca 100644 --- a/src/Import/NoFoundation.hs +++ b/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,6 +38,7 @@ 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(..)) diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs new file mode 100644 index 000000000..6ce7760f5 --- /dev/null +++ b/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 diff --git a/src/index.md b/src/index.md index 2fcfbeaa6..563023e8b 100644 --- a/src/index.md +++ b/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` diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 7776c0bc8..9efdc5e24 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -18,7 +18,7 @@ $maybe descr <- sheetDescription sheet
_{MsgSheetSolutionFrom}
#{solution}
_{MsgSheetType} -
_{SheetTypeComplete (sheetType sheet)} +
_{sheetType sheet} $if CorrectorSubmissions == sheetSubmissionMode sheet
_{MsgSheetPseudonym}
From aa2d33922a9ca06e407ee362b5c4ddb08cefb9b3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 9 Nov 2018 14:53:07 +0100 Subject: [PATCH 3/4] Fix tests --- test/Handler/Utils/ZipSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index eca7d9c6a..b18dbe8ab 100644 --- a/test/Handler/Utils/ZipSpec.hs +++ b/test/Handler/Utils/ZipSpec.hs @@ -18,7 +18,7 @@ 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) fileContent <- arbitrary From 7d132bf7791f57c43f4928aa0824cf98c313426f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 9 Nov 2018 14:58:37 +0100 Subject: [PATCH 4/4] Minor cleanup --- test/Handler/Utils/ZipSpec.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index b18dbe8ab..031a7d153 100644 --- a/test/Handler/Utils/ZipSpec.hs +++ b/test/Handler/Utils/ZipSpec.hs @@ -20,7 +20,7 @@ instance Arbitrary File where arbitrary = do 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