392 lines
15 KiB
Haskell
392 lines
15 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
||
{-# LANGUAGE NoImplicitPrelude #-}
|
||
{-# LANGUAGE RecordWildCards #-}
|
||
{-# LANGUAGE NamedFieldPuns #-}
|
||
{-# LANGUAGE ViewPatterns #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE TupleSections #-}
|
||
{-# LANGUAGE TypeFamilies #-}
|
||
{-# LANGUAGE LambdaCase #-}
|
||
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
||
|
||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||
|
||
module Handler.Utils.Zip.Rating
|
||
( Rating(..), Rating'(..)
|
||
, getRating
|
||
, formatRating
|
||
, ratingFile
|
||
, RatingException(..)
|
||
, UnicodeException(..)
|
||
, isRatingFile
|
||
, parseRating
|
||
, SubmissionContent
|
||
, extractRatings
|
||
, SubmissionSinkException(..)
|
||
, sinkSubmission
|
||
) where
|
||
|
||
import Import hiding ((</>))
|
||
|
||
|
||
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
|
||
|
||
import Control.Monad.Trans.Maybe
|
||
import Control.Monad.State hiding (forM_)
|
||
|
||
import Data.Text (Text)
|
||
import qualified Data.Text as Text
|
||
import qualified Data.Text.Encoding as Text
|
||
import Data.Text.Encoding.Error (UnicodeException(..))
|
||
|
||
import Data.Set (Set)
|
||
import qualified Data.Set as Set
|
||
|
||
import Data.Monoid (Monoid, Any(..))
|
||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||
|
||
import qualified Data.Text.Lazy.Encoding as Lazy.Text
|
||
|
||
import Data.CaseInsensitive (CI)
|
||
import qualified Data.CaseInsensitive as CI
|
||
|
||
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
||
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
||
|
||
import Text.Read (readEither)
|
||
|
||
import GHC.Generics (Generic)
|
||
import Data.Typeable (Typeable)
|
||
|
||
import CryptoID.Base32 as Base32
|
||
|
||
import System.FilePath
|
||
|
||
import qualified Database.Esqueleto as E
|
||
|
||
import qualified Data.Conduit.List as Conduit
|
||
|
||
|
||
instance HasResolution prec => Pretty (Fixed prec) where
|
||
pretty = pretty . show
|
||
|
||
instance Pretty x => Pretty (CI x) where
|
||
pretty = pretty . CI.original
|
||
|
||
|
||
data Rating = Rating
|
||
{ ratingCourseName :: Text
|
||
, ratingSheetName :: Text
|
||
, 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
|
||
|
||
|
||
getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
|
||
getRating submissionId = runMaybeT $ do
|
||
let query = E.select . E.from $ \(submission `E.InnerJoin` sheet `E.InnerJoin` course) -> do
|
||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
|
||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId
|
||
|
||
E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId
|
||
|
||
-- Yes, we can only pass a tuple through 'E.select'
|
||
return ( course E.^. CourseName
|
||
, sheet E.^. SheetName
|
||
, submission E.^. SubmissionRatingPoints
|
||
, submission E.^. SubmissionRatingComment
|
||
, submission E.^. SubmissionRatingTime
|
||
)
|
||
|
||
[ ( E.unValue -> ratingCourseName
|
||
, E.unValue -> ratingSheetName
|
||
, E.unValue -> ratingPoints
|
||
, E.unValue -> ratingComment
|
||
, E.unValue -> ratingTime
|
||
) ] <- lift query
|
||
|
||
return Rating{ ratingValues = Rating'{..}, .. }
|
||
|
||
formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString
|
||
formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
|
||
doc = renderPretty 1 45 $ foldr (<$$>) mempty
|
||
[ "= Bitte nur Bewertung und Kommentare ändern ="
|
||
, "============================================="
|
||
, "========== UniWorx Bewertungsdatei =========="
|
||
, "======= diese Datei ist UTF8 encodiert ======"
|
||
, "Informationen zum Übungsblatt:"
|
||
, indent 2 $ foldr (<$$>) mempty
|
||
[ "Veranstaltung:" <+> pretty ratingCourseName
|
||
, "Blatt:" <+> pretty ratingSheetName
|
||
]
|
||
, "Abgabe-Id:" <+> pretty (ciphertext cID)
|
||
, "============================================="
|
||
, "Bewertung:" <+> pretty ratingPoints
|
||
, "=========== Beginn der Kommentare ==========="
|
||
, pretty ratingComment
|
||
]
|
||
in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc
|
||
|
||
ratingFile :: CryptoFileNameSubmission -> Rating -> Maybe File
|
||
ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
|
||
fileModified <- ratingTime
|
||
let
|
||
fileTitle = "bewertung_" <> (Text.unpack . CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)) <.> "txt"
|
||
fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
|
||
return File{..}
|
||
|
||
parseRating :: MonadThrow m => File -> m Rating'
|
||
parseRating File{ fileContent = Just input, .. } = do
|
||
inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input
|
||
let
|
||
(headerLines, commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText
|
||
ratingLines = filter (rating `Text.isInfixOf`) headerLines
|
||
sep = "Beginn der Kommentare"
|
||
rating = "Bewertung:"
|
||
comment' <- case commentLines of
|
||
(_:commentLines') -> return . Text.strip $ Text.unlines commentLines'
|
||
_ -> throw RatingMissingSeparator
|
||
let
|
||
ratingComment
|
||
| Text.null comment' = Nothing
|
||
| otherwise = Just comment'
|
||
ratingLine' <- case ratingLines of
|
||
[l] -> return l
|
||
_ -> throw RatingMultiple
|
||
let
|
||
(_, ratingLine) = Text.breakOnEnd rating ratingLine'
|
||
ratingStr = Text.unpack $ Text.strip ratingLine
|
||
ratingPoints <- case () of
|
||
_ | null ratingStr -> return Nothing
|
||
| otherwise -> either (throw . RatingInvalid) return $ Just <$> readEither ratingStr
|
||
return Rating'{ ratingTime = Just fileModified, .. }
|
||
parseRating _ = throwM RatingFileIsDirectory
|
||
|
||
|
||
type SubmissionContent = Either File (SubmissionId, Rating')
|
||
|
||
extractRatings :: ( MonadHandler m
|
||
, HandlerSite m ~ UniWorX
|
||
, MonadCatch m
|
||
) => Conduit File m SubmissionContent
|
||
extractRatings = Conduit.mapM $ \f@File{..} -> do
|
||
msId <- isRatingFile fileTitle
|
||
case () of
|
||
_ | Just sId <- msId
|
||
, isJust fileContent
|
||
-> Right . (sId, ) <$> parseRating f
|
||
| otherwise -> return $ Left f
|
||
|
||
isRatingFile :: ( MonadHandler m
|
||
, HandlerSite m ~ UniWorX
|
||
, MonadCatch m
|
||
) => FilePath -> m (Maybe SubmissionId)
|
||
isRatingFile fName
|
||
| Just cID <- isRatingFile' fName = do
|
||
cIDKey <- getsYesod appCryptoIDKey
|
||
(Just <$> Base32.decrypt cIDKey cID) `catch` decryptErrors
|
||
| otherwise = return Nothing
|
||
where
|
||
|
||
decryptErrors (CiphertextConversionFailed _) = return Nothing
|
||
decryptErrors InvalidNamespaceDetected = return Nothing
|
||
decryptErrors DeserializationError = return Nothing
|
||
decryptErrors err = throwM err
|
||
|
||
isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
|
||
isRatingFile' (normalise -> fName)
|
||
| (bName, ".txt") <- splitExtension fName
|
||
, Just (CI.mk . Text.pack -> ciphertext) <- stripPrefix "bewertung_" bName
|
||
= Just CryptoID{..}
|
||
| otherwise
|
||
= Nothing
|
||
|
||
|
||
data SubmissionSinkState = SubmissionSinkState
|
||
{ sinkSeenRating :: Any
|
||
, sinkSubmissionTouched :: Any
|
||
, sinkFilenames :: Set FilePath
|
||
} deriving (Show, Eq, Generic, Typeable)
|
||
|
||
instance Monoid SubmissionSinkState where
|
||
mempty = memptydefault
|
||
mappend = mappenddefault
|
||
|
||
data SubmissionSinkException = DuplicateFileTitle FilePath
|
||
| DuplicateRating
|
||
| RatingWithoutUpdate
|
||
| ForeignRating
|
||
deriving (Typeable, Show)
|
||
|
||
instance Exception SubmissionSinkException
|
||
|
||
sinkSubmission :: SheetId
|
||
-> UserId
|
||
-> Maybe (SubmissionId, Bool {-^ Is this a correction -})
|
||
-> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
|
||
sinkSubmission sheetId userId mExists = do
|
||
now <- liftIO getCurrentTime
|
||
let
|
||
submissionSheetId = sheetId
|
||
submissionRatingPoints = Nothing
|
||
submissionRatingComment = Nothing
|
||
submissionRatingBy = Nothing
|
||
submissionRatingTime = Nothing
|
||
submissionCreated = now
|
||
submissionChanged = now
|
||
submissionCreatedBy = userId
|
||
submissionChangedBy = userId
|
||
|
||
(sId, isUpdate) <- lift $ maybe ((, False) <$> insert Submission{..}) return mExists
|
||
|
||
sId <$ sinkSubmission' sId isUpdate
|
||
where
|
||
tell = modify . mappend
|
||
|
||
sinkSubmission' :: SubmissionId
|
||
-> Bool -- ^ Is this a correction
|
||
-> Sink SubmissionContent (YesodDB UniWorX) ()
|
||
sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
|
||
Left file@(File{..}) -> do
|
||
alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
|
||
when alreadySeen . throwM $ DuplicateFileTitle fileTitle
|
||
tell $ mempty{ sinkFilenames = Set.singleton fileTitle }
|
||
|
||
collidingFiles <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
|
||
E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
|
||
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
|
||
E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
|
||
E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work
|
||
return (f, sf)
|
||
|
||
let anyChanges
|
||
| not (null collidingFiles) = any (/= file) [ f | (Entity _ f, _) <- collidingFiles ]
|
||
| otherwise = True
|
||
undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ]
|
||
-- The Eq Instance for File compares modification time exactly even
|
||
-- though zip archives have very limited accuracy and range regarding
|
||
-- timestamps.
|
||
-- We thus expect to replace files a little more often than is actually
|
||
-- necessary.
|
||
-- This was done on the premise that changes in file modification time
|
||
-- break file identity under upload and re-download.
|
||
--
|
||
-- We could check whether the new version of the file matches the
|
||
-- version of the file for which 'isUpdate' is different from this
|
||
-- one's, and, if so, simply delete the version for which 'isUpdate' is
|
||
-- 'True', reverting the correction.
|
||
--
|
||
-- This idea was discarded since modification times make this difficult
|
||
-- to implement properly – should we equate file versions that differ in
|
||
-- modification time?
|
||
|
||
when anyChanges $ do
|
||
touchSubmission
|
||
when (not $ null collidingFiles) $
|
||
lift $ deleteCascadeWhere [ FileId <-. [ fId | (Entity fId _, _) <- collidingFiles ] ]
|
||
fileId <- lift $ insert file
|
||
lift . insert_ $ SubmissionFile
|
||
{ submissionFileSubmissionId = submissionId
|
||
, submissionFileFileId = fileId
|
||
, submissionFileIsUpdate = isUpdate
|
||
, submissionFileIsDeletion = False
|
||
}
|
||
when undoneDeletion $ do
|
||
touchSubmission
|
||
lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
|
||
|
||
Right (submissionId', Rating'{..}) -> do
|
||
unless (submissionId' == submissionId) $ throwM ForeignRating
|
||
|
||
alreadySeen <- gets $ getAny . sinkSeenRating
|
||
when alreadySeen $ throwM DuplicateRating
|
||
tell $ mempty{ sinkSeenRating = Any True }
|
||
|
||
unless isUpdate $ throwM RatingWithoutUpdate
|
||
|
||
Submission{..} <- lift $ getJust submissionId
|
||
|
||
let anyChanges = or $
|
||
[ submissionRatingPoints /= ratingPoints
|
||
, submissionRatingComment /= ratingComment
|
||
]
|
||
-- 'ratingTime' is ignored for consistency with 'File's:
|
||
--
|
||
-- 'fileModified' is simply stored and never inspected while
|
||
-- 'submissionChanged' is always set to @now@.
|
||
|
||
when anyChanges $ do
|
||
touchSubmission
|
||
lift $ update submissionId
|
||
[ SubmissionRatingPoints =. ratingPoints
|
||
, SubmissionRatingComment =. ratingComment
|
||
]
|
||
where
|
||
touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) ()
|
||
touchSubmission = do
|
||
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
|
||
when (not alreadyTouched) $ do
|
||
now <- liftIO getCurrentTime
|
||
lift . update submissionId $ case isUpdate of
|
||
False -> [ SubmissionChangedBy =. userId, SubmissionChanged =. now ]
|
||
True -> [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
|
||
tell $ mempty{ sinkSubmissionTouched = Any True }
|
||
|
||
finalize :: SubmissionSinkState -> YesodDB UniWorX ()
|
||
finalize SubmissionSinkState{..} = do
|
||
missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
||
E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
|
||
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
|
||
when (not isUpdate) $
|
||
E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
|
||
E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
|
||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
||
|
||
return (f, sf)
|
||
|
||
case isUpdate of
|
||
False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ]
|
||
True -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do
|
||
shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
|
||
E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
|
||
E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
|
||
E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate)
|
||
E.where_ $ f E.^. FileTitle E.==. E.val fileTitle
|
||
return $ f E.^. FileId
|
||
|
||
case (shadowing, submissionFileIsUpdate) of
|
||
([], _) -> deleteCascade fileId
|
||
(E.Value f:_, False) -> do
|
||
insert_ $ SubmissionFile
|
||
{ submissionFileSubmissionId = submissionId
|
||
, submissionFileFileId = f
|
||
, submissionFileIsUpdate = True
|
||
, submissionFileIsDeletion = True
|
||
}
|
||
(E.Value f:_, True) -> do
|
||
update sfId [ SubmissionFileFileId =. f, SubmissionFileIsDeletion =. True ]
|
||
deleteCascade fileId
|
||
|
||
when (isUpdate && not (getAny sinkSeenRating)) $
|
||
update submissionId
|
||
[ SubmissionRatingTime =. Nothing
|
||
, SubmissionRatingPoints =. Nothing
|
||
, SubmissionRatingBy =. Nothing
|
||
, SubmissionRatingComment =. Nothing
|
||
]
|