143 lines
5.1 KiB
Haskell
143 lines
5.1 KiB
Haskell
module Handler.Utils.Rating
|
|
( Rating(..), Rating'(..)
|
|
, validateRating
|
|
, getRating
|
|
, ratingFile
|
|
, isRatingFile
|
|
, SubmissionContent
|
|
, extractRatings
|
|
, module Handler.Utils.Rating.Format
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils.DateTime (getDateTimeFormatter)
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Conduit.List as Conduit
|
|
|
|
import Handler.Utils.Rating.Format
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
validateRating :: SheetType -> Rating' -> [RatingValidityException]
|
|
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 ratingSheetType Rating'{ .. }
|
|
| has _grading ratingSheetType
|
|
, is _Nothing ratingPoints
|
|
, ratingDone
|
|
, hasn't (_grading . _PassAlways) ratingSheetType
|
|
= [RatingPointsRequired]
|
|
validateRating _ _ = []
|
|
|
|
getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
|
|
getRating submissionId = runMaybeT $ do
|
|
let query = E.select . E.from $ \(corrector `E.RightOuterJoin` (submission `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` school)) -> do
|
|
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
|
|
|
E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId
|
|
|
|
-- Yes, we can only pass a tuple through 'E.select'
|
|
return ( course E.^. CourseTerm
|
|
, school E.^. SchoolName
|
|
, course E.^. CourseName
|
|
, sheet E.^. SheetName
|
|
, corrector E.?. UserDisplayName
|
|
, sheet E.^. SheetType
|
|
, submission
|
|
)
|
|
|
|
[ ( unTermKey . E.unValue -> ratingCourseTerm
|
|
, E.unValue -> ratingCourseSchool
|
|
, E.unValue -> ratingCourseName
|
|
, E.unValue -> ratingSheetName
|
|
, E.unValue -> ratingCorrectorName
|
|
, E.unValue -> ratingSheetType
|
|
, E.Entity _ sub@Submission{..}
|
|
) ] <- lift query
|
|
|
|
let ratingPoints = submissionRatingPoints
|
|
ratingComment = submissionRatingComment
|
|
ratingTime = submissionRatingTime
|
|
ratingDone = submissionRatingDone sub
|
|
|
|
return Rating{ ratingValues = Rating'{..}, .. }
|
|
|
|
extensionRating :: String
|
|
extensionRating = "txt"
|
|
|
|
ratingFile :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> CryptoFileNameSubmission -> Rating -> m File
|
|
ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
|
|
mr'@(MsgRenderer mr) <- getMsgRenderer
|
|
dtFmt <- getDateTimeFormatter
|
|
fileModified <- maybe (liftIO getCurrentTime) return ratingTime
|
|
let
|
|
fileTitle = ensureExtension extensionRating . unpack . mr $ MsgRatingFileTitle cID
|
|
fileContent = Just . Lazy.ByteString.toStrict $ formatRating mr' dtFmt cID rating
|
|
return File{..}
|
|
where ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName
|
|
|
|
type SubmissionContent = Either File (SubmissionId, Rating')
|
|
|
|
extractRatings :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
) => ConduitT File SubmissionContent m ()
|
|
extractRatings = Conduit.mapM $ \f@File{..} -> liftHandler $ do
|
|
msId <- isRatingFile fileTitle
|
|
case () of
|
|
_ | Just sId <- msId
|
|
, isJust fileContent -> do
|
|
(rating, cID) <- handle (throwM . RatingFileException fileTitle) $ parseRating f
|
|
sId' <- traverse decrypt cID
|
|
unless (maybe (const True) (==) sId' sId) $
|
|
throwM $ RatingFileException fileTitle RatingSubmissionIDIncorrect
|
|
return $ Right (sId, rating)
|
|
| otherwise -> return $ Left f
|
|
|
|
isRatingFile :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
) => FilePath -> m (Maybe SubmissionId)
|
|
isRatingFile fName = liftHandler $
|
|
fmap getFirst . flip foldMapM segments' $ fmap First . tryDecrypt
|
|
where
|
|
tryDecrypt :: Text -> Handler (Maybe SubmissionId)
|
|
tryDecrypt ciphertext
|
|
| Just cID <- fromPathPiece ciphertext
|
|
= (Just <$> decrypt (cID :: CryptoFileNameSubmission)) `catch` decryptErrors
|
|
| otherwise
|
|
= return Nothing
|
|
|
|
decryptErrors (CiphertextConversionFailed _) = return Nothing
|
|
decryptErrors InvalidNamespaceDetected = return Nothing
|
|
decryptErrors DeserializationError = return Nothing
|
|
decryptErrors err = throwM err
|
|
|
|
segments' = filter (not . Text.null) . Text.split (flip Set.notMember cryptoIdChars . CI.mk) . Text.pack $ takeFileName fName
|
|
|
|
cryptoIdChars :: Set (CI Char)
|
|
cryptoIdChars = Set.fromList . map CI.mk $ "uwa" ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
|