227 lines
9.1 KiB
Haskell
227 lines
9.1 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
|
|
module Handler.Corrections where
|
|
|
|
import Import
|
|
-- import System.FilePath (takeFileName)
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Submission
|
|
-- import Handler.Utils.Zip
|
|
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
|
|
-- import Data.Time
|
|
-- import qualified Data.Text as T
|
|
-- import Data.Function ((&))
|
|
--
|
|
import Colonnade hiding (fromMaybe, singleton)
|
|
-- import Yesod.Colonnade
|
|
--
|
|
-- import qualified Data.UUID.Cryptographic as UUID
|
|
-- import qualified Data.Conduit.List as C
|
|
|
|
import qualified Database.Esqueleto as E
|
|
-- import qualified Database.Esqueleto.Internal.Sql as E
|
|
|
|
import Control.Lens
|
|
-- import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
|
|
|
-- import Network.Mime
|
|
|
|
import Web.PathPieces
|
|
|
|
|
|
|
|
type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
|
|
(expr (Entity Course), expr (Entity Sheet), expr (Entity Submission))
|
|
-> expr (E.Value Bool)
|
|
|
|
ratedBy :: Key User -> CorrectionsWhere
|
|
ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
|
|
|
courseIs :: Key Course -> CorrectionsWhere
|
|
courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
|
|
|
|
|
|
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)))
|
|
|
|
colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
|
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
|
$ \DBRow{ dbrOutput=(_, _, course) } ->
|
|
-- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester
|
|
textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel
|
|
|
|
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
|
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
|
$ \DBRow{ dbrOutput=(_, _, course) } -> cell $
|
|
let tid = E.unValue $ course ^. _3
|
|
csh = E.unValue $ course ^. _2
|
|
in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
|
|
|
|
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
|
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
|
$ \DBRow{ dbrOutput=(_, sheet, course) } -> cell $
|
|
let tid = E.unValue $ course ^. _3
|
|
csh = E.unValue $ course ^. _2
|
|
shn = sheetName $ entityVal sheet
|
|
in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
|
|
-- textCell $ sheetName $ entityVal sheet
|
|
|
|
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
|
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector)
|
|
$ \DBRow{ dbrOutput=(submission, _, _) } ->
|
|
textCell $ display $ submissionRatingBy $ entityVal submission
|
|
|
|
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
|
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
|
$ \DBRow{ dbrOutput=(submission, sheet, course) } -> cell $ do
|
|
let tid = E.unValue $ course ^. _3
|
|
csh = E.unValue $ course ^. _2
|
|
shn = sheetName $ entityVal sheet
|
|
cid <- encrypt (entityKey submission :: SubmissionId)
|
|
[whamlet|<a href=@{CSheetR tid csh shn (SubmissionR cid)}>#{display cid}|]
|
|
|
|
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
|
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _) } -> encrypt subId
|
|
|
|
makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h )
|
|
=> _ -> Colonnade h r' (DBCell m x) -> Handler (DBResult m x)
|
|
makeCorrectionsTable whereClause colChoices = do
|
|
let tableData :: E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity Course))
|
|
(E.SqlExpr (Entity Sheet )))
|
|
(E.SqlExpr (Entity Submission))
|
|
-> E.SqlQuery _
|
|
tableData (course `E.InnerJoin` sheet `E.InnerJoin` submission) = do
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ whereClause (course,sheet,submission)
|
|
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value Text)
|
|
, course E.^. CourseShorthand
|
|
, course E.^. CourseTerm
|
|
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
|
|
)
|
|
return (submission, sheet, crse)
|
|
dbTable def $ DBTable
|
|
{ dbtSQLQuery = tableData
|
|
, dbtColonnade = colChoices
|
|
, dbtSorting = [ ( "term"
|
|
, SortColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) -> course E.^. CourseTerm
|
|
)
|
|
, ( "course"
|
|
, SortColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) -> course E.^. CourseShorthand
|
|
)
|
|
-- TODO
|
|
]
|
|
, dbtFilter = [] {- [ ( "term"
|
|
, FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
|
|
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
|
)
|
|
] -}
|
|
, dbtAttrs = tableDefault
|
|
, dbtIdent = "corrections" :: Text
|
|
}
|
|
|
|
data ActionCorrections = CorrDownload
|
|
| CorrSetCorrector
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
|
instance PathPiece ActionCorrections where
|
|
fromPathPiece = readFromPathPiece
|
|
toPathPiece = showToPathPiece
|
|
|
|
instance RenderMessage UniWorX ActionCorrections where
|
|
renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
|
|
renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
|
|
|
|
data ActionCorrectionsData = CorrDownloadData
|
|
| CorrSetCorrectorData UserId
|
|
|
|
correctionsR :: _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Widget)) -> Handler TypedContent
|
|
correctionsR whereClause (formColonnade -> displayColumns) actions = do
|
|
tableForm <- makeCorrectionsTable whereClause displayColumns
|
|
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
|
|
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
|
|
(actionRes, action) <- multiAction actions
|
|
return ((,) <$> actionRes <*> selectionRes, table <> action)
|
|
|
|
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
|
|
case actionRes of
|
|
FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs
|
|
FormMissing -> return ()
|
|
FormSuccess (CorrDownloadData, subs) -> do
|
|
(Set.fromList -> ids) <- forM (Set.toList subs) decrypt
|
|
addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\""
|
|
sendResponse =<< submissionMultiArchive ids
|
|
FormSuccess (CorrSetCorrectorData uid, subs) -> do
|
|
addMessage "danger" $ "Setting correctors not implemented yet" -- TODO
|
|
redirect currentRoute
|
|
|
|
fmap toTypedContent . defaultLayout $ do
|
|
setTitleI MsgCourseCorrectionsTitle
|
|
$(widgetFile "corrections")
|
|
|
|
|
|
type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Widget))
|
|
|
|
downloadAction :: ActionCorrections'
|
|
downloadAction = ( CorrDownload
|
|
, return (pure CorrDownloadData, mempty)
|
|
)
|
|
|
|
assignAction :: ActionCorrections'
|
|
assignAction = ( CorrSetCorrector
|
|
, return (pure undefined, mempty) -- TODO
|
|
)
|
|
|
|
getCorrectionsR, postCorrectionsR :: Handler TypedContent
|
|
getCorrectionsR = postCorrectionsR
|
|
postCorrectionsR = do
|
|
uid <- requireAuthId
|
|
let whereClause = ratedBy uid
|
|
colonnade = mconcat
|
|
[ colSelect
|
|
, dbRow
|
|
, colTerm
|
|
, colCourse
|
|
, colSheet
|
|
, colSubmissionLink
|
|
] -- Continue here
|
|
correctionsR whereClause colonnade $ Map.fromList
|
|
[ downloadAction
|
|
]
|
|
|
|
getCourseCorrectionsR, postCourseCorrectionsR :: TermId -> Text -> Handler TypedContent
|
|
getCourseCorrectionsR = postCourseCorrectionsR
|
|
postCourseCorrectionsR tid csh = do
|
|
cid <- runDB $ getBy404 $ CourseTermShort tid csh
|
|
let whereClause = courseIs $ entityKey cid
|
|
colonnade = mconcat
|
|
[ colSelect
|
|
, dbRow
|
|
, colSheet
|
|
, colCorrector
|
|
, colSubmissionLink
|
|
] -- Continue here
|
|
correctionsR whereClause colonnade $ Map.fromList
|
|
[ downloadAction
|
|
, assignAction
|
|
]
|